anil.recoil.org
+20
-1
.gitignore
+20
-1
.gitignore
···
1
-
_build
1
+
# OCaml build artifacts
2
+
_build/
3
+
*.install
4
+
*.merlin
5
+
6
+
# Third-party sources (fetch locally with opam source)
7
+
third_party/
8
+
9
+
# Editor and OS files
10
+
.DS_Store
11
+
*.swp
12
+
*~
13
+
.vscode/
14
+
.idea/
15
+
16
+
# Opam local switch
17
+
_opam/
18
+
19
+
# Environment and secrets
2
20
.env
3
21
.api-key
22
+
.api-key-rw
4
23
.api-url
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version=0.28.1
+53
.tangled/workflows/build.yml
+53
.tangled/workflows/build.yml
···
1
+
when:
2
+
- event: ["push", "pull_request"]
3
+
branch: ["main"]
4
+
5
+
engine: nixery
6
+
7
+
dependencies:
8
+
nixpkgs:
9
+
- shell
10
+
- stdenv
11
+
- findutils
12
+
- binutils
13
+
- libunwind
14
+
- ncurses
15
+
- opam
16
+
- git
17
+
- gawk
18
+
- gnupatch
19
+
- gnum4
20
+
- gnumake
21
+
- gnutar
22
+
- gnused
23
+
- gnugrep
24
+
- diffutils
25
+
- gzip
26
+
- bzip2
27
+
- gcc
28
+
- ocaml
29
+
- pkg-config
30
+
31
+
steps:
32
+
- name: opam
33
+
command: |
34
+
opam init --disable-sandboxing -a -y
35
+
- name: repo
36
+
command: |
37
+
opam repo add aoah https://tangled.org/anil.recoil.org/aoah-opam-repo.git
38
+
- name: switch
39
+
command: |
40
+
opam install . --confirm-level=unsafe-yes --deps-only
41
+
- name: build
42
+
command: |
43
+
opam exec -- dune build -p jmap
44
+
- name: switch-test
45
+
command: |
46
+
opam install . --confirm-level=unsafe-yes --deps-only --with-test
47
+
- name: test
48
+
command: |
49
+
opam exec -- dune runtest --verbose
50
+
- name: doc
51
+
command: |
52
+
opam install -y odoc
53
+
opam exec -- dune build @doc
+15
LICENSE.md
+15
LICENSE.md
···
1
+
ISC License
2
+
3
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>
4
+
5
+
Permission to use, copy, modify, and distribute this software for any
6
+
purpose with or without fee is hereby granted, provided that the above
7
+
copyright notice and this permission notice appear in all copies.
8
+
9
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10
+
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11
+
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12
+
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13
+
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14
+
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15
+
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+54
README.md
+54
README.md
···
1
+
# ocaml-jmap - JMAP Protocol Implementation for OCaml
2
+
3
+
A complete implementation of the JSON Meta Application Protocol (JMAP) as specified in RFC 8620 (core) and RFC 8621 (mail).
4
+
5
+
## Packages
6
+
7
+
- **jmap** - Core JMAP protocol types and serialization
8
+
- **jmap-eio** - JMAP client using Eio for async I/O
9
+
- **jmap-brr** - JMAP client for browsers using js_of_ocaml
10
+
11
+
## Key Features
12
+
13
+
- Full RFC 8620 (JMAP Core) support: sessions, accounts, method calls, and error handling
14
+
- Full RFC 8621 (JMAP Mail) support: mailboxes, emails, threads, identities, and submissions
15
+
- Type-safe API with comprehensive type definitions
16
+
- Multiple backends: Eio for native async, Brr for browser-based clients
17
+
- JSON serialization via jsont
18
+
19
+
## Usage
20
+
21
+
```ocaml
22
+
(* Query emails from a mailbox *)
23
+
open Jmap
24
+
25
+
let query_emails ~client ~account_id ~mailbox_id =
26
+
let filter = Email.Query.Filter.(in_mailbox mailbox_id) in
27
+
let query = Email.Query.make ~account_id ~filter () in
28
+
Client.call client query
29
+
```
30
+
31
+
## Installation
32
+
33
+
```
34
+
opam install jmap jmap-eio
35
+
```
36
+
37
+
For browser-based applications:
38
+
39
+
```
40
+
opam install jmap jmap-brr
41
+
```
42
+
43
+
## Documentation
44
+
45
+
API documentation is available via:
46
+
47
+
```
48
+
opam install jmap
49
+
odig doc jmap
50
+
```
51
+
52
+
## License
53
+
54
+
ISC
+14
-4
bin/dune
+14
-4
bin/dune
···
1
1
(executable
2
-
(name jmap_test)
3
-
(public_name jmap-test)
4
-
(package jmap-eio)
5
-
(libraries jmap-eio eio_main))
2
+
(name jmap)
3
+
(public_name jmap)
4
+
(package jmap)
5
+
(optional)
6
+
(modules jmap)
7
+
(libraries jmap.eio eio_main))
8
+
9
+
(executable
10
+
(name jmapq)
11
+
(public_name jmapq)
12
+
(package jmap)
13
+
(optional)
14
+
(modules jmapq)
15
+
(libraries jmap.eio eio_main re jsont.bytesrw))
+8
-8
bin/fastmail_list.ml
+8
-8
bin/fastmail_list.ml
···
18
18
19
19
open Lwt.Syntax
20
20
open Jmap
21
-
open Jmap_mail
21
+
open Jmap.Mail
22
22
open Cmdliner
23
-
module Mail = Jmap_mail.Types
23
+
module Mail = Jmap.Proto.Types
24
24
25
25
(** Prints the email details *)
26
26
let print_email ~show_labels (email : Mail.email) =
···
42
42
(* Format labels/keywords if requested *)
43
43
let labels_str =
44
44
if show_labels then
45
-
let formatted = Jmap_mail.Types.format_email_keywords email.keywords in
45
+
let formatted = Jmap.Proto.Types.format_email_keywords email.keywords in
46
46
if formatted <> "" then
47
47
" [" ^ formatted ^ "]"
48
48
else
···
73
73
Printf.printf "=====================\n";
74
74
75
75
(* Step 1: Get all mailboxes *)
76
-
let* mailboxes_result = Jmap_mail.get_mailboxes conn ~account_id in
76
+
let* mailboxes_result = Jmap.Proto.get_mailboxes conn ~account_id in
77
77
match mailboxes_result with
78
78
| Error err ->
79
79
Printf.printf "Error getting mailboxes: %s\n" (Api.string_of_error err);
···
90
90
Printf.printf "Using mailbox: %s\n" first_mailbox.Mail.name;
91
91
92
92
(* Step 3: Get emails from the selected mailbox *)
93
-
let* emails_result = Jmap_mail.get_messages_in_mailbox
93
+
let* emails_result = Jmap.Proto.get_messages_in_mailbox
94
94
conn
95
95
~account_id
96
96
~mailbox_id:first_mailbox.Mail.id
···
108
108
(List.length emails);
109
109
110
110
(* Display some basic information about the emails *)
111
-
List.iteri (fun i (email:Jmap_mail.Types.email) ->
111
+
List.iteri (fun i (email:Jmap.Proto.Types.email) ->
112
112
let subject = Option.value ~default:"<no subject>" email.Mail.subject in
113
113
Printf.printf " %d. %s\n" (i + 1) subject
114
114
) emails;
···
159
159
| Ok conn ->
160
160
(* Get the primary account ID *)
161
161
let primary_account_id =
162
-
let mail_capability = Jmap_mail.Capability.to_string Jmap_mail.Capability.Mail in
162
+
let mail_capability = Jmap.Proto.Capability.to_string Jmap.Proto.Capability.Mail in
163
163
match List.assoc_opt mail_capability conn.session.primary_accounts with
164
164
| Some id -> id
165
165
| None ->
···
220
220
if sender_filter <> "" then begin
221
221
Printf.printf "Filtering by sender: %s\n" sender_filter;
222
222
List.filter (fun email ->
223
-
Jmap_mail.email_matches_sender email sender_filter
223
+
Jmap.Proto.email_matches_sender email sender_filter
224
224
) filtered_by_unread
225
225
end else
226
226
filtered_by_unread
+7
-7
bin/fastmail_send.ml
+7
-7
bin/fastmail_send.ml
···
52
52
(* Initialize JMAP connection *)
53
53
let fastmail_uri = "https://api.fastmail.com/jmap/session" in
54
54
Lwt_main.run begin
55
-
let* conn_result = Jmap_mail.login_with_token ~uri:fastmail_uri ~api_token:token in
55
+
let* conn_result = Jmap.Proto.login_with_token ~uri:fastmail_uri ~api_token:token in
56
56
match conn_result with
57
57
| Error err ->
58
58
let msg = Jmap.Api.string_of_error err in
···
78
78
| Some email -> Lwt.return_ok email
79
79
| None ->
80
80
(* Get first available identity *)
81
-
let* identities_result = Jmap_mail.get_identities conn ~account_id in
81
+
let* identities_result = Jmap.Proto.get_identities conn ~account_id in
82
82
match identities_result with
83
83
| Ok [] ->
84
84
log_error "No identities found for account";
···
99
99
(String.concat ", " to_addresses);
100
100
101
101
let* submission_result =
102
-
Jmap_mail.create_and_submit_email
102
+
Jmap.Proto.create_and_submit_email
103
103
conn
104
104
~account_id
105
105
~from:from_email
···
118
118
log_success "Email sent successfully (Submission ID: %s)" submission_id;
119
119
(* Wait briefly then check submission status *)
120
120
let* () = Lwt_unix.sleep 1.0 in
121
-
let* status_result = Jmap_mail.get_submission_status
121
+
let* status_result = Jmap.Proto.get_submission_status
122
122
conn
123
123
~account_id
124
124
~submission_id
···
126
126
127
127
(match status_result with
128
128
| Ok status ->
129
-
let status_text = match status.Jmap_mail.Types.undo_status with
129
+
let status_text = match status.Jmap.Proto.Types.undo_status with
130
130
| Some `pending -> "Pending"
131
131
| Some `final -> "Final (delivered)"
132
132
| Some `canceled -> "Canceled"
···
134
134
in
135
135
log_info "Submission status: %s" status_text;
136
136
137
-
(match status.Jmap_mail.Types.delivery_status with
137
+
(match status.Jmap.Proto.Types.delivery_status with
138
138
| Some statuses ->
139
139
List.iter (fun (email, status) ->
140
-
let delivery = match status.Jmap_mail.Types.delivered with
140
+
let delivery = match status.Jmap.Proto.Types.delivered with
141
141
| Some "yes" -> "Delivered"
142
142
| Some "no" -> "Failed"
143
143
| Some "queued" -> "Queued"
-114
bin/flag_color_test.ml
-114
bin/flag_color_test.ml
···
1
-
(** Demo of message flags and mailbox attributes functionality *)
2
-
3
-
open Jmap_mail.Types
4
-
5
-
(** Demonstrate flag color functionality *)
6
-
let demo_flag_colors () =
7
-
Printf.printf "Flag Color Demo:\n";
8
-
Printf.printf "================\n";
9
-
10
-
(* Show all flag colors and their bit patterns *)
11
-
let colors = [Red; Orange; Yellow; Green; Blue; Purple; Gray] in
12
-
List.iter (fun color ->
13
-
let (bit0, bit1, bit2) = bits_of_flag_color color in
14
-
Printf.printf "Color: %-7s Bits: %d%d%d\n"
15
-
(match color with
16
-
| Red -> "Red"
17
-
| Orange -> "Orange"
18
-
| Yellow -> "Yellow"
19
-
| Green -> "Green"
20
-
| Blue -> "Blue"
21
-
| Purple -> "Purple"
22
-
| Gray -> "Gray")
23
-
(if bit0 then 1 else 0)
24
-
(if bit1 then 1 else 0)
25
-
(if bit2 then 1 else 0)
26
-
) colors;
27
-
28
-
Printf.printf "\n"
29
-
30
-
(** Demonstrate message keyword functionality *)
31
-
let demo_message_keywords () =
32
-
Printf.printf "Message Keywords Demo:\n";
33
-
Printf.printf "=====================\n";
34
-
35
-
(* Show all standard message keywords and their string representations *)
36
-
let keywords = [
37
-
Notify; Muted; Followed; Memo; HasMemo; HasAttachment; HasNoAttachment;
38
-
AutoSent; Unsubscribed; CanUnsubscribe; Imported; IsTrusted;
39
-
MaskedEmail; New; MailFlagBit0; MailFlagBit1; MailFlagBit2
40
-
] in
41
-
42
-
List.iter (fun kw ->
43
-
Printf.printf "%-15s -> %s\n"
44
-
(match kw with
45
-
| Notify -> "Notify"
46
-
| Muted -> "Muted"
47
-
| Followed -> "Followed"
48
-
| Memo -> "Memo"
49
-
| HasMemo -> "HasMemo"
50
-
| HasAttachment -> "HasAttachment"
51
-
| HasNoAttachment -> "HasNoAttachment"
52
-
| AutoSent -> "AutoSent"
53
-
| Unsubscribed -> "Unsubscribed"
54
-
| CanUnsubscribe -> "CanUnsubscribe"
55
-
| Imported -> "Imported"
56
-
| IsTrusted -> "IsTrusted"
57
-
| MaskedEmail -> "MaskedEmail"
58
-
| New -> "New"
59
-
| MailFlagBit0 -> "MailFlagBit0"
60
-
| MailFlagBit1 -> "MailFlagBit1"
61
-
| MailFlagBit2 -> "MailFlagBit2"
62
-
| OtherKeyword s -> "Other: " ^ s)
63
-
(string_of_message_keyword kw)
64
-
) keywords;
65
-
66
-
Printf.printf "\n"
67
-
68
-
(** Demonstrate mailbox attribute functionality *)
69
-
let demo_mailbox_attributes () =
70
-
Printf.printf "Mailbox Attributes Demo:\n";
71
-
Printf.printf "=======================\n";
72
-
73
-
(* Show all standard mailbox attributes and their string representations *)
74
-
let attributes = [Snoozed; Scheduled; Memos] in
75
-
76
-
List.iter (fun attr ->
77
-
Printf.printf "%-10s -> %s\n"
78
-
(match attr with
79
-
| Snoozed -> "Snoozed"
80
-
| Scheduled -> "Scheduled"
81
-
| Memos -> "Memos"
82
-
| OtherAttribute s -> "Other: " ^ s)
83
-
(string_of_mailbox_attribute attr)
84
-
) attributes;
85
-
86
-
Printf.printf "\n"
87
-
88
-
(** Demonstrate formatting functionality *)
89
-
let demo_formatting () =
90
-
Printf.printf "Keyword Formatting Demo:\n";
91
-
Printf.printf "======================\n";
92
-
93
-
(* Create a sample email with various keywords *)
94
-
let sample_keywords = [
95
-
(Flagged, true); (* Standard flag *)
96
-
(Custom "$MailFlagBit0", true); (* Flag color bit *)
97
-
(Custom "$MailFlagBit2", true); (* Flag color bit *)
98
-
(Custom "$notify", true); (* Message keyword *)
99
-
(Custom "$followed", true); (* Message keyword *)
100
-
(Custom "$hasattachment", true); (* Message keyword *)
101
-
(Seen, false); (* Inactive keyword *)
102
-
(Custom "$random", true); (* Unknown keyword *)
103
-
] in
104
-
105
-
(* Test formatted output *)
106
-
let formatted = format_email_keywords sample_keywords in
107
-
Printf.printf "Formatted keywords: %s\n\n" formatted
108
-
109
-
(** Main entry point *)
110
-
let () =
111
-
demo_flag_colors ();
112
-
demo_message_keywords ();
113
-
demo_mailbox_attributes ();
114
-
demo_formatting ()
+1552
bin/jmap.ml
+1552
bin/jmap.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP command-line client *)
7
+
8
+
open Cmdliner
9
+
10
+
(** {1 Helpers} *)
11
+
12
+
let ptime_to_string t =
13
+
let (y, m, d), ((hh, mm, ss), _tz) = Ptime.to_date_time t in
14
+
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" y m d hh mm ss
15
+
16
+
let truncate_string max_len s =
17
+
if String.length s <= max_len then s
18
+
else String.sub s 0 (max_len - 3) ^ "..."
19
+
20
+
let format_email_address (addr : Jmap.Proto.Email_address.t) =
21
+
match addr.name with
22
+
| Some name -> Printf.sprintf "%s <%s>" name addr.email
23
+
| None -> addr.email
24
+
25
+
let format_email_addresses addrs =
26
+
String.concat ", " (List.map format_email_address addrs)
27
+
28
+
let format_keywords keywords =
29
+
keywords
30
+
|> List.filter_map (fun (k, v) -> if v then Some k else None)
31
+
|> String.concat " "
32
+
33
+
(* Helpers for optional Email fields *)
34
+
let email_id (e : Jmap.Proto.Email.t) =
35
+
match e.id with Some id -> Jmap.Proto.Id.to_string id | None -> "?"
36
+
37
+
let email_received_at (e : Jmap.Proto.Email.t) =
38
+
match e.received_at with Some t -> ptime_to_string t | None -> "?"
39
+
40
+
let email_keywords (e : Jmap.Proto.Email.t) =
41
+
Option.value ~default:[] e.keywords
42
+
43
+
let email_preview (e : Jmap.Proto.Email.t) =
44
+
Option.value ~default:"" e.preview
45
+
46
+
let email_thread_id (e : Jmap.Proto.Email.t) =
47
+
match e.thread_id with Some id -> Jmap.Proto.Id.to_string id | None -> "?"
48
+
49
+
let email_size (e : Jmap.Proto.Email.t) =
50
+
Option.value ~default:0L e.size
51
+
52
+
let email_mailbox_ids (e : Jmap.Proto.Email.t) =
53
+
Option.value ~default:[] e.mailbox_ids
54
+
55
+
(** {1 Session Command} *)
56
+
57
+
let session_cmd =
58
+
let run cfg =
59
+
Eio_main.run @@ fun env ->
60
+
Eio.Switch.run @@ fun sw ->
61
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
62
+
let session = Jmap_eio.Client.session client in
63
+
64
+
Fmt.pr "@[<v>%a@," Fmt.(styled `Bold string) "Session Information:";
65
+
Fmt.pr " Username: %a@," Fmt.(styled `Green string) session.username;
66
+
Fmt.pr " State: %s@," session.state;
67
+
Fmt.pr " API URL: %s@," session.api_url;
68
+
Fmt.pr " Upload URL: %s@," session.upload_url;
69
+
Fmt.pr " Download URL: %s@," session.download_url;
70
+
Fmt.pr "@, %a@," Fmt.(styled `Bold string) "Capabilities:";
71
+
List.iter (fun (cap, _) ->
72
+
Fmt.pr " %s@," cap
73
+
) session.capabilities;
74
+
Fmt.pr "@, %a@," Fmt.(styled `Bold string) "Accounts:";
75
+
List.iter (fun (id, acct) ->
76
+
let acct : Jmap.Proto.Session.Account.t = acct in
77
+
Fmt.pr " %a: %s (personal=%b, read_only=%b)@,"
78
+
Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string id)
79
+
acct.name acct.is_personal acct.is_read_only
80
+
) session.accounts;
81
+
Fmt.pr "@, %a@," Fmt.(styled `Bold string) "Primary Accounts:";
82
+
List.iter (fun (cap, id) ->
83
+
Fmt.pr " %s: %s@," cap (Jmap.Proto.Id.to_string id)
84
+
) session.primary_accounts;
85
+
Fmt.pr "@]@."
86
+
in
87
+
let doc = "Show JMAP session information" in
88
+
let info = Cmd.info "session" ~doc in
89
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term)
90
+
91
+
(** {1 Mailboxes Command} *)
92
+
93
+
let mailboxes_cmd =
94
+
let run cfg =
95
+
Eio_main.run @@ fun env ->
96
+
Eio.Switch.run @@ fun sw ->
97
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
98
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
99
+
100
+
Jmap_eio.Cli.debug cfg "Fetching mailboxes for account %s" (Jmap.Proto.Id.to_string account_id);
101
+
102
+
let req = Jmap_eio.Client.Build.(
103
+
make_request
104
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
105
+
[mailbox_get ~call_id:"m1" ~account_id ()]
106
+
) in
107
+
108
+
match Jmap_eio.Client.request client req with
109
+
| Error e ->
110
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
111
+
exit 1
112
+
| Ok response ->
113
+
match Jmap_eio.Client.Parse.parse_mailbox_get ~call_id:"m1" response with
114
+
| Error e ->
115
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
116
+
exit 1
117
+
| Ok result ->
118
+
Fmt.pr "@[<v>%a (state: %s)@,@,"
119
+
Fmt.(styled `Bold string) "Mailboxes"
120
+
result.state;
121
+
(* Sort by sort_order then name *)
122
+
let sorted = List.sort (fun (a : Jmap.Proto.Mailbox.t) (b : Jmap.Proto.Mailbox.t) ->
123
+
let sort_a = Option.value ~default:0L a.sort_order in
124
+
let sort_b = Option.value ~default:0L b.sort_order in
125
+
let cmp = Int64.compare sort_a sort_b in
126
+
let name_a = Option.value ~default:"" a.name in
127
+
let name_b = Option.value ~default:"" b.name in
128
+
if cmp <> 0 then cmp else String.compare name_a name_b
129
+
) result.list in
130
+
List.iter (fun (mbox : Jmap.Proto.Mailbox.t) ->
131
+
let role_str = match mbox.role with
132
+
| Some role -> Printf.sprintf " [%s]" (Jmap.Proto.Mailbox.role_to_string role)
133
+
| None -> ""
134
+
in
135
+
let id_str = match mbox.id with
136
+
| Some id -> Jmap.Proto.Id.to_string id
137
+
| None -> "?"
138
+
in
139
+
let name = Option.value ~default:"(unnamed)" mbox.name in
140
+
let total = Option.value ~default:0L mbox.total_emails in
141
+
let unread = Option.value ~default:0L mbox.unread_emails in
142
+
Fmt.pr " %a %s%a (%Ld total, %Ld unread)@,"
143
+
Fmt.(styled `Cyan string) id_str
144
+
name
145
+
Fmt.(styled `Yellow string) role_str
146
+
total unread
147
+
) sorted;
148
+
Fmt.pr "@]@."
149
+
in
150
+
let doc = "List mailboxes" in
151
+
let info = Cmd.info "mailboxes" ~doc in
152
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term)
153
+
154
+
(** {1 Emails Command} *)
155
+
156
+
let emails_cmd =
157
+
let limit_term =
158
+
let doc = "Maximum number of emails to list" in
159
+
Arg.(value & opt int 20 & info ["limit"; "n"] ~docv:"N" ~doc)
160
+
in
161
+
let mailbox_term =
162
+
let doc = "Mailbox ID to filter by" in
163
+
Arg.(value & opt (some string) None & info ["mailbox"; "m"] ~docv:"ID" ~doc)
164
+
in
165
+
let run cfg limit mailbox_id_str =
166
+
Eio_main.run @@ fun env ->
167
+
Eio.Switch.run @@ fun sw ->
168
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
169
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
170
+
171
+
Jmap_eio.Cli.debug cfg "Querying emails with limit %d" limit;
172
+
173
+
(* Build filter if mailbox specified *)
174
+
let filter = match mailbox_id_str with
175
+
| Some id_str ->
176
+
let mailbox_id = Jmap.Proto.Id.of_string_exn id_str in
177
+
let cond : Jmap.Proto.Email.Filter_condition.t = {
178
+
in_mailbox = Some mailbox_id;
179
+
in_mailbox_other_than = None;
180
+
before = None; after = None;
181
+
min_size = None; max_size = None;
182
+
all_in_thread_have_keyword = None;
183
+
some_in_thread_have_keyword = None;
184
+
none_in_thread_have_keyword = None;
185
+
has_keyword = None; not_keyword = None;
186
+
has_attachment = None;
187
+
text = None; from = None; to_ = None;
188
+
cc = None; bcc = None; subject = None;
189
+
body = None; header = None;
190
+
} in
191
+
Some (Jmap.Proto.Filter.Condition cond)
192
+
| None -> None
193
+
in
194
+
195
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
196
+
let query_inv = Jmap_eio.Client.Build.email_query
197
+
~call_id:"q1"
198
+
~account_id
199
+
?filter
200
+
~sort
201
+
~limit:(Int64.of_int limit)
202
+
()
203
+
in
204
+
205
+
let req = Jmap_eio.Client.Build.(
206
+
make_request
207
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
208
+
[query_inv]
209
+
) in
210
+
211
+
match Jmap_eio.Client.request client req with
212
+
| Error e ->
213
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
214
+
exit 1
215
+
| Ok response ->
216
+
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
217
+
| Error e ->
218
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
219
+
exit 1
220
+
| Ok query_result ->
221
+
let email_ids = query_result.ids in
222
+
Jmap_eio.Cli.debug cfg "Found %d email IDs" (List.length email_ids);
223
+
224
+
if List.length email_ids = 0 then (
225
+
Fmt.pr "No emails found.@.";
226
+
) else (
227
+
(* Fetch email details *)
228
+
let get_inv = Jmap_eio.Client.Build.email_get
229
+
~call_id:"g1"
230
+
~account_id
231
+
~ids:email_ids
232
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
233
+
"size"; "receivedAt"; "subject"; "from"; "preview"]
234
+
()
235
+
in
236
+
let req2 = Jmap_eio.Client.Build.(
237
+
make_request
238
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
239
+
[get_inv]
240
+
) in
241
+
242
+
match Jmap_eio.Client.request client req2 with
243
+
| Error e ->
244
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
245
+
exit 1
246
+
| Ok response2 ->
247
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
248
+
| Error e ->
249
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
250
+
exit 1
251
+
| Ok get_result ->
252
+
Fmt.pr "@[<v>%a (showing %d of %s)@,@,"
253
+
Fmt.(styled `Bold string) "Emails"
254
+
(List.length get_result.list)
255
+
(match query_result.total with
256
+
| Some n -> Int64.to_string n
257
+
| None -> "?");
258
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
259
+
let from_str = match email.from with
260
+
| Some addrs -> format_email_addresses addrs
261
+
| None -> "(unknown)"
262
+
in
263
+
let subject = Option.value email.subject ~default:"(no subject)" in
264
+
let keywords = Option.value ~default:[] email.keywords in
265
+
let flags = format_keywords keywords in
266
+
let flag_str = if flags = "" then "" else " [" ^ flags ^ "]" in
267
+
let id_str = match email.id with
268
+
| Some id -> Jmap.Proto.Id.to_string id
269
+
| None -> "?"
270
+
in
271
+
let received = match email.received_at with
272
+
| Some t -> ptime_to_string t
273
+
| None -> "?"
274
+
in
275
+
let preview = Option.value ~default:"" email.preview in
276
+
Fmt.pr " %a %s@,"
277
+
Fmt.(styled `Cyan string) id_str
278
+
received;
279
+
Fmt.pr " From: %s@," (truncate_string 60 from_str);
280
+
Fmt.pr " Subject: %a%s@,"
281
+
Fmt.(styled `White string) (truncate_string 60 subject)
282
+
flag_str;
283
+
Fmt.pr " Preview: %s@,@,"
284
+
(truncate_string 70 preview);
285
+
) get_result.list;
286
+
Fmt.pr "@]@."
287
+
)
288
+
in
289
+
let doc = "List emails" in
290
+
let info = Cmd.info "emails" ~doc in
291
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ limit_term $ mailbox_term)
292
+
293
+
(** {1 Search Command} *)
294
+
295
+
let search_cmd =
296
+
let query_term =
297
+
let doc = "Search query text" in
298
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"QUERY" ~doc)
299
+
in
300
+
let limit_term =
301
+
let doc = "Maximum number of results" in
302
+
Arg.(value & opt int 20 & info ["limit"; "n"] ~docv:"N" ~doc)
303
+
in
304
+
let run cfg query limit =
305
+
Eio_main.run @@ fun env ->
306
+
Eio.Switch.run @@ fun sw ->
307
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
308
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
309
+
310
+
Jmap_eio.Cli.debug cfg "Searching for: %s" query;
311
+
312
+
(* Build text filter *)
313
+
let cond : Jmap.Proto.Email.Filter_condition.t = {
314
+
in_mailbox = None; in_mailbox_other_than = None;
315
+
before = None; after = None;
316
+
min_size = None; max_size = None;
317
+
all_in_thread_have_keyword = None;
318
+
some_in_thread_have_keyword = None;
319
+
none_in_thread_have_keyword = None;
320
+
has_keyword = None; not_keyword = None;
321
+
has_attachment = None;
322
+
text = Some query;
323
+
from = None; to_ = None;
324
+
cc = None; bcc = None; subject = None;
325
+
body = None; header = None;
326
+
} in
327
+
let filter = Jmap.Proto.Filter.Condition cond in
328
+
329
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
330
+
let query_inv = Jmap_eio.Client.Build.email_query
331
+
~call_id:"q1"
332
+
~account_id
333
+
~filter
334
+
~sort
335
+
~limit:(Int64.of_int limit)
336
+
()
337
+
in
338
+
339
+
let req = Jmap_eio.Client.Build.(
340
+
make_request
341
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
342
+
[query_inv]
343
+
) in
344
+
345
+
match Jmap_eio.Client.request client req with
346
+
| Error e ->
347
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
348
+
exit 1
349
+
| Ok response ->
350
+
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
351
+
| Error e ->
352
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
353
+
exit 1
354
+
| Ok query_result ->
355
+
let email_ids = query_result.ids in
356
+
357
+
if List.length email_ids = 0 then (
358
+
Fmt.pr "No emails found matching: %s@." query;
359
+
) else (
360
+
(* Fetch email details *)
361
+
let get_inv = Jmap_eio.Client.Build.email_get
362
+
~call_id:"g1"
363
+
~account_id
364
+
~ids:email_ids
365
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
366
+
"size"; "receivedAt"; "subject"; "from"; "preview"]
367
+
()
368
+
in
369
+
let req2 = Jmap_eio.Client.Build.(
370
+
make_request
371
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
372
+
[get_inv]
373
+
) in
374
+
375
+
match Jmap_eio.Client.request client req2 with
376
+
| Error e ->
377
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
378
+
exit 1
379
+
| Ok response2 ->
380
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
381
+
| Error e ->
382
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
383
+
exit 1
384
+
| Ok get_result ->
385
+
Fmt.pr "@[<v>%a for \"%s\" (%d results)@,@,"
386
+
Fmt.(styled `Bold string) "Search results"
387
+
query
388
+
(List.length get_result.list);
389
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
390
+
let from_str = match email.from with
391
+
| Some addrs -> format_email_addresses addrs
392
+
| None -> "(unknown)"
393
+
in
394
+
let subject = Option.value email.subject ~default:"(no subject)" in
395
+
let id_str = match email.id with
396
+
| Some id -> Jmap.Proto.Id.to_string id
397
+
| None -> "?"
398
+
in
399
+
let received = match email.received_at with
400
+
| Some t -> ptime_to_string t
401
+
| None -> "?"
402
+
in
403
+
let preview = Option.value ~default:"" email.preview in
404
+
Fmt.pr " %a %s@,"
405
+
Fmt.(styled `Cyan string) id_str
406
+
received;
407
+
Fmt.pr " From: %s@," (truncate_string 60 from_str);
408
+
Fmt.pr " Subject: %a@,"
409
+
Fmt.(styled `White string) (truncate_string 60 subject);
410
+
Fmt.pr " Preview: %s@,@,"
411
+
(truncate_string 70 preview);
412
+
) get_result.list;
413
+
Fmt.pr "@]@."
414
+
)
415
+
in
416
+
let doc = "Search emails by text" in
417
+
let info = Cmd.info "search" ~doc in
418
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ query_term $ limit_term)
419
+
420
+
(** {1 Recent Command - chains query + get for detailed listing} *)
421
+
422
+
let recent_cmd =
423
+
let limit_term =
424
+
let doc = "Number of recent emails to show (max 100)" in
425
+
Arg.(value & opt int 100 & info ["limit"; "n"] ~docv:"N" ~doc)
426
+
in
427
+
let format_term =
428
+
let doc = "Output format: table, compact, or detailed" in
429
+
Arg.(value & opt (enum ["table", `Table; "compact", `Compact; "detailed", `Detailed])
430
+
`Table & info ["format"; "f"] ~docv:"FORMAT" ~doc)
431
+
in
432
+
let run cfg limit format =
433
+
let limit = min limit 100 in
434
+
Eio_main.run @@ fun env ->
435
+
Eio.Switch.run @@ fun sw ->
436
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
437
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
438
+
439
+
Jmap_eio.Cli.debug cfg "Fetching %d most recent emails" limit;
440
+
441
+
(* Query for recent emails *)
442
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
443
+
let query_inv = Jmap_eio.Client.Build.email_query
444
+
~call_id:"q1"
445
+
~account_id
446
+
~sort
447
+
~limit:(Int64.of_int limit)
448
+
()
449
+
in
450
+
451
+
let req = Jmap_eio.Client.Build.(
452
+
make_request
453
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
454
+
[query_inv]
455
+
) in
456
+
457
+
match Jmap_eio.Client.request client req with
458
+
| Error e ->
459
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
460
+
exit 1
461
+
| Ok response ->
462
+
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
463
+
| Error e ->
464
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
465
+
exit 1
466
+
| Ok query_result ->
467
+
let email_ids = query_result.ids in
468
+
Jmap_eio.Cli.debug cfg "Query returned %d email IDs" (List.length email_ids);
469
+
470
+
if List.length email_ids = 0 then (
471
+
Fmt.pr "No emails found.@."
472
+
) else (
473
+
(* Fetch full details for all emails *)
474
+
let properties = [
475
+
"id"; "blobId"; "threadId"; "mailboxIds"; "keywords"; "size";
476
+
"receivedAt"; "subject"; "from"; "to"; "cc"; "preview"
477
+
] in
478
+
let get_inv = Jmap_eio.Client.Build.email_get
479
+
~call_id:"g1"
480
+
~account_id
481
+
~ids:email_ids
482
+
~properties
483
+
()
484
+
in
485
+
let req2 = Jmap_eio.Client.Build.(
486
+
make_request
487
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
488
+
[get_inv]
489
+
) in
490
+
491
+
Jmap_eio.Cli.debug cfg "Fetching email details...";
492
+
493
+
match Jmap_eio.Client.request client req2 with
494
+
| Error e ->
495
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
496
+
exit 1
497
+
| Ok response2 ->
498
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
499
+
| Error e ->
500
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
501
+
exit 1
502
+
| Ok get_result ->
503
+
Jmap_eio.Cli.debug cfg "Got %d emails" (List.length get_result.list);
504
+
505
+
(* Output based on format *)
506
+
match format with
507
+
| `Compact ->
508
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
509
+
let from_str = match email.from with
510
+
| Some (addr :: _) ->
511
+
Option.value addr.name ~default:addr.email
512
+
| _ -> "?"
513
+
in
514
+
let subject = Option.value email.subject ~default:"(no subject)" in
515
+
let flags = format_keywords (email_keywords email) in
516
+
Printf.printf "%s\t%s\t%s\t%s\t%s\n"
517
+
(email_id email)
518
+
(email_received_at email)
519
+
(truncate_string 20 from_str)
520
+
(truncate_string 50 subject)
521
+
flags
522
+
) get_result.list
523
+
524
+
| `Table ->
525
+
Fmt.pr "@[<v>%a (%d emails, state: %s)@,@,"
526
+
Fmt.(styled `Bold string) "Recent Emails"
527
+
(List.length get_result.list)
528
+
get_result.state;
529
+
(* Header *)
530
+
Fmt.pr "%-12s %-19s %-20s %-40s %s@,"
531
+
"ID" "Date" "From" "Subject" "Flags";
532
+
Fmt.pr "%s@," (String.make 110 '-');
533
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
534
+
let from_str = match email.from with
535
+
| Some (addr :: _) ->
536
+
Option.value addr.name ~default:addr.email
537
+
| _ -> "?"
538
+
in
539
+
let subject = Option.value email.subject ~default:"(no subject)" in
540
+
let flags = format_keywords (email_keywords email) in
541
+
let id_short =
542
+
let id = email_id email in
543
+
if String.length id > 12 then String.sub id 0 12 else id
544
+
in
545
+
Fmt.pr "%-12s %s %-20s %-40s %s@,"
546
+
id_short
547
+
(email_received_at email)
548
+
(truncate_string 20 from_str)
549
+
(truncate_string 40 subject)
550
+
flags
551
+
) get_result.list;
552
+
Fmt.pr "@]@."
553
+
554
+
| `Detailed ->
555
+
Fmt.pr "@[<v>%a (%d emails)@,@,"
556
+
Fmt.(styled `Bold string) "Recent Emails"
557
+
(List.length get_result.list);
558
+
List.iteri (fun i (email : Jmap.Proto.Email.t) ->
559
+
let from_str = match email.from with
560
+
| Some addrs -> format_email_addresses addrs
561
+
| None -> "(unknown)"
562
+
in
563
+
let to_str = match email.to_ with
564
+
| Some addrs -> format_email_addresses addrs
565
+
| None -> ""
566
+
in
567
+
let cc_str = match email.cc with
568
+
| Some addrs -> format_email_addresses addrs
569
+
| None -> ""
570
+
in
571
+
let subject = Option.value email.subject ~default:"(no subject)" in
572
+
let flags = format_keywords (email_keywords email) in
573
+
let mailbox_count = List.length (email_mailbox_ids email) in
574
+
575
+
Fmt.pr "@[<v 2>%a Email %d of %d@,"
576
+
Fmt.(styled `Bold string) "---"
577
+
(i + 1) (List.length get_result.list);
578
+
Fmt.pr "ID: %a@,"
579
+
Fmt.(styled `Cyan string) (email_id email);
580
+
Fmt.pr "Thread: %s@," (email_thread_id email);
581
+
Fmt.pr "Date: %s@," (email_received_at email);
582
+
Fmt.pr "From: %s@," from_str;
583
+
if to_str <> "" then Fmt.pr "To: %s@," to_str;
584
+
if cc_str <> "" then Fmt.pr "Cc: %s@," cc_str;
585
+
Fmt.pr "Subject: %a@,"
586
+
Fmt.(styled `White string) subject;
587
+
Fmt.pr "Size: %Ld bytes@," (email_size email);
588
+
Fmt.pr "Mailboxes: %d@," mailbox_count;
589
+
if flags <> "" then Fmt.pr "Flags: %s@," flags;
590
+
Fmt.pr "Preview: %s@]@,@," (email_preview email);
591
+
) get_result.list;
592
+
Fmt.pr "@]@."
593
+
)
594
+
in
595
+
let doc = "List recent emails with full details (chains query + get)" in
596
+
let info = Cmd.info "recent" ~doc in
597
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ limit_term $ format_term)
598
+
599
+
(** {1 Threads Command} *)
600
+
601
+
let threads_cmd =
602
+
let email_id_term =
603
+
let doc = "Email ID to get thread for" in
604
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"EMAIL_ID" ~doc)
605
+
in
606
+
let run cfg email_id_str =
607
+
Eio_main.run @@ fun env ->
608
+
Eio.Switch.run @@ fun sw ->
609
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
610
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
611
+
612
+
let target_email_id = Jmap.Proto.Id.of_string_exn email_id_str in
613
+
614
+
(* First get the email to find its thread ID - include required properties *)
615
+
let get_inv = Jmap_eio.Client.Build.email_get
616
+
~call_id:"e1"
617
+
~account_id
618
+
~ids:[target_email_id]
619
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"]
620
+
()
621
+
in
622
+
let req = Jmap_eio.Client.Build.(
623
+
make_request
624
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
625
+
[get_inv]
626
+
) in
627
+
628
+
match Jmap_eio.Client.request client req with
629
+
| Error e ->
630
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
631
+
exit 1
632
+
| Ok response ->
633
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"e1" response with
634
+
| Error e ->
635
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
636
+
exit 1
637
+
| Ok email_result ->
638
+
match email_result.list with
639
+
| [] ->
640
+
Fmt.epr "Email not found: %s@." email_id_str;
641
+
exit 1
642
+
| email :: _ ->
643
+
let thread_id = match email.thread_id with
644
+
| Some id -> id
645
+
| None ->
646
+
Fmt.epr "Email has no thread ID@.";
647
+
exit 1
648
+
in
649
+
Jmap_eio.Cli.debug cfg "Thread ID: %s" (Jmap.Proto.Id.to_string thread_id);
650
+
651
+
(* Get the thread *)
652
+
let thread_inv = Jmap_eio.Client.Build.thread_get
653
+
~call_id:"t1"
654
+
~account_id
655
+
~ids:[thread_id]
656
+
()
657
+
in
658
+
let req2 = Jmap_eio.Client.Build.(
659
+
make_request
660
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
661
+
[thread_inv]
662
+
) in
663
+
664
+
match Jmap_eio.Client.request client req2 with
665
+
| Error e ->
666
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
667
+
exit 1
668
+
| Ok response2 ->
669
+
match Jmap_eio.Client.Parse.parse_thread_get ~call_id:"t1" response2 with
670
+
| Error e ->
671
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
672
+
exit 1
673
+
| Ok thread_result ->
674
+
match thread_result.list with
675
+
| [] ->
676
+
Fmt.epr "Thread not found@.";
677
+
exit 1
678
+
| thread :: _ ->
679
+
let thread_id_str = match thread.id with
680
+
| Some id -> Jmap.Proto.Id.to_string id
681
+
| None -> "?"
682
+
in
683
+
let email_ids = Option.value ~default:[] thread.email_ids in
684
+
Fmt.pr "@[<v>%a %s (%d emails)@,@,"
685
+
Fmt.(styled `Bold string) "Thread"
686
+
thread_id_str
687
+
(List.length email_ids);
688
+
689
+
(* Fetch all emails in thread *)
690
+
let get_inv2 = Jmap_eio.Client.Build.email_get
691
+
~call_id:"e2"
692
+
~account_id
693
+
~ids:email_ids
694
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
695
+
"size"; "receivedAt"; "subject"; "from"; "preview"]
696
+
()
697
+
in
698
+
let req3 = Jmap_eio.Client.Build.(
699
+
make_request
700
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
701
+
[get_inv2]
702
+
) in
703
+
704
+
match Jmap_eio.Client.request client req3 with
705
+
| Error e ->
706
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
707
+
exit 1
708
+
| Ok response3 ->
709
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"e2" response3 with
710
+
| Error e ->
711
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
712
+
exit 1
713
+
| Ok emails_result ->
714
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
715
+
let from_str = match email.from with
716
+
| Some addrs -> format_email_addresses addrs
717
+
| None -> "(unknown)"
718
+
in
719
+
let subject = Option.value email.subject ~default:"(no subject)" in
720
+
Fmt.pr " %a %s@,"
721
+
Fmt.(styled `Cyan string) (email_id email)
722
+
(email_received_at email);
723
+
Fmt.pr " From: %s@," (truncate_string 60 from_str);
724
+
Fmt.pr " Subject: %a@,@,"
725
+
Fmt.(styled `White string) (truncate_string 60 subject);
726
+
) emails_result.list;
727
+
Fmt.pr "@]@."
728
+
in
729
+
let doc = "Show email thread" in
730
+
let info = Cmd.info "thread" ~doc in
731
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_id_term)
732
+
733
+
(** {1 Identities Command} *)
734
+
735
+
let identities_cmd =
736
+
let run cfg =
737
+
Eio_main.run @@ fun env ->
738
+
Eio.Switch.run @@ fun sw ->
739
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
740
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
741
+
742
+
let req = Jmap_eio.Client.Build.(
743
+
make_request
744
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail;
745
+
Jmap.Proto.Capability.submission]
746
+
[identity_get ~call_id:"i1" ~account_id ()]
747
+
) in
748
+
749
+
match Jmap_eio.Client.request client req with
750
+
| Error e ->
751
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
752
+
exit 1
753
+
| Ok response ->
754
+
match Jmap_eio.Client.Parse.parse_response ~call_id:"i1"
755
+
(Jmap_eio.Client.Parse.get_response Jmap.Proto.Identity.jsont)
756
+
response with
757
+
| Error e ->
758
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
759
+
exit 1
760
+
| Ok result ->
761
+
Fmt.pr "@[<v>%a (state: %s)@,@,"
762
+
Fmt.(styled `Bold string) "Identities"
763
+
result.state;
764
+
List.iter (fun (ident : Jmap.Proto.Identity.t) ->
765
+
let ident_id = match ident.id with Some id -> Jmap.Proto.Id.to_string id | None -> "?" in
766
+
let ident_name = Option.value ~default:"(unnamed)" ident.name in
767
+
let ident_email = Option.value ~default:"(no email)" ident.email in
768
+
let ident_sig = Option.value ~default:"" ident.text_signature in
769
+
let ident_may_delete = Option.value ~default:false ident.may_delete in
770
+
Fmt.pr " %a@,"
771
+
Fmt.(styled `Cyan string) ident_id;
772
+
Fmt.pr " Name: %s@," ident_name;
773
+
Fmt.pr " Email: %a@,"
774
+
Fmt.(styled `Green string) ident_email;
775
+
if ident_sig <> "" then
776
+
Fmt.pr " Signature: %s@," (truncate_string 50 ident_sig);
777
+
Fmt.pr " May delete: %b@,@," ident_may_delete
778
+
) result.list;
779
+
Fmt.pr "@]@."
780
+
in
781
+
let doc = "List email identities" in
782
+
let info = Cmd.info "identities" ~doc in
783
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term)
784
+
785
+
(** {1 Chained Commands - Using the Chain monad} *)
786
+
787
+
(** Inbox command - demonstrates simple query+get chain *)
788
+
let inbox_cmd =
789
+
let limit_term =
790
+
let doc = "Maximum number of emails to show" in
791
+
Arg.(value & opt int 20 & info ["limit"; "n"] ~docv:"N" ~doc)
792
+
in
793
+
let run cfg limit =
794
+
Eio_main.run @@ fun env ->
795
+
Eio.Switch.run @@ fun sw ->
796
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
797
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
798
+
799
+
Jmap_eio.Cli.debug cfg "Fetching inbox emails using Chain API";
800
+
801
+
(* Find inbox mailbox first *)
802
+
let mbox_req = Jmap_eio.Client.Build.(
803
+
make_request
804
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
805
+
[mailbox_get ~call_id:"m1" ~account_id ()]
806
+
) in
807
+
808
+
match Jmap_eio.Client.request client mbox_req with
809
+
| Error e ->
810
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
811
+
exit 1
812
+
| Ok mbox_response ->
813
+
match Jmap_eio.Client.Parse.parse_mailbox_get ~call_id:"m1" mbox_response with
814
+
| Error e ->
815
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
816
+
exit 1
817
+
| Ok mbox_result ->
818
+
(* Find inbox *)
819
+
let inbox =
820
+
List.find_opt (fun (m : Jmap.Proto.Mailbox.t) ->
821
+
m.role = Some `Inbox
822
+
) mbox_result.list
823
+
in
824
+
match inbox with
825
+
| None ->
826
+
Fmt.epr "No inbox found@.";
827
+
exit 1
828
+
| Some inbox ->
829
+
let inbox_id = match inbox.id with
830
+
| Some id -> id
831
+
| None ->
832
+
Fmt.epr "Inbox has no ID@.";
833
+
exit 1
834
+
in
835
+
Jmap_eio.Cli.debug cfg "Found inbox: %s" (Jmap.Proto.Id.to_string inbox_id);
836
+
837
+
(* Now use Chain API to query and get emails in one request *)
838
+
let open Jmap_eio.Chain in
839
+
let filter_cond : Jmap.Proto.Email.Filter_condition.t = {
840
+
in_mailbox = Some inbox_id;
841
+
in_mailbox_other_than = None;
842
+
before = None; after = None;
843
+
min_size = None; max_size = None;
844
+
all_in_thread_have_keyword = None;
845
+
some_in_thread_have_keyword = None;
846
+
none_in_thread_have_keyword = None;
847
+
has_keyword = None; not_keyword = None;
848
+
has_attachment = None;
849
+
text = None; from = None; to_ = None;
850
+
cc = None; bcc = None; subject = None;
851
+
body = None; header = None;
852
+
} in
853
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
854
+
855
+
let request, email_handle = build
856
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
857
+
begin
858
+
let* query = email_query ~account_id
859
+
~filter:(Jmap.Proto.Filter.Condition filter_cond)
860
+
~sort
861
+
~limit:(Int64.of_int limit)
862
+
()
863
+
in
864
+
let* emails = email_get ~account_id
865
+
~ids:(from_query query)
866
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "preview"; "keywords"]
867
+
()
868
+
in
869
+
return emails
870
+
end in
871
+
872
+
Jmap_eio.Cli.debug cfg "Sending chained request (query + get in one round trip)";
873
+
874
+
match Jmap_eio.Client.request client request with
875
+
| Error e ->
876
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
877
+
exit 1
878
+
| Ok response ->
879
+
match parse email_handle response with
880
+
| Error e ->
881
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
882
+
exit 1
883
+
| Ok result ->
884
+
Fmt.pr "@[<v>%a (%d emails in inbox)@,@,"
885
+
Fmt.(styled `Bold string) "Inbox"
886
+
(List.length result.list);
887
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
888
+
let from_str = match email.from with
889
+
| Some (addr :: _) ->
890
+
Option.value addr.name ~default:addr.email
891
+
| _ -> "?"
892
+
in
893
+
let subject = Option.value email.subject ~default:"(no subject)" in
894
+
let flags = format_keywords (email_keywords email) in
895
+
Fmt.pr " %a %s@,"
896
+
Fmt.(styled `Cyan string) (email_id email)
897
+
(email_received_at email);
898
+
Fmt.pr " From: %s@," (truncate_string 40 from_str);
899
+
Fmt.pr " Subject: %a%s@,"
900
+
Fmt.(styled `White string) (truncate_string 50 subject)
901
+
(if flags = "" then "" else " [" ^ flags ^ "]");
902
+
Fmt.pr "@,"
903
+
) result.list;
904
+
Fmt.pr "@]@."
905
+
in
906
+
let doc = "List inbox emails (uses Chain API for query+get in single request)" in
907
+
let info = Cmd.info "inbox" ~doc in
908
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ limit_term)
909
+
910
+
(** Thread-view command - demonstrates multi-step chaining (RFC 8620 example) *)
911
+
let thread_view_cmd =
912
+
let limit_term =
913
+
let doc = "Number of threads to show" in
914
+
Arg.(value & opt int 10 & info ["limit"; "n"] ~docv:"N" ~doc)
915
+
in
916
+
let run cfg limit =
917
+
Eio_main.run @@ fun env ->
918
+
Eio.Switch.run @@ fun sw ->
919
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
920
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
921
+
922
+
Jmap_eio.Cli.debug cfg "Fetching threaded view using multi-step Chain API";
923
+
924
+
(*
925
+
This implements the RFC 8620 example:
926
+
1. Email/query with collapseThreads to get one email per thread
927
+
2. Email/get to fetch threadId for each
928
+
3. Thread/get to fetch all emailIds in each thread
929
+
4. Email/get to fetch details for all emails in those threads
930
+
*)
931
+
let open Jmap_eio.Chain in
932
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
933
+
934
+
let request, (query_h, final_emails_h) = build
935
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
936
+
begin
937
+
(* Step 1: Query for recent emails, collapsing threads *)
938
+
let* query = email_query ~account_id
939
+
~sort
940
+
~collapse_threads:true
941
+
~limit:(Int64.of_int limit)
942
+
()
943
+
in
944
+
(* Step 2: Get just threadId for those emails *)
945
+
let* emails1 = email_get ~account_id
946
+
~ids:(from_query query)
947
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"]
948
+
()
949
+
in
950
+
(* Step 3: Get threads using threadIds from step 2 *)
951
+
let* threads = thread_get ~account_id
952
+
~ids:(from_get_field emails1 "threadId")
953
+
()
954
+
in
955
+
(* Step 4: Get all emails in those threads *)
956
+
let* emails2 = email_get ~account_id
957
+
~ids:(from_get_field threads "emailIds")
958
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "preview"]
959
+
()
960
+
in
961
+
return (query, emails2)
962
+
end in
963
+
964
+
Jmap_eio.Cli.debug cfg "Sending 4-step chained request in single round trip";
965
+
966
+
match Jmap_eio.Client.request client request with
967
+
| Error e ->
968
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
969
+
exit 1
970
+
| Ok response ->
971
+
let query_result = parse_exn query_h response in
972
+
let emails_result = parse_exn final_emails_h response in
973
+
974
+
(* Group emails by thread *)
975
+
let threads_map = Hashtbl.create 16 in
976
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
977
+
let tid = email_thread_id email in
978
+
let existing = try Hashtbl.find threads_map tid with Not_found -> [] in
979
+
Hashtbl.replace threads_map tid (email :: existing)
980
+
) emails_result.list;
981
+
982
+
Fmt.pr "@[<v>%a (%d threads, %d total emails)@,@,"
983
+
Fmt.(styled `Bold string) "Threaded View"
984
+
(Hashtbl.length threads_map)
985
+
(List.length emails_result.list);
986
+
Fmt.pr "Query found %s total matching emails@,@,"
987
+
(match query_result.total with Some n -> Int64.to_string n | None -> "?");
988
+
989
+
(* Print threads *)
990
+
Hashtbl.iter (fun _tid emails ->
991
+
let emails = List.sort (fun (a : Jmap.Proto.Email.t) (b : Jmap.Proto.Email.t) ->
992
+
let a_time = Option.value ~default:Ptime.epoch a.received_at in
993
+
let b_time = Option.value ~default:Ptime.epoch b.received_at in
994
+
Ptime.compare a_time b_time
995
+
) emails in
996
+
let first_email = List.hd emails in
997
+
let subject = Option.value first_email.subject ~default:"(no subject)" in
998
+
Fmt.pr " %a Thread: %s (%d emails)@,"
999
+
Fmt.(styled `Bold string) "▸"
1000
+
(truncate_string 50 subject)
1001
+
(List.length emails);
1002
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
1003
+
let from_str = match email.from with
1004
+
| Some (addr :: _) -> Option.value addr.name ~default:addr.email
1005
+
| _ -> "?"
1006
+
in
1007
+
Fmt.pr " %s %s %s@,"
1008
+
(email_id email |> truncate_string 12)
1009
+
(email_received_at email)
1010
+
(truncate_string 30 from_str)
1011
+
) emails;
1012
+
Fmt.pr "@,"
1013
+
) threads_map;
1014
+
Fmt.pr "@]@."
1015
+
in
1016
+
let doc = "Show threaded view (demonstrates RFC 8620 multi-step chain)" in
1017
+
let info = Cmd.info "thread-view" ~doc in
1018
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ limit_term)
1019
+
1020
+
(** Mark-read command - demonstrates email_set for updating keywords *)
1021
+
let mark_read_cmd =
1022
+
let email_id_term =
1023
+
let doc = "Email ID to mark as read" in
1024
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"EMAIL_ID" ~doc)
1025
+
in
1026
+
let unread_term =
1027
+
let doc = "Mark as unread instead of read" in
1028
+
Arg.(value & flag & info ["unread"; "u"] ~doc)
1029
+
in
1030
+
let run cfg email_id_str unread =
1031
+
Eio_main.run @@ fun env ->
1032
+
Eio.Switch.run @@ fun sw ->
1033
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1034
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1035
+
let email_id = Jmap.Proto.Id.of_string_exn email_id_str in
1036
+
1037
+
Jmap_eio.Cli.debug cfg "%s email %s"
1038
+
(if unread then "Marking as unread" else "Marking as read")
1039
+
email_id_str;
1040
+
1041
+
(* Build the patch object - set or unset $seen keyword *)
1042
+
let patch =
1043
+
let open Jmap_eio.Chain in
1044
+
if unread then
1045
+
json_obj [("keywords/$seen", json_null)]
1046
+
else
1047
+
json_obj [("keywords/$seen", json_bool true)]
1048
+
in
1049
+
1050
+
let open Jmap_eio.Chain in
1051
+
let request, set_h = build
1052
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1053
+
begin
1054
+
email_set ~account_id
1055
+
~update:[(email_id, patch)]
1056
+
()
1057
+
end in
1058
+
1059
+
match Jmap_eio.Client.request client request with
1060
+
| Error e ->
1061
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1062
+
exit 1
1063
+
| Ok response ->
1064
+
match parse set_h response with
1065
+
| Error e ->
1066
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1067
+
exit 1
1068
+
| Ok result ->
1069
+
(* Check if update succeeded *)
1070
+
let updated_ids =
1071
+
result.updated
1072
+
|> Option.value ~default:[]
1073
+
|> List.map (fun (id, _) -> Jmap.Proto.Id.to_string id)
1074
+
in
1075
+
if List.mem email_id_str updated_ids then
1076
+
Fmt.pr "Email %s marked as %s@."
1077
+
email_id_str
1078
+
(if unread then "unread" else "read")
1079
+
else (
1080
+
Fmt.epr "Failed to update email. ";
1081
+
let not_updated = Option.value ~default:[] result.not_updated in
1082
+
(match List.find_opt (fun (id, _) -> Jmap.Proto.Id.to_string id = email_id_str) not_updated with
1083
+
| Some (_, err) ->
1084
+
let open Jmap.Proto.Error in
1085
+
let err_type = set_error_type_to_string err.type_ in
1086
+
let err_desc = Option.value ~default:"" err.description in
1087
+
Fmt.epr "Error: %s (%s)@." err_type err_desc
1088
+
| None ->
1089
+
Fmt.epr "Unknown error@.");
1090
+
exit 1
1091
+
)
1092
+
in
1093
+
let doc = "Mark an email as read/unread (demonstrates Email/set)" in
1094
+
let info = Cmd.info "mark-read" ~doc in
1095
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_id_term $ unread_term)
1096
+
1097
+
(** Delete email command - demonstrates email_set destroy *)
1098
+
let delete_email_cmd =
1099
+
let email_ids_term =
1100
+
let doc = "Email IDs to delete" in
1101
+
Arg.(non_empty & pos_all string [] & info [] ~docv:"EMAIL_ID" ~doc)
1102
+
in
1103
+
let run cfg email_id_strs =
1104
+
Eio_main.run @@ fun env ->
1105
+
Eio.Switch.run @@ fun sw ->
1106
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1107
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1108
+
let email_ids = List.map Jmap.Proto.Id.of_string_exn email_id_strs in
1109
+
1110
+
Jmap_eio.Cli.debug cfg "Deleting %d email(s)" (List.length email_ids);
1111
+
1112
+
let open Jmap_eio.Chain in
1113
+
let request, set_h = build
1114
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1115
+
begin
1116
+
email_set ~account_id
1117
+
~destroy:(ids email_ids)
1118
+
()
1119
+
end in
1120
+
1121
+
match Jmap_eio.Client.request client request with
1122
+
| Error e ->
1123
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1124
+
exit 1
1125
+
| Ok response ->
1126
+
match parse set_h response with
1127
+
| Error e ->
1128
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1129
+
exit 1
1130
+
| Ok result ->
1131
+
let destroyed = Option.value ~default:[] result.destroyed in
1132
+
let destroyed_ids = List.map Jmap.Proto.Id.to_string destroyed in
1133
+
Fmt.pr "Deleted %d email(s):@." (List.length destroyed_ids);
1134
+
List.iter (fun id -> Fmt.pr " %s@." id) destroyed_ids;
1135
+
(* Report any failures *)
1136
+
let not_destroyed = Option.value ~default:[] result.not_destroyed in
1137
+
if not_destroyed <> [] then begin
1138
+
Fmt.epr "Failed to delete %d email(s):@." (List.length not_destroyed);
1139
+
List.iter (fun (id, err) ->
1140
+
let open Jmap.Proto.Error in
1141
+
let err_type = set_error_type_to_string err.type_ in
1142
+
Fmt.epr " %s: %s@."
1143
+
(Jmap.Proto.Id.to_string id)
1144
+
err_type
1145
+
) not_destroyed
1146
+
end
1147
+
in
1148
+
let doc = "Delete emails (demonstrates Email/set destroy)" in
1149
+
let info = Cmd.info "delete" ~doc in
1150
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_ids_term)
1151
+
1152
+
(** Changes command - demonstrates email_changes for sync *)
1153
+
let changes_cmd =
1154
+
let state_term =
1155
+
let doc = "State to get changes since (use 'current' to just show current state)" in
1156
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"STATE" ~doc)
1157
+
in
1158
+
let run cfg state_str =
1159
+
Eio_main.run @@ fun env ->
1160
+
Eio.Switch.run @@ fun sw ->
1161
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1162
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1163
+
1164
+
if state_str = "current" then (
1165
+
(* Just get current state by doing a minimal query *)
1166
+
let open Jmap_eio.Chain in
1167
+
let request, get_h = build
1168
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1169
+
begin
1170
+
(* Get empty list just to see state *)
1171
+
email_get ~account_id ~ids:(ids []) ()
1172
+
end in
1173
+
1174
+
match Jmap_eio.Client.request client request with
1175
+
| Error e ->
1176
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1177
+
exit 1
1178
+
| Ok response ->
1179
+
match parse get_h response with
1180
+
| Error e ->
1181
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1182
+
exit 1
1183
+
| Ok result ->
1184
+
Fmt.pr "Current email state: %a@."
1185
+
Fmt.(styled `Cyan string) result.state
1186
+
) else (
1187
+
Jmap_eio.Cli.debug cfg "Getting changes since state: %s" state_str;
1188
+
1189
+
let open Jmap_eio.Chain in
1190
+
let request, changes_h = build
1191
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1192
+
begin
1193
+
email_changes ~account_id ~since_state:state_str ()
1194
+
end in
1195
+
1196
+
match Jmap_eio.Client.request client request with
1197
+
| Error e ->
1198
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1199
+
exit 1
1200
+
| Ok response ->
1201
+
match parse changes_h response with
1202
+
| Error e ->
1203
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1204
+
exit 1
1205
+
| Ok result ->
1206
+
Fmt.pr "@[<v>%a@,@,"
1207
+
Fmt.(styled `Bold string) "Email Changes";
1208
+
Fmt.pr "Old state: %s@," result.old_state;
1209
+
Fmt.pr "New state: %a@," Fmt.(styled `Cyan string) result.new_state;
1210
+
Fmt.pr "Has more changes: %b@,@," result.has_more_changes;
1211
+
Fmt.pr "Created: %d email(s)@," (List.length result.created);
1212
+
List.iter (fun id ->
1213
+
Fmt.pr " + %s@," (Jmap.Proto.Id.to_string id)
1214
+
) result.created;
1215
+
Fmt.pr "Updated: %d email(s)@," (List.length result.updated);
1216
+
List.iter (fun id ->
1217
+
Fmt.pr " ~ %s@," (Jmap.Proto.Id.to_string id)
1218
+
) result.updated;
1219
+
Fmt.pr "Destroyed: %d email(s)@," (List.length result.destroyed);
1220
+
List.iter (fun id ->
1221
+
Fmt.pr " - %s@," (Jmap.Proto.Id.to_string id)
1222
+
) result.destroyed;
1223
+
Fmt.pr "@]@."
1224
+
)
1225
+
in
1226
+
let doc = "Show email changes since a state (demonstrates Email/changes)" in
1227
+
let info = Cmd.info "changes" ~doc in
1228
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ state_term)
1229
+
1230
+
(** Sync command - demonstrates changes + get pattern for incremental sync *)
1231
+
let sync_cmd =
1232
+
let state_term =
1233
+
let doc = "State to sync from" in
1234
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"STATE" ~doc)
1235
+
in
1236
+
let run cfg state_str =
1237
+
Eio_main.run @@ fun env ->
1238
+
Eio.Switch.run @@ fun sw ->
1239
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1240
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1241
+
1242
+
Jmap_eio.Cli.debug cfg "Syncing from state: %s" state_str;
1243
+
1244
+
(* Chain: changes → get created → get updated *)
1245
+
let open Jmap_eio.Chain in
1246
+
let request, (changes_h, created_h, updated_h) = build
1247
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1248
+
begin
1249
+
let* changes = email_changes ~account_id ~since_state:state_str () in
1250
+
let* created = email_get ~account_id
1251
+
~ids:(from_changes_created changes)
1252
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "preview"]
1253
+
()
1254
+
in
1255
+
let* updated = email_get ~account_id
1256
+
~ids:(from_changes_updated changes)
1257
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "keywords"]
1258
+
()
1259
+
in
1260
+
return (changes, created, updated)
1261
+
end in
1262
+
1263
+
Jmap_eio.Cli.debug cfg "Sending chained sync request";
1264
+
1265
+
match Jmap_eio.Client.request client request with
1266
+
| Error e ->
1267
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1268
+
exit 1
1269
+
| Ok response ->
1270
+
let changes_result = parse_exn changes_h response in
1271
+
let created_result = parse_exn created_h response in
1272
+
let updated_result = parse_exn updated_h response in
1273
+
1274
+
Fmt.pr "@[<v>%a (state: %s → %s)@,@,"
1275
+
Fmt.(styled `Bold string) "Sync Results"
1276
+
changes_result.old_state
1277
+
changes_result.new_state;
1278
+
1279
+
if List.length created_result.list > 0 then begin
1280
+
Fmt.pr "%a (%d)@,"
1281
+
Fmt.(styled `Green string) "New emails"
1282
+
(List.length created_result.list);
1283
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
1284
+
let from_str = match email.from with
1285
+
| Some (addr :: _) -> Option.value addr.name ~default:addr.email
1286
+
| _ -> "?"
1287
+
in
1288
+
let subject = Option.value email.subject ~default:"(no subject)" in
1289
+
Fmt.pr " + %s %s %s@,"
1290
+
(email_id email |> truncate_string 12)
1291
+
(truncate_string 20 from_str)
1292
+
(truncate_string 40 subject)
1293
+
) created_result.list;
1294
+
Fmt.pr "@,"
1295
+
end;
1296
+
1297
+
if List.length updated_result.list > 0 then begin
1298
+
Fmt.pr "%a (%d)@,"
1299
+
Fmt.(styled `Yellow string) "Updated emails"
1300
+
(List.length updated_result.list);
1301
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
1302
+
let flags = format_keywords (email_keywords email) in
1303
+
Fmt.pr " ~ %s [%s]@,"
1304
+
(email_id email |> truncate_string 12)
1305
+
flags
1306
+
) updated_result.list;
1307
+
Fmt.pr "@,"
1308
+
end;
1309
+
1310
+
if List.length changes_result.destroyed > 0 then begin
1311
+
Fmt.pr "%a (%d)@,"
1312
+
Fmt.(styled `Red string) "Deleted emails"
1313
+
(List.length changes_result.destroyed);
1314
+
List.iter (fun id ->
1315
+
Fmt.pr " - %s@," (Jmap.Proto.Id.to_string id)
1316
+
) changes_result.destroyed;
1317
+
Fmt.pr "@,"
1318
+
end;
1319
+
1320
+
if changes_result.has_more_changes then
1321
+
Fmt.pr "%a - call sync again with state %s@,"
1322
+
Fmt.(styled `Bold string) "More changes available"
1323
+
changes_result.new_state;
1324
+
1325
+
Fmt.pr "@]@."
1326
+
in
1327
+
let doc = "Incremental sync (demonstrates changes + get chain)" in
1328
+
let info = Cmd.info "sync" ~doc in
1329
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ state_term)
1330
+
1331
+
(** Headers command - demonstrates RFC 8621 §4.1 header property queries *)
1332
+
let headers_cmd =
1333
+
let email_id_term =
1334
+
let doc = "Email ID to get headers for" in
1335
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"EMAIL_ID" ~doc)
1336
+
in
1337
+
1338
+
(* Format a header value for display *)
1339
+
let format_header_value = function
1340
+
| Jmap.Proto.Email_header.String_single None -> "(null)"
1341
+
| Jmap.Proto.Email_header.String_single (Some s) -> s
1342
+
| Jmap.Proto.Email_header.String_all [] -> "(empty list)"
1343
+
| Jmap.Proto.Email_header.String_all strs -> String.concat "; " strs
1344
+
| Jmap.Proto.Email_header.Addresses_single None -> "(null)"
1345
+
| Jmap.Proto.Email_header.Addresses_single (Some []) -> "(empty)"
1346
+
| Jmap.Proto.Email_header.Addresses_single (Some addrs) ->
1347
+
String.concat ", " (List.map (fun a ->
1348
+
match a.Jmap.Proto.Email_address.name with
1349
+
| Some n -> Printf.sprintf "%s <%s>" n a.email
1350
+
| None -> a.email
1351
+
) addrs)
1352
+
| Jmap.Proto.Email_header.Addresses_all [] -> "(empty list)"
1353
+
| Jmap.Proto.Email_header.Addresses_all groups ->
1354
+
String.concat " | " (List.map (fun addrs ->
1355
+
String.concat ", " (List.map (fun a ->
1356
+
match a.Jmap.Proto.Email_address.name with
1357
+
| Some n -> Printf.sprintf "%s <%s>" n a.email
1358
+
| None -> a.email
1359
+
) addrs)
1360
+
) groups)
1361
+
| Jmap.Proto.Email_header.Grouped_single None -> "(null)"
1362
+
| Jmap.Proto.Email_header.Grouped_single (Some groups) ->
1363
+
String.concat "; " (List.map (fun g ->
1364
+
let name = Option.value ~default:"(ungrouped)" g.Jmap.Proto.Email_address.Group.name in
1365
+
let addrs = String.concat ", " (List.map (fun a ->
1366
+
match a.Jmap.Proto.Email_address.name with
1367
+
| Some n -> Printf.sprintf "%s <%s>" n a.email
1368
+
| None -> a.email
1369
+
) g.addresses) in
1370
+
Printf.sprintf "%s: %s" name addrs
1371
+
) groups)
1372
+
| Jmap.Proto.Email_header.Grouped_all _ -> "(grouped addresses list)"
1373
+
| Jmap.Proto.Email_header.Date_single None -> "(null)"
1374
+
| Jmap.Proto.Email_header.Date_single (Some t) -> ptime_to_string t
1375
+
| Jmap.Proto.Email_header.Date_all [] -> "(empty list)"
1376
+
| Jmap.Proto.Email_header.Date_all dates ->
1377
+
String.concat "; " (List.map (function
1378
+
| None -> "(null)"
1379
+
| Some t -> ptime_to_string t
1380
+
) dates)
1381
+
| Jmap.Proto.Email_header.Strings_single None -> "(null)"
1382
+
| Jmap.Proto.Email_header.Strings_single (Some []) -> "(empty)"
1383
+
| Jmap.Proto.Email_header.Strings_single (Some strs) -> String.concat ", " strs
1384
+
| Jmap.Proto.Email_header.Strings_all [] -> "(empty list)"
1385
+
| Jmap.Proto.Email_header.Strings_all groups ->
1386
+
String.concat " | " (List.map (function
1387
+
| None -> "(null)"
1388
+
| Some strs -> String.concat ", " strs
1389
+
) groups)
1390
+
in
1391
+
1392
+
let run cfg email_id_str =
1393
+
Eio_main.run @@ fun env ->
1394
+
Eio.Switch.run @@ fun sw ->
1395
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1396
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1397
+
let target_email_id = Jmap.Proto.Id.of_string_exn email_id_str in
1398
+
1399
+
Jmap_eio.Cli.debug cfg "Fetching headers for email %s" email_id_str;
1400
+
1401
+
(* Demonstrate various header forms from RFC 8621 §4.1.2:
1402
+
- header:name - Raw value
1403
+
- header:name:asText - Text decoded
1404
+
- header:name:asAddresses - Address list
1405
+
- header:name:asGroupedAddresses - Address groups
1406
+
- header:name:asMessageIds - Message-ID list
1407
+
- header:name:asDate - RFC 3339 date
1408
+
- header:name:asURLs - URL list
1409
+
- header:name:all - All values (not just first)
1410
+
*)
1411
+
let header_props = [
1412
+
(* Raw and text forms *)
1413
+
"header:Subject";
1414
+
"header:Subject:asText";
1415
+
(* Address headers *)
1416
+
"header:From:asAddresses";
1417
+
"header:To:asAddresses";
1418
+
"header:Cc:asAddresses";
1419
+
"header:Bcc:asAddresses";
1420
+
"header:Reply-To:asAddresses";
1421
+
"header:Sender:asAddresses";
1422
+
(* Grouped addresses *)
1423
+
"header:From:asGroupedAddresses";
1424
+
(* Message ID headers *)
1425
+
"header:Message-ID:asMessageIds";
1426
+
"header:In-Reply-To:asMessageIds";
1427
+
"header:References:asMessageIds";
1428
+
(* Date header *)
1429
+
"header:Date:asDate";
1430
+
(* List headers as URLs *)
1431
+
"header:List-Unsubscribe:asURLs";
1432
+
"header:List-Post:asURLs";
1433
+
"header:List-Archive:asURLs";
1434
+
(* Custom headers *)
1435
+
"header:X-Mailer:asText";
1436
+
"header:X-Priority";
1437
+
"header:X-Spam-Status:asText";
1438
+
"header:Content-Type";
1439
+
"header:MIME-Version";
1440
+
(* Get all Received headers (typically multiple) *)
1441
+
"header:Received:all";
1442
+
] in
1443
+
1444
+
let properties = "id" :: "threadId" :: "subject" :: header_props in
1445
+
1446
+
let get_inv = Jmap_eio.Client.Build.email_get
1447
+
~call_id:"h1"
1448
+
~account_id
1449
+
~ids:[target_email_id]
1450
+
~properties
1451
+
()
1452
+
in
1453
+
let req = Jmap_eio.Client.Build.(
1454
+
make_request
1455
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1456
+
[get_inv]
1457
+
) in
1458
+
1459
+
match Jmap_eio.Client.request client req with
1460
+
| Error e ->
1461
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1462
+
exit 1
1463
+
| Ok response ->
1464
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"h1" response with
1465
+
| Error e ->
1466
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1467
+
exit 1
1468
+
| Ok email_result ->
1469
+
match email_result.list with
1470
+
| [] ->
1471
+
Fmt.epr "Email not found: %s@." email_id_str;
1472
+
exit 1
1473
+
| email :: _ ->
1474
+
Fmt.pr "@[<v>%a@," Fmt.(styled `Bold string) "Email Headers (RFC 8621 §4.1)";
1475
+
Fmt.pr "ID: %s@," (email_id email);
1476
+
Fmt.pr "Thread: %s@," (email_thread_id email);
1477
+
(match email.subject with
1478
+
| Some s -> Fmt.pr "Subject (convenience): %s@," s
1479
+
| None -> ());
1480
+
Fmt.pr "@,";
1481
+
1482
+
(* Print dynamic headers grouped by category *)
1483
+
let raw_headers = Jmap.Proto.Email.dynamic_headers_raw email in
1484
+
if raw_headers = [] then
1485
+
Fmt.pr "%a@," Fmt.(styled `Yellow string) "No dynamic headers returned"
1486
+
else begin
1487
+
Fmt.pr "%a (%d properties)@,@,"
1488
+
Fmt.(styled `Bold string) "Dynamic Header Properties"
1489
+
(List.length raw_headers);
1490
+
1491
+
List.iter (fun (name, json) ->
1492
+
match Jmap.Proto.Email.decode_header_value name json with
1493
+
| None ->
1494
+
Fmt.pr " %a: (decode failed)@,"
1495
+
Fmt.(styled `Red string) name
1496
+
| Some value ->
1497
+
let formatted = format_header_value value in
1498
+
if String.length formatted > 80 then
1499
+
Fmt.pr " %a:@, %s@,"
1500
+
Fmt.(styled `Cyan string) name
1501
+
formatted
1502
+
else
1503
+
Fmt.pr " %a: %s@,"
1504
+
Fmt.(styled `Cyan string) name
1505
+
formatted
1506
+
) raw_headers
1507
+
end;
1508
+
Fmt.pr "@]@."
1509
+
in
1510
+
let doc = "Show email headers in various forms (demonstrates RFC 8621 §4.1)" in
1511
+
let info = Cmd.info "headers" ~doc in
1512
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_id_term)
1513
+
1514
+
(** {1 Main Command Group} *)
1515
+
1516
+
let main_cmd =
1517
+
let doc = "JMAP command-line client" in
1518
+
let man = [
1519
+
`S Manpage.s_description;
1520
+
`P "A command-line client for JMAP (JSON Meta Application Protocol) email servers.";
1521
+
`S Manpage.s_environment;
1522
+
`P Jmap_eio.Cli.env_docs;
1523
+
`S Manpage.s_examples;
1524
+
`P "List mailboxes:";
1525
+
`Pre " jmap mailboxes --url https://api.fastmail.com/jmap/session -k YOUR_API_KEY";
1526
+
`P "Show recent emails:";
1527
+
`Pre " jmap recent -n 50 --format detailed";
1528
+
`P "Search emails:";
1529
+
`Pre " jmap search \"meeting notes\" -n 10";
1530
+
] in
1531
+
let info = Cmd.info "jmap" ~version:"0.1.0" ~doc ~man in
1532
+
Cmd.group info [
1533
+
session_cmd;
1534
+
mailboxes_cmd;
1535
+
emails_cmd;
1536
+
search_cmd;
1537
+
recent_cmd;
1538
+
threads_cmd;
1539
+
identities_cmd;
1540
+
headers_cmd;
1541
+
(* Chain API examples *)
1542
+
inbox_cmd;
1543
+
thread_view_cmd;
1544
+
mark_read_cmd;
1545
+
delete_email_cmd;
1546
+
changes_cmd;
1547
+
sync_cmd;
1548
+
]
1549
+
1550
+
let () =
1551
+
Fmt_tty.setup_std_outputs ();
1552
+
exit (Cmd.eval main_cmd)
-189
bin/jmap_test.ml
-189
bin/jmap_test.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP test client - connects to a JMAP server and queries recent emails *)
7
-
8
-
let ptime_to_string t =
9
-
let (y, m, d), ((hh, mm, ss), _tz) = Ptime.to_date_time t in
10
-
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" y m d hh mm ss
11
-
12
-
let debug_mode = ref false
13
-
14
-
let debug fmt =
15
-
if !debug_mode then
16
-
Printf.kfprintf (fun oc -> Printf.fprintf oc "\n%!") stderr ("[DEBUG] " ^^ fmt)
17
-
else
18
-
Printf.ifprintf stderr fmt
19
-
20
-
let () =
21
-
(* Parse command line arguments *)
22
-
let usage = "Usage: jmap-test [--debug] <session-url> <api-key>" in
23
-
let args = ref [] in
24
-
let spec = [
25
-
("--debug", Arg.Set debug_mode, "Enable debug output");
26
-
("-d", Arg.Set debug_mode, "Enable debug output");
27
-
] in
28
-
Arg.parse spec (fun arg -> args := arg :: !args) usage;
29
-
let session_url, api_key =
30
-
match List.rev !args with
31
-
| [url; key] -> (url, key)
32
-
| _ ->
33
-
prerr_endline usage;
34
-
exit 1
35
-
in
36
-
37
-
debug "Session URL: %s" session_url;
38
-
debug "API key length: %d chars" (String.length api_key);
39
-
40
-
(* Run with Eio *)
41
-
Eio_main.run @@ fun env ->
42
-
Eio.Switch.run @@ fun sw ->
43
-
44
-
(* Create HTTP client with Bearer token auth *)
45
-
let requests = Requests.create ~sw env in
46
-
let auth = Requests.Auth.bearer ~token:api_key in
47
-
48
-
debug "Created HTTP client with Bearer auth";
49
-
Printf.printf "Connecting to %s...\n%!" session_url;
50
-
51
-
(* Create JMAP client from session URL *)
52
-
match Jmap_eio.Client.create_from_url ~auth requests session_url with
53
-
| Error e ->
54
-
Printf.eprintf "Failed to connect: %s\n" (Jmap_eio.Client.error_to_string e);
55
-
exit 1
56
-
| Ok client ->
57
-
let session = Jmap_eio.Client.session client in
58
-
debug "Session state: %s" session.state;
59
-
debug "API URL: %s" session.api_url;
60
-
debug "Upload URL: %s" session.upload_url;
61
-
debug "Download URL: %s" session.download_url;
62
-
debug "Capabilities: %s" (String.concat ", " (List.map fst session.capabilities));
63
-
debug "Accounts: %d" (List.length session.accounts);
64
-
List.iter (fun (id, acct) ->
65
-
debug " Account %s: %s (personal=%b, read_only=%b)"
66
-
(Jmap_proto.Id.to_string id)
67
-
acct.Jmap_proto.Session.Account.name
68
-
acct.is_personal
69
-
acct.is_read_only
70
-
) session.accounts;
71
-
Printf.printf "Connected! Username: %s\n%!" session.username;
72
-
73
-
(* Get primary mail account *)
74
-
let primary_account_id =
75
-
match Jmap_proto.Session.primary_account_for Jmap_proto.Capability.mail session with
76
-
| Some id -> id
77
-
| None ->
78
-
prerr_endline "No primary mail account found";
79
-
exit 1
80
-
in
81
-
debug "Primary accounts: %s"
82
-
(String.concat ", " (List.map (fun (cap, id) ->
83
-
cap ^ "=" ^ Jmap_proto.Id.to_string id) session.primary_accounts));
84
-
Printf.printf "Primary mail account: %s\n%!" (Jmap_proto.Id.to_string primary_account_id);
85
-
86
-
(* Query for recent emails - get the 10 most recent *)
87
-
let sort = [Jmap_proto.Filter.comparator ~is_ascending:false "receivedAt"] in
88
-
let query_inv = Jmap_eio.Client.Build.email_query
89
-
~call_id:"q1"
90
-
~account_id:primary_account_id
91
-
~sort
92
-
~limit:10L
93
-
()
94
-
in
95
-
96
-
(* Build request with mail capability *)
97
-
let req = Jmap_eio.Client.Build.make_request
98
-
~capabilities:[Jmap_proto.Capability.core; Jmap_proto.Capability.mail]
99
-
[query_inv]
100
-
in
101
-
102
-
debug "Built Email/query request with sort by receivedAt desc, limit 10";
103
-
Printf.printf "Querying recent emails...\n%!";
104
-
105
-
match Jmap_eio.Client.request client req with
106
-
| Error e ->
107
-
Printf.eprintf "Query failed: %s\n" (Jmap_eio.Client.error_to_string e);
108
-
exit 1
109
-
| Ok response ->
110
-
debug "Query response received, parsing...";
111
-
(* Parse the query response *)
112
-
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
113
-
| Error e ->
114
-
Printf.eprintf "Failed to parse query response: %s\n" (Jsont.Error.to_string e);
115
-
exit 1
116
-
| Ok query_result ->
117
-
let email_ids = query_result.ids in
118
-
debug "Query state: %s" query_result.query_state;
119
-
debug "Can calculate updates: %b" query_result.can_calculate_changes;
120
-
debug "Total results: %Ld" (Option.value query_result.total ~default:(-1L));
121
-
debug "Position: %Ld" query_result.position;
122
-
debug "Email IDs: %s"
123
-
(String.concat ", " (List.map Jmap_proto.Id.to_string email_ids));
124
-
Printf.printf "Found %d emails\n%!" (List.length email_ids);
125
-
126
-
if List.length email_ids = 0 then (
127
-
Printf.printf "No emails found.\n%!";
128
-
) else (
129
-
(* Fetch the email details - must include required properties *)
130
-
let get_inv = Jmap_eio.Client.Build.email_get
131
-
~call_id:"g1"
132
-
~account_id:primary_account_id
133
-
~ids:email_ids
134
-
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size";
135
-
"receivedAt"; "subject"; "from"; "preview"]
136
-
()
137
-
in
138
-
139
-
let req2 = Jmap_eio.Client.Build.make_request
140
-
~capabilities:[Jmap_proto.Capability.core; Jmap_proto.Capability.mail]
141
-
[get_inv]
142
-
in
143
-
144
-
debug "Built Email/get request for %d emails" (List.length email_ids);
145
-
Printf.printf "Fetching email details...\n%!";
146
-
147
-
match Jmap_eio.Client.request client req2 with
148
-
| Error e ->
149
-
Printf.eprintf "Get failed: %s\n" (Jmap_eio.Client.error_to_string e);
150
-
exit 1
151
-
| Ok response2 ->
152
-
debug "Get response received, parsing...";
153
-
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
154
-
| Error e ->
155
-
Printf.eprintf "Failed to parse get response: %s\n" (Jsont.Error.to_string e);
156
-
exit 1
157
-
| Ok get_result ->
158
-
debug "Get state: %s" get_result.state;
159
-
debug "Emails returned: %d" (List.length get_result.list);
160
-
debug "Not found: %d" (List.length get_result.not_found);
161
-
Printf.printf "\n=== Recent Emails ===\n\n%!";
162
-
List.iter (fun (email : Jmap_mail.Email.t) ->
163
-
let id = Jmap_proto.Id.to_string email.id in
164
-
let subject = Option.value email.subject ~default:"(no subject)" in
165
-
let from_addrs = Option.value email.from ~default:[] in
166
-
let from_str = match from_addrs with
167
-
| [] -> "(unknown sender)"
168
-
| addr :: _ ->
169
-
let name = Option.value addr.name ~default:"" in
170
-
let email_addr = addr.email in
171
-
if name = "" then email_addr
172
-
else Printf.sprintf "%s <%s>" name email_addr
173
-
in
174
-
let received = ptime_to_string email.received_at in
175
-
let preview = email.preview in
176
-
let preview_short =
177
-
if String.length preview > 80 then
178
-
String.sub preview 0 77 ^ "..."
179
-
else preview
180
-
in
181
-
Printf.printf "ID: %s\n" id;
182
-
Printf.printf "From: %s\n" from_str;
183
-
Printf.printf "Date: %s\n" received;
184
-
Printf.printf "Subject: %s\n" subject;
185
-
Printf.printf "Preview: %s\n" preview_short;
186
-
Printf.printf "\n%!";
187
-
) get_result.list;
188
-
Printf.printf "=== End of emails ===\n%!"
189
-
)
+662
bin/jmapq.ml
+662
bin/jmapq.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAPQ - Specialist JMAP workflow commands *)
7
+
8
+
open Cmdliner
9
+
10
+
(** {1 Helpers} *)
11
+
12
+
let ptime_to_string t =
13
+
let (y, m, d), ((hh, mm, ss), _tz) = Ptime.to_date_time t in
14
+
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" y m d hh mm ss
15
+
16
+
let truncate_string max_len s =
17
+
if String.length s <= max_len then s
18
+
else String.sub s 0 (max_len - 3) ^ "..."
19
+
20
+
(** {1 Zulip Types and Codec} *)
21
+
22
+
(** Parsed information from a Zulip notification email subject.
23
+
Subject format: "#Channel > topic [Server Name]" *)
24
+
module Zulip_message = struct
25
+
type t = {
26
+
id : string;
27
+
date : Ptime.t;
28
+
thread_id : string;
29
+
channel : string;
30
+
topic : string;
31
+
server : string;
32
+
is_read : bool;
33
+
labels : string list;
34
+
}
35
+
36
+
(** Parse a Zulip subject line of the form "#Channel > topic [Server Name]" *)
37
+
let parse_subject subject =
38
+
(* Pattern: #<channel> > <topic> [<server>] *)
39
+
let channel_re = Re.Pcre.regexp {|^#(.+?)\s*>\s*(.+?)\s*\[(.+?)\]$|} in
40
+
match Re.exec_opt channel_re subject with
41
+
| Some groups ->
42
+
let channel = Re.Group.get groups 1 in
43
+
let topic = Re.Group.get groups 2 in
44
+
let server = Re.Group.get groups 3 in
45
+
Some (channel, topic, server)
46
+
| None -> None
47
+
48
+
(** Check if an email has the $seen keyword *)
49
+
let is_seen keywords =
50
+
List.exists (fun (k, v) -> k = "$seen" && v) keywords
51
+
52
+
(** Extract label strings from keywords, excluding standard JMAP keywords *)
53
+
let extract_labels keywords =
54
+
keywords
55
+
|> List.filter_map (fun (k, v) ->
56
+
if v && not (String.length k > 0 && k.[0] = '$') then
57
+
Some k
58
+
else if v && k = "$flagged" then
59
+
Some "flagged"
60
+
else
61
+
None)
62
+
63
+
(** Create a Zulip_message from a JMAP Email *)
64
+
let of_email (email : Jmap.Proto.Email.t) : t option =
65
+
let id = match email.id with
66
+
| Some id -> Jmap.Proto.Id.to_string id
67
+
| None -> ""
68
+
in
69
+
let date = match email.received_at with
70
+
| Some t -> t
71
+
| None -> Ptime.epoch
72
+
in
73
+
let thread_id = match email.thread_id with
74
+
| Some id -> Jmap.Proto.Id.to_string id
75
+
| None -> ""
76
+
in
77
+
let subject = Option.value ~default:"" email.subject in
78
+
match parse_subject subject with
79
+
| None -> None
80
+
| Some (channel, topic, server) ->
81
+
let keywords = Option.value ~default:[] email.keywords in
82
+
let is_read = is_seen keywords in
83
+
let labels = extract_labels keywords in
84
+
Some { id; date; thread_id; channel; topic; server; is_read; labels }
85
+
86
+
(** Jsont codec for Ptime.t - reuse the library's UTC date codec *)
87
+
let ptime_jsont : Ptime.t Jsont.t = Jmap.Proto.Date.Utc.jsont
88
+
89
+
(** Jsont codec for a single Zulip message *)
90
+
let jsont : t Jsont.t =
91
+
let kind = "ZulipMessage" in
92
+
let make id date thread_id channel topic server is_read labels =
93
+
{ id; date; thread_id; channel; topic; server; is_read; labels }
94
+
in
95
+
Jsont.Object.map ~kind make
96
+
|> Jsont.Object.mem "id" Jsont.string ~enc:(fun t -> t.id)
97
+
|> Jsont.Object.mem "date" ptime_jsont ~enc:(fun t -> t.date)
98
+
|> Jsont.Object.mem "thread_id" Jsont.string ~enc:(fun t -> t.thread_id)
99
+
|> Jsont.Object.mem "channel" Jsont.string ~enc:(fun t -> t.channel)
100
+
|> Jsont.Object.mem "topic" Jsont.string ~enc:(fun t -> t.topic)
101
+
|> Jsont.Object.mem "server" Jsont.string ~enc:(fun t -> t.server)
102
+
|> Jsont.Object.mem "is_read" Jsont.bool ~enc:(fun t -> t.is_read)
103
+
|> Jsont.Object.mem "labels" (Jsont.list Jsont.string) ~enc:(fun t -> t.labels)
104
+
|> Jsont.Object.finish
105
+
106
+
(** Jsont codec for a list of Zulip messages *)
107
+
let list_jsont : t list Jsont.t = Jsont.list jsont
108
+
end
109
+
110
+
(** {1 Zulip List Command} *)
111
+
112
+
let zulip_list_cmd =
113
+
let json_term =
114
+
let doc = "Output as JSON" in
115
+
Arg.(value & flag & info ["json"] ~doc)
116
+
in
117
+
let limit_term =
118
+
let doc = "Maximum number of messages to fetch (default: all)" in
119
+
Arg.(value & opt (some int) None & info ["limit"; "n"] ~docv:"N" ~doc)
120
+
in
121
+
let run cfg json_output limit =
122
+
Eio_main.run @@ fun env ->
123
+
Eio.Switch.run @@ fun sw ->
124
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
125
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
126
+
127
+
Jmap_eio.Cli.debug cfg "Searching for Zulip notification emails";
128
+
129
+
(* Build filter for emails from noreply@zulip.com *)
130
+
let cond : Jmap.Proto.Email.Filter_condition.t = {
131
+
in_mailbox = None; in_mailbox_other_than = None;
132
+
before = None; after = None;
133
+
min_size = None; max_size = None;
134
+
all_in_thread_have_keyword = None;
135
+
some_in_thread_have_keyword = None;
136
+
none_in_thread_have_keyword = None;
137
+
has_keyword = None; not_keyword = None;
138
+
has_attachment = None;
139
+
text = None;
140
+
from = Some "noreply@zulip.com";
141
+
to_ = None;
142
+
cc = None; bcc = None; subject = None;
143
+
body = None; header = None;
144
+
} in
145
+
let filter = Jmap.Proto.Filter.Condition cond in
146
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
147
+
148
+
(* Query for all Zulip emails *)
149
+
let query_limit = match limit with
150
+
| Some n -> Int64.of_int n
151
+
| None -> Int64.of_int 10000 (* Large default to get "all" *)
152
+
in
153
+
let query_inv = Jmap_eio.Client.Build.email_query
154
+
~call_id:"q1"
155
+
~account_id
156
+
~filter
157
+
~sort
158
+
~limit:query_limit
159
+
()
160
+
in
161
+
162
+
let req = Jmap_eio.Client.Build.(
163
+
make_request
164
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
165
+
[query_inv]
166
+
) in
167
+
168
+
match Jmap_eio.Client.request client req with
169
+
| Error e ->
170
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
171
+
exit 1
172
+
| Ok response ->
173
+
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
174
+
| Error e ->
175
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
176
+
exit 1
177
+
| Ok query_result ->
178
+
let email_ids = query_result.ids in
179
+
Jmap_eio.Cli.debug cfg "Found %d Zulip email IDs" (List.length email_ids);
180
+
181
+
if List.length email_ids = 0 then (
182
+
if json_output then
183
+
Fmt.pr "[]@."
184
+
else
185
+
Fmt.pr "No Zulip notification emails found.@."
186
+
) else (
187
+
(* Fetch email details *)
188
+
let get_inv = Jmap_eio.Client.Build.email_get
189
+
~call_id:"g1"
190
+
~account_id
191
+
~ids:email_ids
192
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
193
+
"size"; "receivedAt"; "subject"; "from"]
194
+
()
195
+
in
196
+
let req2 = Jmap_eio.Client.Build.(
197
+
make_request
198
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
199
+
[get_inv]
200
+
) in
201
+
202
+
match Jmap_eio.Client.request client req2 with
203
+
| Error e ->
204
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
205
+
exit 1
206
+
| Ok response2 ->
207
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
208
+
| Error e ->
209
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
210
+
exit 1
211
+
| Ok get_result ->
212
+
(* Parse Zulip subjects and filter successful parses *)
213
+
let zulip_messages =
214
+
get_result.list
215
+
|> List.filter_map Zulip_message.of_email
216
+
in
217
+
218
+
Jmap_eio.Cli.debug cfg "Parsed %d Zulip messages from %d emails"
219
+
(List.length zulip_messages)
220
+
(List.length get_result.list);
221
+
222
+
if json_output then (
223
+
(* Output as JSON *)
224
+
match Jsont_bytesrw.encode_string' ~format:Jsont.Indent Zulip_message.list_jsont zulip_messages with
225
+
| Ok json_str -> Fmt.pr "%s@." json_str
226
+
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e)
227
+
) else (
228
+
(* Human-readable output *)
229
+
Fmt.pr "@[<v>%a (%d messages)@,@,"
230
+
Fmt.(styled `Bold string) "Zulip Notifications"
231
+
(List.length zulip_messages);
232
+
233
+
(* Group by server, then by channel *)
234
+
let by_server = Hashtbl.create 8 in
235
+
List.iter (fun (msg : Zulip_message.t) ->
236
+
let existing = try Hashtbl.find by_server msg.server with Not_found -> [] in
237
+
Hashtbl.replace by_server msg.server (msg :: existing)
238
+
) zulip_messages;
239
+
240
+
Hashtbl.iter (fun server msgs ->
241
+
Fmt.pr "%a [%s]@,"
242
+
Fmt.(styled `Bold string) "Server:"
243
+
server;
244
+
245
+
(* Group by channel within server *)
246
+
let by_channel = Hashtbl.create 8 in
247
+
List.iter (fun (msg : Zulip_message.t) ->
248
+
let existing = try Hashtbl.find by_channel msg.channel with Not_found -> [] in
249
+
Hashtbl.replace by_channel msg.channel (msg :: existing)
250
+
) msgs;
251
+
252
+
Hashtbl.iter (fun channel channel_msgs ->
253
+
Fmt.pr " %a #%s (%d)@,"
254
+
Fmt.(styled `Cyan string) "Channel:"
255
+
channel
256
+
(List.length channel_msgs);
257
+
258
+
(* Sort by date descending *)
259
+
let sorted = List.sort (fun a b ->
260
+
Ptime.compare b.Zulip_message.date a.Zulip_message.date
261
+
) channel_msgs in
262
+
263
+
List.iter (fun (msg : Zulip_message.t) ->
264
+
let read_marker = if msg.is_read then " " else "*" in
265
+
let labels_str = match msg.labels with
266
+
| [] -> ""
267
+
| ls -> " [" ^ String.concat ", " ls ^ "]"
268
+
in
269
+
Fmt.pr " %s %s %a %s%s@,"
270
+
read_marker
271
+
(ptime_to_string msg.date)
272
+
Fmt.(styled `Yellow string) (truncate_string 40 msg.topic)
273
+
(truncate_string 12 msg.id)
274
+
labels_str
275
+
) sorted;
276
+
Fmt.pr "@,"
277
+
) by_channel
278
+
) by_server;
279
+
280
+
Fmt.pr "@]@."
281
+
)
282
+
)
283
+
in
284
+
let doc = "List Zulip notification emails with parsed channel/topic info" in
285
+
let man = [
286
+
`S Manpage.s_description;
287
+
`P "Lists all emails from noreply@zulip.com and parses the subject line to extract \
288
+
the Zulip channel, topic, and server name.";
289
+
`P "Subject format expected: \"#Channel > topic [Server Name]\"";
290
+
`S Manpage.s_examples;
291
+
`P "List all Zulip notifications:";
292
+
`Pre " jmapq zulip-list";
293
+
`P "Output as JSON:";
294
+
`Pre " jmapq zulip-list --json";
295
+
`P "Limit to 50 most recent:";
296
+
`Pre " jmapq zulip-list -n 50";
297
+
] in
298
+
let info = Cmd.info "zulip-list" ~doc ~man in
299
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ json_term $ limit_term)
300
+
301
+
(** {1 Zulip Timeout Command} *)
302
+
303
+
(** The keyword used to mark Zulip notifications as processed *)
304
+
let zulip_processed_keyword = "zulip-processed"
305
+
306
+
let zulip_timeout_cmd =
307
+
let email_ids_term =
308
+
let doc = "Email IDs to mark as processed" in
309
+
Arg.(non_empty & pos_all string [] & info [] ~docv:"EMAIL_ID" ~doc)
310
+
in
311
+
let verbose_term =
312
+
let doc = "Show the raw JMAP server response" in
313
+
Arg.(value & flag & info ["v"; "verbose"] ~doc)
314
+
in
315
+
let run cfg verbose email_id_strs =
316
+
Eio_main.run @@ fun env ->
317
+
Eio.Switch.run @@ fun sw ->
318
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
319
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
320
+
let email_ids = List.map Jmap.Proto.Id.of_string_exn email_id_strs in
321
+
322
+
Jmap_eio.Cli.debug cfg "Marking %d email(s) with '%s' keyword"
323
+
(List.length email_ids) zulip_processed_keyword;
324
+
325
+
(* Build patch to add the zulip-processed keyword and mark as read *)
326
+
let patch =
327
+
let open Jmap_eio.Chain in
328
+
json_obj [
329
+
("keywords/" ^ zulip_processed_keyword, json_bool true);
330
+
("keywords/$seen", json_bool true);
331
+
]
332
+
in
333
+
334
+
(* Build updates list: each email ID gets the same patch *)
335
+
let updates = List.map (fun id -> (id, patch)) email_ids in
336
+
337
+
let open Jmap_eio.Chain in
338
+
let request, set_h = build
339
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
340
+
begin
341
+
email_set ~account_id
342
+
~update:updates
343
+
()
344
+
end in
345
+
346
+
match Jmap_eio.Client.request client request with
347
+
| Error e ->
348
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
349
+
exit 1
350
+
| Ok response ->
351
+
(* Print raw response if verbose *)
352
+
if verbose then begin
353
+
Fmt.pr "@[<v>%a:@," Fmt.(styled `Bold string) "Server Response";
354
+
(match Jsont_bytesrw.encode_string' ~format:Jsont.Indent
355
+
Jmap.Proto.Response.jsont response with
356
+
| Ok json_str -> Fmt.pr "%s@,@]@." json_str
357
+
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e))
358
+
end;
359
+
(* Check for JMAP method-level errors first *)
360
+
let call_id = Jmap_eio.Chain.call_id set_h in
361
+
(match Jmap.Proto.Response.find_response call_id response with
362
+
| None ->
363
+
Fmt.epr "Error: No response found for call_id %s@." call_id;
364
+
exit 1
365
+
| Some inv when Jmap.Proto.Response.is_error inv ->
366
+
(match Jmap.Proto.Response.get_error inv with
367
+
| Some err ->
368
+
Fmt.epr "JMAP Error: %s%s@."
369
+
(Jmap.Proto.Error.method_error_type_to_string err.type_)
370
+
(match err.description with Some d -> " - " ^ d | None -> "");
371
+
exit 1
372
+
| None ->
373
+
Fmt.epr "JMAP Error: Unknown error@.";
374
+
exit 1)
375
+
| Some _ ->
376
+
match parse set_h response with
377
+
| Error e ->
378
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
379
+
exit 1
380
+
| Ok result ->
381
+
(* Report successes *)
382
+
let updated_ids =
383
+
result.updated
384
+
|> Option.value ~default:[]
385
+
|> List.map (fun (id, _) -> Jmap.Proto.Id.to_string id)
386
+
in
387
+
if List.length updated_ids > 0 then begin
388
+
Fmt.pr "@[<v>%a %d email(s) as read with '%s':@,"
389
+
Fmt.(styled `Green string) "Marked"
390
+
(List.length updated_ids)
391
+
zulip_processed_keyword;
392
+
List.iter (fun id -> Fmt.pr " %s@," id) updated_ids;
393
+
Fmt.pr "@]@."
394
+
end;
395
+
396
+
(* Report failures *)
397
+
let not_updated = Option.value ~default:[] result.not_updated in
398
+
if not_updated <> [] then begin
399
+
Fmt.epr "@[<v>%a to mark %d email(s):@,"
400
+
Fmt.(styled `Red string) "Failed"
401
+
(List.length not_updated);
402
+
List.iter (fun (id, err) ->
403
+
let open Jmap.Proto.Error in
404
+
let err_type = set_error_type_to_string err.type_ in
405
+
let err_desc = Option.value ~default:"" err.description in
406
+
Fmt.epr " %s: %s%s@,"
407
+
(Jmap.Proto.Id.to_string id)
408
+
err_type
409
+
(if err_desc = "" then "" else " - " ^ err_desc)
410
+
) not_updated;
411
+
Fmt.epr "@]@.";
412
+
exit 1
413
+
end)
414
+
in
415
+
let doc = "Mark Zulip notification emails as processed" in
416
+
let man = [
417
+
`S Manpage.s_description;
418
+
`P (Printf.sprintf "Adds the '%s' keyword to the specified email(s). \
419
+
This keyword can be used to filter processed Zulip notifications \
420
+
or set up server-side rules to auto-archive them."
421
+
zulip_processed_keyword);
422
+
`S Manpage.s_examples;
423
+
`P "Mark a single email as processed:";
424
+
`Pre " jmapq zulip-timeout StrrDTS_WEa3";
425
+
`P "Mark multiple emails as processed:";
426
+
`Pre " jmapq zulip-timeout StrrDTS_WEa3 StrsGZ7P8Dpc StrsGuCSXJ3Z";
427
+
] in
428
+
let info = Cmd.info "zulip-timeout" ~doc ~man in
429
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ verbose_term $ email_ids_term)
430
+
431
+
(** {1 Zulip View Command} *)
432
+
433
+
let zulip_view_cmd =
434
+
let json_term =
435
+
let doc = "Output as JSON" in
436
+
Arg.(value & flag & info ["json"] ~doc)
437
+
in
438
+
let limit_term =
439
+
let doc = "Maximum number of messages to fetch (default: all)" in
440
+
Arg.(value & opt (some int) None & info ["limit"; "n"] ~docv:"N" ~doc)
441
+
in
442
+
let verbose_term =
443
+
let doc = "Show the raw JMAP request and response" in
444
+
Arg.(value & flag & info ["v"; "verbose"] ~doc)
445
+
in
446
+
let run cfg json_output limit verbose =
447
+
Eio_main.run @@ fun env ->
448
+
Eio.Switch.run @@ fun sw ->
449
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
450
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
451
+
452
+
Jmap_eio.Cli.debug cfg "Searching for Zulip emails marked as processed";
453
+
454
+
(* Build filter for emails from noreply@zulip.com with zulip-processed keyword *)
455
+
let cond : Jmap.Proto.Email.Filter_condition.t = {
456
+
in_mailbox = None; in_mailbox_other_than = None;
457
+
before = None; after = None;
458
+
min_size = None; max_size = None;
459
+
all_in_thread_have_keyword = None;
460
+
some_in_thread_have_keyword = None;
461
+
none_in_thread_have_keyword = None;
462
+
has_keyword = Some zulip_processed_keyword;
463
+
not_keyword = None;
464
+
has_attachment = None;
465
+
text = None;
466
+
from = Some "noreply@zulip.com";
467
+
to_ = None;
468
+
cc = None; bcc = None; subject = None;
469
+
body = None; header = None;
470
+
} in
471
+
let filter = Jmap.Proto.Filter.Condition cond in
472
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
473
+
474
+
(* Query for processed Zulip emails *)
475
+
let query_limit = match limit with
476
+
| Some n -> Int64.of_int n
477
+
| None -> Int64.of_int 10000
478
+
in
479
+
let query_inv = Jmap_eio.Client.Build.email_query
480
+
~call_id:"q1"
481
+
~account_id
482
+
~filter
483
+
~sort
484
+
~limit:query_limit
485
+
()
486
+
in
487
+
488
+
let req = Jmap_eio.Client.Build.(
489
+
make_request
490
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
491
+
[query_inv]
492
+
) in
493
+
494
+
(* Print request if verbose *)
495
+
if verbose then begin
496
+
Fmt.pr "@[<v>%a:@," Fmt.(styled `Bold string) "Request";
497
+
(match Jsont_bytesrw.encode_string' ~format:Jsont.Indent
498
+
Jmap.Proto.Request.jsont req with
499
+
| Ok json_str -> Fmt.pr "%s@,@]@." json_str
500
+
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e))
501
+
end;
502
+
503
+
match Jmap_eio.Client.request client req with
504
+
| Error e ->
505
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
506
+
exit 1
507
+
| Ok response ->
508
+
(* Print response if verbose *)
509
+
if verbose then begin
510
+
Fmt.pr "@[<v>%a:@," Fmt.(styled `Bold string) "Response";
511
+
(match Jsont_bytesrw.encode_string' ~format:Jsont.Indent
512
+
Jmap.Proto.Response.jsont response with
513
+
| Ok json_str -> Fmt.pr "%s@,@]@." json_str
514
+
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e))
515
+
end;
516
+
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
517
+
| Error e ->
518
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
519
+
exit 1
520
+
| Ok query_result ->
521
+
let email_ids = query_result.ids in
522
+
Jmap_eio.Cli.debug cfg "Found %d processed Zulip email IDs" (List.length email_ids);
523
+
524
+
if List.length email_ids = 0 then (
525
+
if json_output then
526
+
Fmt.pr "[]@."
527
+
else
528
+
Fmt.pr "No Zulip emails marked as processed.@."
529
+
) else (
530
+
(* Fetch email details *)
531
+
let get_inv = Jmap_eio.Client.Build.email_get
532
+
~call_id:"g1"
533
+
~account_id
534
+
~ids:email_ids
535
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
536
+
"size"; "receivedAt"; "subject"; "from"]
537
+
()
538
+
in
539
+
let req2 = Jmap_eio.Client.Build.(
540
+
make_request
541
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
542
+
[get_inv]
543
+
) in
544
+
545
+
match Jmap_eio.Client.request client req2 with
546
+
| Error e ->
547
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
548
+
exit 1
549
+
| Ok response2 ->
550
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
551
+
| Error e ->
552
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
553
+
exit 1
554
+
| Ok get_result ->
555
+
(* Parse Zulip subjects and filter successful parses *)
556
+
let zulip_messages =
557
+
get_result.list
558
+
|> List.filter_map Zulip_message.of_email
559
+
in
560
+
561
+
Jmap_eio.Cli.debug cfg "Parsed %d Zulip messages from %d emails"
562
+
(List.length zulip_messages)
563
+
(List.length get_result.list);
564
+
565
+
if json_output then (
566
+
(* Output as JSON *)
567
+
match Jsont_bytesrw.encode_string' ~format:Jsont.Indent Zulip_message.list_jsont zulip_messages with
568
+
| Ok json_str -> Fmt.pr "%s@." json_str
569
+
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e)
570
+
) else (
571
+
(* Human-readable output *)
572
+
Fmt.pr "@[<v>%a (%d messages)@,@,"
573
+
Fmt.(styled `Bold string) "Processed Zulip Notifications"
574
+
(List.length zulip_messages);
575
+
576
+
(* Group by server, then by channel *)
577
+
let by_server = Hashtbl.create 8 in
578
+
List.iter (fun (msg : Zulip_message.t) ->
579
+
let existing = try Hashtbl.find by_server msg.server with Not_found -> [] in
580
+
Hashtbl.replace by_server msg.server (msg :: existing)
581
+
) zulip_messages;
582
+
583
+
Hashtbl.iter (fun server msgs ->
584
+
Fmt.pr "%a [%s]@,"
585
+
Fmt.(styled `Bold string) "Server:"
586
+
server;
587
+
588
+
(* Group by channel within server *)
589
+
let by_channel = Hashtbl.create 8 in
590
+
List.iter (fun (msg : Zulip_message.t) ->
591
+
let existing = try Hashtbl.find by_channel msg.channel with Not_found -> [] in
592
+
Hashtbl.replace by_channel msg.channel (msg :: existing)
593
+
) msgs;
594
+
595
+
Hashtbl.iter (fun channel channel_msgs ->
596
+
Fmt.pr " %a #%s (%d)@,"
597
+
Fmt.(styled `Cyan string) "Channel:"
598
+
channel
599
+
(List.length channel_msgs);
600
+
601
+
(* Sort by date descending *)
602
+
let sorted = List.sort (fun a b ->
603
+
Ptime.compare b.Zulip_message.date a.Zulip_message.date
604
+
) channel_msgs in
605
+
606
+
List.iter (fun (msg : Zulip_message.t) ->
607
+
let read_marker = if msg.is_read then " " else "*" in
608
+
let labels_str = match msg.labels with
609
+
| [] -> ""
610
+
| ls -> " [" ^ String.concat ", " ls ^ "]"
611
+
in
612
+
Fmt.pr " %s %s %a %s%s@,"
613
+
read_marker
614
+
(ptime_to_string msg.date)
615
+
Fmt.(styled `Yellow string) (truncate_string 40 msg.topic)
616
+
(truncate_string 12 msg.id)
617
+
labels_str
618
+
) sorted;
619
+
Fmt.pr "@,"
620
+
) by_channel
621
+
) by_server;
622
+
623
+
Fmt.pr "@]@."
624
+
)
625
+
)
626
+
in
627
+
let doc = "List Zulip emails that have been marked as processed" in
628
+
let man = [
629
+
`S Manpage.s_description;
630
+
`P (Printf.sprintf "Lists all Zulip notification emails that have the '%s' keyword."
631
+
zulip_processed_keyword);
632
+
`S Manpage.s_examples;
633
+
`P "List all processed Zulip notifications:";
634
+
`Pre " jmapq zulip-view";
635
+
`P "Output as JSON:";
636
+
`Pre " jmapq zulip-view --json";
637
+
`P "Limit to 50 most recent:";
638
+
`Pre " jmapq zulip-view -n 50";
639
+
] in
640
+
let info = Cmd.info "zulip-view" ~doc ~man in
641
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ json_term $ limit_term $ verbose_term)
642
+
643
+
(** {1 Main Command Group} *)
644
+
645
+
let main_cmd =
646
+
let doc = "JMAPQ - Specialist JMAP workflow commands" in
647
+
let man = [
648
+
`S Manpage.s_description;
649
+
`P "A collection of specialist workflow commands for JMAP email processing.";
650
+
`S Manpage.s_environment;
651
+
`P Jmap_eio.Cli.env_docs;
652
+
] in
653
+
let info = Cmd.info "jmapq" ~version:"0.1.0" ~doc ~man in
654
+
Cmd.group info [
655
+
zulip_list_cmd;
656
+
zulip_timeout_cmd;
657
+
zulip_view_cmd;
658
+
]
659
+
660
+
let () =
661
+
Fmt_tty.setup_std_outputs ();
662
+
exit (Cmd.eval main_cmd)
+8
-8
bin/tutorial_examples.ml
+8
-8
bin/tutorial_examples.ml
···
2
2
3
3
open Lwt.Syntax
4
4
open Jmap
5
-
open Jmap_mail
5
+
open Jmap.Mail
6
6
7
7
(* Example: Authentication *)
8
8
let auth_example () =
···
13
13
Printf.eprintf "Error: JMAP_API_TOKEN environment variable not set\n";
14
14
Lwt.return_none
15
15
| Some token ->
16
-
let+ result = Jmap_mail.login_with_token
16
+
let+ result = Jmap.Proto.login_with_token
17
17
~uri:"https://api.fastmail.com/jmap/session"
18
18
~api_token:token
19
19
in
···
23
23
| Ok conn ->
24
24
(* Get the primary account ID *)
25
25
let account_id =
26
-
let mail_capability = Jmap_mail.Capability.to_string Jmap_mail.Capability.Mail in
26
+
let mail_capability = Jmap.Proto.Capability.to_string Jmap.Proto.Capability.Mail in
27
27
match List.assoc_opt mail_capability conn.session.primary_accounts with
28
28
| Some id -> id
29
29
| None ->
···
45
45
(* Example: Working with Mailboxes *)
46
46
let mailbox_example (conn, account_id) =
47
47
(* Get all mailboxes *)
48
-
let+ mailboxes_result = Jmap_mail.get_mailboxes conn ~account_id in
48
+
let+ mailboxes_result = Jmap.Proto.get_mailboxes conn ~account_id in
49
49
50
50
match mailboxes_result with
51
51
| Ok mailboxes ->
···
78
78
(* Example: Working with Emails *)
79
79
let email_example (conn, account_id, mailbox_id) =
80
80
(* Get emails from mailbox *)
81
-
let+ emails_result = Jmap_mail.get_messages_in_mailbox
81
+
let+ emails_result = Jmap.Proto.get_messages_in_mailbox
82
82
conn
83
83
~account_id
84
84
~mailbox_id
···
91
91
Printf.printf "Found %d emails\n" (List.length emails);
92
92
93
93
(* Display emails *)
94
-
List.iter (fun (email:Jmap_mail.Types.email) ->
94
+
List.iter (fun (email:Jmap.Proto.Types.email) ->
95
95
(* Using explicit module path for Types to avoid ambiguity *)
96
-
let module Mail = Jmap_mail.Types in
96
+
let module Mail = Jmap.Proto.Types in
97
97
98
98
(* Get sender info *)
99
99
let from = match email.Mail.from with
···
127
127
128
128
match emails with
129
129
| [] -> None
130
-
| hd::_ -> Some (conn, account_id, hd.Jmap_mail.Types.id)
130
+
| hd::_ -> Some (conn, account_id, hd.Jmap.Proto.Types.id)
131
131
end
132
132
| Error e ->
133
133
Printf.eprintf "Error getting emails: %s\n"
+7
doc/dune
+7
doc/dune
+13
doc/index.mld
+13
doc/index.mld
···
1
+
{0 jmap}
2
+
3
+
{!modules: Jmap Jmap_top}
4
+
5
+
{1 Tutorial}
6
+
7
+
See the {!page-tutorial} for a comprehensive guide to using JMAP with OCaml,
8
+
including how types map to JSON and practical examples.
9
+
10
+
{1 Browser Support}
11
+
12
+
For browser-based applications, see the [jmap-brr] package which provides
13
+
a JMAP client using the Brr library and js_of_ocaml.
+494
doc/tutorial.mld
+494
doc/tutorial.mld
···
1
+
{0 JMAP Tutorial}
2
+
3
+
This tutorial introduces JMAP (JSON Meta Application Protocol) and
4
+
demonstrates the [jmap] OCaml library through interactive examples. JMAP
5
+
is defined in {{:https://www.rfc-editor.org/rfc/rfc8620}RFC 8620} (core)
6
+
and {{:https://www.rfc-editor.org/rfc/rfc8621}RFC 8621} (mail).
7
+
8
+
{1 What is JMAP?}
9
+
10
+
JMAP is a modern, efficient protocol for synchronizing mail and other
11
+
data. It's designed as a better alternative to IMAP, addressing many of
12
+
IMAP's limitations:
13
+
14
+
{ul
15
+
{- {b Stateless over HTTP}: Unlike IMAP's persistent TCP connections, JMAP
16
+
uses standard HTTP POST requests with JSON payloads.}
17
+
{- {b Efficient batching}: Multiple operations can be combined into a single
18
+
request, reducing round-trips.}
19
+
{- {b Result references}: The output of one method call can be used as input
20
+
to another in the same request.}
21
+
{- {b Push support}: Built-in mechanisms for real-time notifications.}
22
+
{- {b Binary data handling}: Separate upload/download endpoints for large
23
+
attachments.}}
24
+
25
+
The core protocol (RFC 8620) defines the general structure, while RFC 8621
26
+
extends it specifically for email, mailboxes, threads, and related objects.
27
+
28
+
{1 Setup}
29
+
30
+
First, let's set up our environment. In the toplevel, load the library
31
+
with [#require "jmap.top";;] which will automatically install pretty
32
+
printers.
33
+
34
+
{@ocaml[
35
+
# Jmap_top.install ();;
36
+
- : unit = ()
37
+
# open Jmap;;
38
+
]}
39
+
40
+
For parsing and encoding JSON, we'll use some helper functions:
41
+
42
+
{@ocaml[
43
+
# let parse_json s =
44
+
match Jsont_bytesrw.decode_string Jsont.json s with
45
+
| Ok json -> json
46
+
| Error e -> failwith e;;
47
+
val parse_json : string -> Jsont.json = <fun>
48
+
# let json_to_string json =
49
+
match Jsont_bytesrw.encode_string ~format:Jsont.Indent Jsont.json json with
50
+
| Ok s -> s
51
+
| Error e -> failwith e;;
52
+
val json_to_string : Jsont.json -> string = <fun>
53
+
]}
54
+
55
+
{1 JMAP Identifiers}
56
+
57
+
From {{:https://www.rfc-editor.org/rfc/rfc8620#section-1.2}RFC 8620 Section 1.2}:
58
+
59
+
{i An "Id" is a String of at least 1 and a maximum of 255 octets in size,
60
+
and it MUST only contain characters from the "URL and Filename Safe"
61
+
base64 alphabet.}
62
+
63
+
The {!Jmap.Id} module provides type-safe identifiers:
64
+
65
+
{@ocaml[
66
+
# let id = Id.of_string_exn "abc123";;
67
+
val id : Id.t = abc123
68
+
# Id.to_string id;;
69
+
- : string = "abc123"
70
+
]}
71
+
72
+
Invalid identifiers are rejected:
73
+
74
+
{@ocaml[
75
+
# Id.of_string "";;
76
+
- : (Id.t, string) result = Error "Id cannot be empty"
77
+
# Id.of_string (String.make 256 'x');;
78
+
- : (Id.t, string) result = Error "Id cannot exceed 255 characters"
79
+
]}
80
+
81
+
{1 Keywords}
82
+
83
+
Email keywords are string flags that indicate message state. RFC 8621
84
+
defines standard keywords, and the library represents them as polymorphic
85
+
variants for type safety.
86
+
87
+
{2 Standard Keywords}
88
+
89
+
From {{:https://www.rfc-editor.org/rfc/rfc8621#section-4.1.1}RFC 8621
90
+
Section 4.1.1}:
91
+
92
+
{@ocaml[
93
+
# Keyword.of_string "$seen";;
94
+
- : Keyword.t = $seen
95
+
# Keyword.of_string "$flagged";;
96
+
- : Keyword.t = $flagged
97
+
# Keyword.of_string "$draft";;
98
+
- : Keyword.t = $draft
99
+
# Keyword.of_string "$answered";;
100
+
- : Keyword.t = $answered
101
+
]}
102
+
103
+
The standard keywords are:
104
+
105
+
{ul
106
+
{- [`Seen] - The email has been read}
107
+
{- [`Flagged] - The email has been flagged for attention}
108
+
{- [`Draft] - The email is a draft being composed}
109
+
{- [`Answered] - The email has been replied to}
110
+
{- [`Forwarded] - The email has been forwarded}
111
+
{- [`Phishing] - The email is likely phishing}
112
+
{- [`Junk] - The email is spam}
113
+
{- [`NotJunk] - The email is definitely not spam}}
114
+
115
+
{2 Extended Keywords}
116
+
117
+
The library also supports draft-ietf-mailmaint extended keywords:
118
+
119
+
{@ocaml[
120
+
# Keyword.of_string "$notify";;
121
+
- : Keyword.t = $notify
122
+
# Keyword.of_string "$muted";;
123
+
- : Keyword.t = $muted
124
+
# Keyword.of_string "$hasattachment";;
125
+
- : Keyword.t = $hasattachment
126
+
]}
127
+
128
+
{2 Custom Keywords}
129
+
130
+
Unknown keywords are preserved as [`Custom]:
131
+
132
+
{@ocaml[
133
+
# Keyword.of_string "$my_custom_flag";;
134
+
- : Keyword.t = $my_custom_flag
135
+
]}
136
+
137
+
{2 Converting Back to Strings}
138
+
139
+
{@ocaml[
140
+
# Keyword.to_string `Seen;;
141
+
- : string = "$seen"
142
+
# Keyword.to_string `Flagged;;
143
+
- : string = "$flagged"
144
+
# Keyword.to_string (`Custom "$important");;
145
+
- : string = "$important"
146
+
]}
147
+
148
+
{1 Mailbox Roles}
149
+
150
+
Mailboxes can have special roles that indicate their purpose. From
151
+
{{:https://www.rfc-editor.org/rfc/rfc8621#section-2}RFC 8621 Section 2}:
152
+
153
+
{@ocaml[
154
+
# Role.of_string "inbox";;
155
+
- : Role.t = inbox
156
+
# Role.of_string "sent";;
157
+
- : Role.t = sent
158
+
# Role.of_string "drafts";;
159
+
- : Role.t = drafts
160
+
# Role.of_string "trash";;
161
+
- : Role.t = trash
162
+
# Role.of_string "junk";;
163
+
- : Role.t = junk
164
+
# Role.of_string "archive";;
165
+
- : Role.t = archive
166
+
]}
167
+
168
+
Custom roles are also supported:
169
+
170
+
{@ocaml[
171
+
# Role.of_string "receipts";;
172
+
- : Role.t = receipts
173
+
]}
174
+
175
+
{1 Capabilities}
176
+
177
+
JMAP uses capability URIs to indicate supported features. From
178
+
{{:https://www.rfc-editor.org/rfc/rfc8620#section-2}RFC 8620 Section 2}:
179
+
180
+
{@ocaml[
181
+
# Capability.core_uri;;
182
+
- : string = "urn:ietf:params:jmap:core"
183
+
# Capability.mail_uri;;
184
+
- : string = "urn:ietf:params:jmap:mail"
185
+
# Capability.submission_uri;;
186
+
- : string = "urn:ietf:params:jmap:submission"
187
+
]}
188
+
189
+
{@ocaml[
190
+
# Capability.of_string Capability.core_uri;;
191
+
- : Capability.t = urn:ietf:params:jmap:core
192
+
# Capability.of_string Capability.mail_uri;;
193
+
- : Capability.t = urn:ietf:params:jmap:mail
194
+
# Capability.of_string "urn:example:custom";;
195
+
- : Capability.t = urn:example:custom
196
+
]}
197
+
198
+
{1 Understanding JMAP JSON Structure}
199
+
200
+
One of the key benefits of JMAP over IMAP is its use of JSON. Let's see
201
+
how OCaml types map to the wire format.
202
+
203
+
{2 Requests}
204
+
205
+
A JMAP request contains:
206
+
- [using]: List of capability URIs required
207
+
- [methodCalls]: Array of method invocations
208
+
209
+
Each method invocation is a triple: [methodName], [arguments], [callId].
210
+
211
+
Here's how a simple request is structured:
212
+
213
+
{x@ocaml[
214
+
# let req = Jmap.Proto.Request.create
215
+
~using:[Capability.core_uri; Capability.mail_uri]
216
+
~method_calls:[
217
+
Jmap.Proto.Invocation.create
218
+
~name:"Mailbox/get"
219
+
~arguments:(parse_json {|{"accountId": "abc123"}|})
220
+
~call_id:"c0"
221
+
]
222
+
();;
223
+
Line 7, characters 18-22:
224
+
Error: The function applied to this argument has type
225
+
method_call_id:string -> Proto.Invocation.t
226
+
This argument cannot be applied with label ~call_id
227
+
# Jmap_top.encode Jmap.Proto.Request.jsont req |> json_to_string |> print_endline;;
228
+
Line 1, characters 42-45:
229
+
Error: Unbound value req
230
+
Hint: Did you mean ref?
231
+
]x}
232
+
233
+
{2 Email Filter Conditions}
234
+
235
+
Filters demonstrate how complex query conditions map to JSON. From
236
+
{{:https://www.rfc-editor.org/rfc/rfc8621#section-4.4.1}RFC 8621
237
+
Section 4.4.1}:
238
+
239
+
{x@ocaml[
240
+
# let filter_condition : Jmap.Proto.Email.Filter_condition.t = {
241
+
in_mailbox = Some (Id.of_string_exn "inbox123");
242
+
in_mailbox_other_than = None;
243
+
before = None;
244
+
after = None;
245
+
min_size = None;
246
+
max_size = None;
247
+
all_in_thread_have_keyword = None;
248
+
some_in_thread_have_keyword = None;
249
+
none_in_thread_have_keyword = None;
250
+
has_keyword = Some "$flagged";
251
+
not_keyword = None;
252
+
has_attachment = Some true;
253
+
text = None;
254
+
from = Some "alice@";
255
+
to_ = None;
256
+
cc = None;
257
+
bcc = None;
258
+
subject = Some "urgent";
259
+
body = None;
260
+
header = None;
261
+
};;
262
+
Line 2, characters 23-52:
263
+
Error: This expression has type Id.t but an expression was expected of type
264
+
Proto.Id.t
265
+
# Jmap_top.encode Jmap.Proto.Email.Filter_condition.jsont filter_condition
266
+
|> json_to_string |> print_endline;;
267
+
Line 1, characters 57-73:
268
+
Error: Unbound value filter_condition
269
+
]x}
270
+
271
+
Notice how:
272
+
- OCaml record fields use [snake_case], but JSON uses [camelCase]
273
+
- [None] values are omitted from JSON (not sent as [null])
274
+
- The filter only includes non-empty conditions
275
+
276
+
{2 Filter Operators}
277
+
278
+
Filters can be combined with AND, OR, and NOT operators:
279
+
280
+
{x@ocaml[
281
+
# let combined_filter = Jmap.Proto.Filter.Operator {
282
+
operator = `And;
283
+
conditions = [
284
+
Condition filter_condition;
285
+
Condition { filter_condition with has_keyword = Some "$seen" }
286
+
]
287
+
};;
288
+
Line 4, characters 17-33:
289
+
Error: Unbound value filter_condition
290
+
]x}
291
+
292
+
{1 Method Chaining}
293
+
294
+
One of JMAP's most powerful features is result references - using the
295
+
output of one method as input to another. The {!Jmap.Chain} module
296
+
provides a monadic interface for building such requests.
297
+
298
+
From {{:https://www.rfc-editor.org/rfc/rfc8620#section-3.7}RFC 8620
299
+
Section 3.7}:
300
+
301
+
{i A method argument may use the result of a previous method invocation
302
+
in the same request.}
303
+
304
+
{2 Basic Example}
305
+
306
+
Query for emails, then fetch their details:
307
+
308
+
{[
309
+
open Jmap.Chain
310
+
311
+
let request, handle = build ~capabilities:[core; mail] begin
312
+
let* query = email_query ~account_id
313
+
~filter:(Condition { in_mailbox = Some inbox_id; (* ... *) })
314
+
~limit:50L ()
315
+
in
316
+
let* emails = email_get ~account_id
317
+
~ids:(from_query query) (* Reference query results! *)
318
+
~properties:["subject"; "from"; "receivedAt"]
319
+
()
320
+
in
321
+
return emails
322
+
end
323
+
][
324
+
{err@mdx-error[
325
+
Line 3, characters 46-50:
326
+
Error: Unbound value core
327
+
]err}]}
328
+
329
+
The key insight is [from_query query] - this creates a reference to the
330
+
[ids] array from the query response. The server processes both calls in
331
+
sequence, substituting the reference with actual IDs.
332
+
333
+
{2 Creation and Submission}
334
+
335
+
Create a draft and send it in one request:
336
+
337
+
{[
338
+
let* set_h, draft_cid = email_set ~account_id
339
+
~create:[("draft1", draft_email_json)]
340
+
()
341
+
in
342
+
let* _ = email_submission_set ~account_id
343
+
~create:[("sub1", submission_json
344
+
~email_id:(created_id_of_string "draft1") (* Reference creation! *)
345
+
~identity_id)]
346
+
()
347
+
in
348
+
return set_h
349
+
][
350
+
{err@mdx-error[
351
+
Line 1, characters 1-5:
352
+
Error: Unbound value ( let* )
353
+
]err}]}
354
+
355
+
{2 The RFC 8620 Example}
356
+
357
+
The RFC provides a complex example: fetch from/date/subject for all
358
+
emails in the first 10 threads in the inbox:
359
+
360
+
{[
361
+
let* q = email_query ~account_id
362
+
~filter:(Condition { in_mailbox = Some inbox_id; (* ... *) })
363
+
~sort:[comparator ~is_ascending:false "receivedAt"]
364
+
~collapse_threads:true ~limit:10L ()
365
+
in
366
+
let* e1 = email_get ~account_id
367
+
~ids:(from_query q)
368
+
~properties:["threadId"]
369
+
()
370
+
in
371
+
let* threads = thread_get ~account_id
372
+
~ids:(from_get_field e1 "threadId") (* Get threadIds from emails *)
373
+
()
374
+
in
375
+
let* e2 = email_get ~account_id
376
+
~ids:(from_get_field threads "emailIds") (* Get all emailIds in threads *)
377
+
~properties:["from"; "receivedAt"; "subject"]
378
+
()
379
+
in
380
+
return e2
381
+
][
382
+
{err@mdx-error[
383
+
Line 1, characters 1-5:
384
+
Error: Unbound value ( let* )
385
+
]err}]}
386
+
387
+
This entire flow executes in a {e single HTTP request}!
388
+
389
+
{1 Error Handling}
390
+
391
+
JMAP has a structured error system with three levels:
392
+
393
+
{2 Request-Level Errors}
394
+
395
+
These are returned with HTTP error status codes and RFC 7807 Problem
396
+
Details. From {{:https://www.rfc-editor.org/rfc/rfc8620#section-3.6.1}RFC
397
+
8620 Section 3.6.1}:
398
+
399
+
{@ocaml[
400
+
# Error.to_string (`Request {
401
+
Error.type_ = "urn:ietf:params:jmap:error:unknownCapability";
402
+
status = Some 400;
403
+
title = Some "Unknown Capability";
404
+
detail = Some "The server does not support 'urn:example:unsupported'";
405
+
limit = None;
406
+
});;
407
+
- : string =
408
+
"Request error: urn:ietf:params:jmap:error:unknownCapability (status 400): The server does not support 'urn:example:unsupported'"
409
+
]}
410
+
411
+
{2 Method-Level Errors}
412
+
413
+
Individual method calls can fail while others succeed:
414
+
415
+
{@ocaml[
416
+
# Error.to_string (`Method {
417
+
Error.type_ = "invalidArguments";
418
+
description = Some "The 'filter' argument is malformed";
419
+
});;
420
+
- : string =
421
+
"Method error: invalidArguments: The 'filter' argument is malformed"
422
+
]}
423
+
424
+
{2 SetError}
425
+
426
+
Object-level errors in /set responses:
427
+
428
+
{@ocaml[
429
+
# Error.to_string (`Set ("draft1", {
430
+
Error.type_ = "invalidProperties";
431
+
description = Some "Unknown property: foobar";
432
+
properties = Some ["foobar"];
433
+
}));;
434
+
- : string =
435
+
"Set error for draft1: invalidProperties: Unknown property: foobar"
436
+
]}
437
+
438
+
{1 Using with FastMail}
439
+
440
+
FastMail is a popular JMAP provider. Here's how to connect:
441
+
442
+
{[
443
+
(* Get a token from https://app.fastmail.com/settings/tokens *)
444
+
let token = "your-api-token"
445
+
446
+
(* The session URL for FastMail *)
447
+
let session_url = "https://api.fastmail.com/jmap/session"
448
+
449
+
(* For browser applications using jmap-brr: *)
450
+
let main () =
451
+
let open Fut.Syntax in
452
+
let* conn = Jmap_brr.get_session
453
+
~url:(Jstr.v session_url)
454
+
~token:(Jstr.v token)
455
+
in
456
+
match conn with
457
+
| Error e -> Brr.Console.(error [str "Error:"; e]); Fut.return ()
458
+
| Ok conn ->
459
+
let session = Jmap_brr.session conn in
460
+
Brr.Console.(log [str "Connected as:";
461
+
str (Jmap.Session.username session)]);
462
+
Fut.return ()
463
+
][
464
+
{err@mdx-error[
465
+
Line 9, characters 14-17:
466
+
Error: Unbound module Fut
467
+
Hint: Did you mean Fun?
468
+
]err}]}
469
+
470
+
{1 Summary}
471
+
472
+
JMAP (RFC 8620/8621) provides a modern, efficient protocol for email:
473
+
474
+
{ol
475
+
{- {b Sessions}: Discover capabilities and account information via GET request}
476
+
{- {b Batching}: Combine multiple method calls in one request}
477
+
{- {b References}: Use results from one method as input to another}
478
+
{- {b Type Safety}: The [jmap] library uses polymorphic variants for keywords and roles}
479
+
{- {b JSON Mapping}: OCaml types map cleanly to JMAP JSON structure}
480
+
{- {b Browser Support}: The [jmap-brr] package enables browser-based clients}}
481
+
482
+
The [jmap] library provides:
483
+
{ul
484
+
{- {!Jmap} - High-level interface with abstract types}
485
+
{- {!Jmap.Proto} - Low-level protocol types matching the RFCs}
486
+
{- {!Jmap.Chain} - Monadic interface for request chaining}
487
+
{- [Jmap_brr] - Browser support via Brr/js_of_ocaml (separate package)}}
488
+
489
+
{2 Key RFC References}
490
+
491
+
{ul
492
+
{- {{:https://www.rfc-editor.org/rfc/rfc8620}RFC 8620}: JMAP Core}
493
+
{- {{:https://www.rfc-editor.org/rfc/rfc8621}RFC 8621}: JMAP for Mail}
494
+
{- {{:https://www.rfc-editor.org/rfc/rfc7807}RFC 7807}: Problem Details for HTTP APIs}}
+14
-18
dune-project
+14
-18
dune-project
···
1
-
(lang dune 3.0)
1
+
(lang dune 3.20)
2
+
3
+
(using mdx 0.4)
2
4
3
5
(name jmap)
4
6
5
7
(generate_opam_files true)
6
8
7
-
(source
8
-
(github avsm/ocaml-jmap))
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
-
(license ISC)
15
+
(homepage "https://tangled.org/@anil.recoil.org/ocaml-jmap")
15
16
16
-
(documentation https://avsm.github.io/ocaml-jmap)
17
+
(bug_reports "https://tangled.org/@anil.recoil.org/ocaml-jmap/issues")
18
+
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
-
"A complete implementation of the JSON Meta Application Protocol (JMAP) as specified in RFC 8620 (core) and RFC 8621 (mail).")
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
-
(ptime (>= 1.0.0))))
28
-
29
-
(package
30
-
(name jmap-eio)
31
-
(synopsis "JMAP client for Eio")
32
-
(description "High-level JMAP client using Eio for async I/O and the Requests HTTP library.")
33
-
(depends
34
-
(ocaml (>= 5.4.0))
35
-
(jmap (= :version))
36
-
(jsont (>= 0.2.0))
37
-
eio
38
-
requests))
30
+
(ptime (>= 1.0.0))
31
+
(eio :with-test)
32
+
(requests :with-test)
33
+
(brr :with-test))
34
+
(depopts eio requests brr))
+214
eio/cli.ml
+214
eio/cli.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP CLI configuration and cmdliner terms *)
7
+
8
+
open Cmdliner
9
+
10
+
(** {1 Configuration Types} *)
11
+
12
+
type source = Default | Env of string | Cmdline
13
+
14
+
type config = {
15
+
session_url : string;
16
+
session_url_source : source;
17
+
api_key : string;
18
+
api_key_source : source;
19
+
account_id : string option;
20
+
account_id_source : source;
21
+
debug : bool;
22
+
}
23
+
24
+
(** {1 Pretty Printing} *)
25
+
26
+
let pp_source ppf = function
27
+
| Default -> Fmt.(styled `Faint string) ppf "default"
28
+
| Env var -> Fmt.pf ppf "%a" Fmt.(styled `Yellow string) ("env(" ^ var ^ ")")
29
+
| Cmdline -> Fmt.(styled `Blue string) ppf "cmdline"
30
+
31
+
let pp_config ppf cfg =
32
+
let pp_field name value source =
33
+
Fmt.pf ppf "@,%a %a %a"
34
+
Fmt.(styled `Cyan string) (name ^ ":")
35
+
Fmt.(styled `Green string) value
36
+
Fmt.(styled `Faint (brackets pp_source)) source
37
+
in
38
+
let pp_opt_field name value_opt source =
39
+
match value_opt with
40
+
| None -> ()
41
+
| Some value -> pp_field name value source
42
+
in
43
+
Fmt.pf ppf "@[<v>%a" Fmt.(styled `Bold string) "JMAP config:";
44
+
pp_field "session_url" cfg.session_url cfg.session_url_source;
45
+
pp_field "api_key" (String.make (min 8 (String.length cfg.api_key)) '*' ^ "...") cfg.api_key_source;
46
+
pp_opt_field "account_id" cfg.account_id cfg.account_id_source;
47
+
Fmt.pf ppf "@]"
48
+
49
+
(** {1 Cmdliner Terms} *)
50
+
51
+
let env_var_name suffix = "JMAP_" ^ suffix
52
+
53
+
let resolve_with_env ~cmdline ~env_var ~default =
54
+
match cmdline with
55
+
| Some v -> (v, Cmdline)
56
+
| None ->
57
+
match Sys.getenv_opt env_var with
58
+
| Some v when v <> "" -> (v, Env env_var)
59
+
| _ -> (default, Default)
60
+
61
+
let resolve_opt_with_env ~cmdline ~env_var =
62
+
match cmdline with
63
+
| Some v -> (Some v, Cmdline)
64
+
| None ->
65
+
match Sys.getenv_opt env_var with
66
+
| Some v when v <> "" -> (Some v, Env env_var)
67
+
| _ -> (None, Default)
68
+
69
+
(** Session URL term *)
70
+
let session_url_term =
71
+
let doc =
72
+
Printf.sprintf
73
+
"JMAP session URL. Can also be set with %s environment variable."
74
+
(env_var_name "SESSION_URL")
75
+
in
76
+
Arg.(value & opt (some string) None & info ["url"; "u"] ~docv:"URL" ~doc)
77
+
78
+
(** API key term *)
79
+
let api_key_term =
80
+
let doc =
81
+
Printf.sprintf
82
+
"JMAP API key or Bearer token. Can also be set with %s environment variable."
83
+
(env_var_name "API_KEY")
84
+
in
85
+
Arg.(value & opt (some string) None & info ["api-key"; "k"] ~docv:"KEY" ~doc)
86
+
87
+
(** API key file term *)
88
+
let api_key_file_term =
89
+
let doc =
90
+
Printf.sprintf
91
+
"File containing JMAP API key. Can also be set with %s environment variable."
92
+
(env_var_name "API_KEY_FILE")
93
+
in
94
+
Arg.(value & opt (some string) None & info ["api-key-file"; "K"] ~docv:"FILE" ~doc)
95
+
96
+
(** Account ID term *)
97
+
let account_id_term =
98
+
let doc =
99
+
Printf.sprintf
100
+
"Account ID to use (defaults to primary mail account). Can also be set with %s."
101
+
(env_var_name "ACCOUNT_ID")
102
+
in
103
+
Arg.(value & opt (some string) None & info ["account"; "a"] ~docv:"ID" ~doc)
104
+
105
+
(** Debug flag term *)
106
+
let debug_term =
107
+
let doc = "Enable debug output" in
108
+
Arg.(value & flag & info ["debug"; "d"] ~doc)
109
+
110
+
(** Read API key from file *)
111
+
let read_api_key_file path =
112
+
try
113
+
let ic = open_in path in
114
+
let key = input_line ic in
115
+
close_in ic;
116
+
String.trim key
117
+
with
118
+
| Sys_error msg -> failwith (Printf.sprintf "Cannot read API key file: %s" msg)
119
+
| End_of_file -> failwith "API key file is empty"
120
+
121
+
(** Combined configuration term *)
122
+
let config_term =
123
+
let make session_url_opt api_key_opt api_key_file_opt account_id_opt debug =
124
+
(* Resolve session URL *)
125
+
let session_url, session_url_source =
126
+
resolve_with_env
127
+
~cmdline:session_url_opt
128
+
~env_var:(env_var_name "SESSION_URL")
129
+
~default:""
130
+
in
131
+
if session_url = "" then
132
+
failwith "Session URL is required. Set via --url or JMAP_SESSION_URL";
133
+
134
+
(* Resolve API key - check key file first, then direct key *)
135
+
let api_key, api_key_source =
136
+
match api_key_file_opt with
137
+
| Some path -> (read_api_key_file path, Cmdline)
138
+
| None ->
139
+
match Sys.getenv_opt (env_var_name "API_KEY_FILE") with
140
+
| Some path when path <> "" -> (read_api_key_file path, Env (env_var_name "API_KEY_FILE"))
141
+
| _ ->
142
+
resolve_with_env
143
+
~cmdline:api_key_opt
144
+
~env_var:(env_var_name "API_KEY")
145
+
~default:""
146
+
in
147
+
if api_key = "" then
148
+
failwith "API key is required. Set via --api-key, --api-key-file, JMAP_API_KEY, or JMAP_API_KEY_FILE";
149
+
150
+
(* Resolve account ID (optional) *)
151
+
let account_id, account_id_source =
152
+
resolve_opt_with_env
153
+
~cmdline:account_id_opt
154
+
~env_var:(env_var_name "ACCOUNT_ID")
155
+
in
156
+
157
+
{ session_url; session_url_source;
158
+
api_key; api_key_source;
159
+
account_id; account_id_source;
160
+
debug }
161
+
in
162
+
Term.(const make $ session_url_term $ api_key_term $ api_key_file_term
163
+
$ account_id_term $ debug_term)
164
+
165
+
(** {1 Environment Documentation} *)
166
+
167
+
let env_docs =
168
+
{|
169
+
Environment Variables:
170
+
JMAP_SESSION_URL JMAP session URL (e.g., https://api.fastmail.com/jmap/session)
171
+
JMAP_API_KEY API key or Bearer token for authentication
172
+
JMAP_API_KEY_FILE Path to file containing API key
173
+
JMAP_ACCOUNT_ID Account ID to use (optional, defaults to primary mail account)
174
+
175
+
Configuration Precedence:
176
+
1. Command-line flags (e.g., --url, --api-key)
177
+
2. Environment variables (e.g., JMAP_SESSION_URL)
178
+
179
+
Example:
180
+
export JMAP_SESSION_URL="https://api.fastmail.com/jmap/session"
181
+
export JMAP_API_KEY_FILE="$HOME/.jmap-api-key"
182
+
jmap emails --limit 10
183
+
|}
184
+
185
+
(** {1 Client Helpers} *)
186
+
187
+
let create_client ~sw env cfg =
188
+
let requests = Requests.create ~sw env in
189
+
let auth = Requests.Auth.bearer ~token:cfg.api_key in
190
+
match Client.create_from_url ~auth requests cfg.session_url with
191
+
| Error e ->
192
+
Fmt.epr "@[<v>%a Failed to connect: %s@]@."
193
+
Fmt.(styled `Red string) "Error:"
194
+
(Client.error_to_string e);
195
+
exit 1
196
+
| Ok client -> client
197
+
198
+
let get_account_id cfg client =
199
+
match cfg.account_id with
200
+
| Some id -> Jmap.Proto.Id.of_string_exn id
201
+
| None ->
202
+
let session = Client.session client in
203
+
match Jmap.Proto.Session.primary_account_for Jmap.Proto.Capability.mail session with
204
+
| Some id -> id
205
+
| None ->
206
+
Fmt.epr "@[<v>%a No primary mail account found. Specify --account.@]@."
207
+
Fmt.(styled `Red string) "Error:";
208
+
exit 1
209
+
210
+
let debug cfg fmt =
211
+
if cfg.debug then
212
+
Fmt.kpf (fun ppf -> Fmt.pf ppf "@.") Fmt.stderr ("@[<h>[DEBUG] " ^^ fmt ^^ "@]")
213
+
else
214
+
Format.ikfprintf ignore Format.err_formatter fmt
+94
eio/cli.mli
+94
eio/cli.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP CLI configuration and cmdliner terms
7
+
8
+
This module provides reusable cmdliner terms for building JMAP CLI tools.
9
+
It handles configuration from command-line arguments and environment
10
+
variables with proper precedence.
11
+
12
+
{2 Environment Variables}
13
+
14
+
- [JMAP_SESSION_URL] - JMAP session URL
15
+
- [JMAP_API_KEY] - API key or Bearer token
16
+
- [JMAP_API_KEY_FILE] - Path to file containing API key
17
+
- [JMAP_ACCOUNT_ID] - Account ID (optional)
18
+
19
+
{2 Configuration Precedence}
20
+
21
+
1. Command-line flags (e.g., [--url], [--api-key])
22
+
2. Environment variables (e.g., [JMAP_SESSION_URL])
23
+
3. Default values (where applicable)
24
+
*)
25
+
26
+
(** {1 Configuration Types} *)
27
+
28
+
(** Source of a configuration value. *)
29
+
type source =
30
+
| Default (** Value from default *)
31
+
| Env of string (** Value from environment variable *)
32
+
| Cmdline (** Value from command line *)
33
+
34
+
(** CLI configuration with source tracking. *)
35
+
type config = {
36
+
session_url : string;
37
+
session_url_source : source;
38
+
api_key : string;
39
+
api_key_source : source;
40
+
account_id : string option;
41
+
account_id_source : source;
42
+
debug : bool;
43
+
}
44
+
45
+
(** {1 Pretty Printing} *)
46
+
47
+
val pp_source : source Fmt.t
48
+
(** Pretty-print a configuration source. *)
49
+
50
+
val pp_config : config Fmt.t
51
+
(** Pretty-print the configuration (with masked API key). *)
52
+
53
+
(** {1 Cmdliner Terms} *)
54
+
55
+
val config_term : config Cmdliner.Term.t
56
+
(** Combined cmdliner term for JMAP configuration.
57
+
Includes session URL, API key (direct or from file), account ID, and debug flag. *)
58
+
59
+
val session_url_term : string option Cmdliner.Term.t
60
+
(** Cmdliner term for session URL. *)
61
+
62
+
val api_key_term : string option Cmdliner.Term.t
63
+
(** Cmdliner term for API key. *)
64
+
65
+
val api_key_file_term : string option Cmdliner.Term.t
66
+
(** Cmdliner term for API key file path. *)
67
+
68
+
val account_id_term : string option Cmdliner.Term.t
69
+
(** Cmdliner term for account ID. *)
70
+
71
+
val debug_term : bool Cmdliner.Term.t
72
+
(** Cmdliner term for debug flag. *)
73
+
74
+
(** {1 Environment Documentation} *)
75
+
76
+
val env_docs : string
77
+
(** Documentation string describing environment variables for use in man pages. *)
78
+
79
+
(** {1 Client Helpers} *)
80
+
81
+
val create_client :
82
+
sw:Eio.Switch.t ->
83
+
Eio_unix.Stdenv.base ->
84
+
config ->
85
+
Client.t
86
+
(** [create_client ~sw env cfg] creates a JMAP client from the configuration.
87
+
Exits with error message on connection failure. *)
88
+
89
+
val get_account_id : config -> Client.t -> Jmap.Proto.Id.t
90
+
(** [get_account_id cfg client] returns the account ID from config, or the
91
+
primary mail account if not specified. Exits with error if no account found. *)
92
+
93
+
val debug : config -> ('a, Format.formatter, unit) format -> 'a
94
+
(** [debug cfg fmt ...] prints a debug message to stderr if debug mode is enabled. *)
+20
-20
eio/client.ml
+20
-20
eio/client.ml
···
5
5
6
6
type error =
7
7
| Http_error of int * string
8
-
| Jmap_error of Jmap_proto.Error.Request_error.t
8
+
| Jmap_error of Jmap.Proto.Error.Request_error.t
9
9
| Json_error of Jsont.Error.t
10
10
| Session_error of string
11
11
| Connection_error of string
···
15
15
Format.fprintf fmt "HTTP error %d: %s" code msg
16
16
| Jmap_error err ->
17
17
Format.fprintf fmt "JMAP error: %s"
18
-
(Jmap_proto.Error.Request_error.urn_to_string err.type_)
18
+
(Jmap.Proto.Error.Request_error.urn_to_string err.type_)
19
19
| Json_error err ->
20
20
Format.fprintf fmt "JSON error: %s" (Jsont.Error.to_string err)
21
21
| Session_error msg ->
···
29
29
exception Jmap_client_error of error
30
30
31
31
type t = {
32
-
mutable session : Jmap_proto.Session.t;
32
+
mutable session : Jmap.Proto.Session.t;
33
33
requests : Requests.t;
34
34
auth : Requests.Auth.t option;
35
35
session_url : string;
36
36
}
37
37
38
38
let session t = t.session
39
-
let api_url t = Jmap_proto.Session.api_url t.session
40
-
let upload_url t = Jmap_proto.Session.upload_url t.session
41
-
let download_url t = Jmap_proto.Session.download_url t.session
39
+
let api_url t = Jmap.Proto.Session.api_url t.session
40
+
let upload_url t = Jmap.Proto.Session.upload_url t.session
41
+
let download_url t = Jmap.Proto.Session.download_url t.session
42
42
43
43
let create ?auth ~session requests =
44
-
let session_url = Jmap_proto.Session.api_url session in
44
+
let session_url = Jmap.Proto.Session.api_url session in
45
45
{ session; requests; auth; session_url }
46
46
47
47
let fetch_session ?auth requests url =
···
119
119
120
120
let expand_upload_url t ~account_id =
121
121
let template = upload_url t in
122
-
let account_id_str = Jmap_proto.Id.to_string account_id in
122
+
let account_id_str = Jmap.Proto.Id.to_string account_id in
123
123
(* Simple template expansion for {accountId} *)
124
124
let re = Str.regexp "{accountId}" in
125
125
Str.global_replace re account_id_str template
···
154
154
155
155
let expand_download_url t ~account_id ~blob_id ?name ?accept () =
156
156
let template = download_url t in
157
-
let account_id_str = Jmap_proto.Id.to_string account_id in
158
-
let blob_id_str = Jmap_proto.Id.to_string blob_id in
157
+
let account_id_str = Jmap.Proto.Id.to_string account_id in
158
+
let blob_id_str = Jmap.Proto.Id.to_string blob_id in
159
159
let name_str = Option.value name ~default:"download" in
160
160
let type_str = Option.value accept ~default:"application/octet-stream" in
161
161
(* Simple template expansion *)
···
190
190
191
191
(* Convenience builders *)
192
192
module Build = struct
193
-
open Jmap_proto
193
+
open Jmap.Proto
194
194
195
195
let json_of_id id =
196
196
Jsont.String (Id.to_string id, Jsont.Meta.none)
···
264
264
let args = match filter with
265
265
| None -> args
266
266
| Some f ->
267
-
("filter", encode_to_json Jmap_mail.Mail_filter.mailbox_filter_jsont f) :: args
267
+
("filter", encode_to_json Jmap.Proto.Mail_filter.mailbox_filter_jsont f) :: args
268
268
in
269
269
let args = match sort with
270
270
| None -> args
···
336
336
let args = match filter with
337
337
| None -> args
338
338
| Some f ->
339
-
("filter", encode_to_json Jmap_mail.Mail_filter.email_filter_jsont f) :: args
339
+
("filter", encode_to_json Jmap.Proto.Mail_filter.email_filter_jsont f) :: args
340
340
in
341
341
let args = match sort with
342
342
| None -> args
···
413
413
let args = match filter with
414
414
| None -> args
415
415
| Some f ->
416
-
("filter", encode_to_json Jmap_mail.Mail_filter.submission_filter_jsont f) :: args
416
+
("filter", encode_to_json Jmap.Proto.Mail_filter.submission_filter_jsont f) :: args
417
417
in
418
418
let args = match sort with
419
419
| None -> args
···
433
433
let vacation_response_get ~call_id ~account_id () =
434
434
let args = [
435
435
("accountId", json_of_id account_id);
436
-
("ids", json_of_id_list [Jmap_mail.Vacation.singleton_id]);
436
+
("ids", json_of_id_list [Jmap.Proto.Vacation.singleton_id]);
437
437
] in
438
438
make_invocation ~name:"VacationResponse/get" ~call_id args
439
439
···
447
447
448
448
(* Response parsing helpers *)
449
449
module Parse = struct
450
-
open Jmap_proto
450
+
open Jmap.Proto
451
451
452
452
let decode_from_json jsont json =
453
453
Jsont.Json.decode' jsont json
···
484
484
(* Mail-specific parsers *)
485
485
486
486
let mailbox_get_response =
487
-
get_response Jmap_mail.Mailbox.jsont
487
+
get_response Jmap.Proto.Mailbox.jsont
488
488
489
489
let email_get_response =
490
-
get_response Jmap_mail.Email.jsont
490
+
get_response Jmap.Proto.Email.jsont
491
491
492
492
let thread_get_response =
493
-
get_response Jmap_mail.Thread.jsont
493
+
get_response Jmap.Proto.Thread.jsont
494
494
495
495
let identity_get_response =
496
-
get_response Jmap_mail.Identity.jsont
496
+
get_response Jmap.Proto.Identity.jsont
497
497
498
498
(* Convenience functions *)
499
499
+78
-78
eio/client.mli
+78
-78
eio/client.mli
···
16
16
type error =
17
17
| Http_error of int * string
18
18
(** HTTP error with status code and message. *)
19
-
| Jmap_error of Jmap_proto.Error.Request_error.t
19
+
| Jmap_error of Jmap.Proto.Error.Request_error.t
20
20
(** JMAP protocol error at request level. *)
21
21
| Json_error of Jsont.Error.t
22
22
(** JSON encoding/decoding error. *)
···
39
39
40
40
val create :
41
41
?auth:Requests.Auth.t ->
42
-
session:Jmap_proto.Session.t ->
42
+
session:Jmap.Proto.Session.t ->
43
43
Requests.t ->
44
44
t
45
45
(** [create ?auth ~session requests] creates a JMAP client from an existing
···
75
75
76
76
(** {1 Session Access} *)
77
77
78
-
val session : t -> Jmap_proto.Session.t
78
+
val session : t -> Jmap.Proto.Session.t
79
79
(** [session client] returns the current JMAP session. *)
80
80
81
81
val refresh_session : t -> (unit, error) result
···
98
98
99
99
val request :
100
100
t ->
101
-
Jmap_proto.Request.t ->
102
-
(Jmap_proto.Response.t, error) result
101
+
Jmap.Proto.Request.t ->
102
+
(Jmap.Proto.Response.t, error) result
103
103
(** [request client req] executes a JMAP request and returns the response. *)
104
104
105
105
val request_exn :
106
106
t ->
107
-
Jmap_proto.Request.t ->
108
-
Jmap_proto.Response.t
107
+
Jmap.Proto.Request.t ->
108
+
Jmap.Proto.Response.t
109
109
(** [request_exn client req] is like {!request} but raises on error. *)
110
110
111
111
(** {1 Blob Operations} *)
112
112
113
113
val upload :
114
114
t ->
115
-
account_id:Jmap_proto.Id.t ->
115
+
account_id:Jmap.Proto.Id.t ->
116
116
content_type:string ->
117
117
data:string ->
118
-
(Jmap_proto.Blob.upload_response, error) result
118
+
(Jmap.Proto.Blob.upload_response, error) result
119
119
(** [upload client ~account_id ~content_type ~data] uploads a blob.
120
120
121
121
@param account_id The account to upload to.
···
124
124
125
125
val upload_exn :
126
126
t ->
127
-
account_id:Jmap_proto.Id.t ->
127
+
account_id:Jmap.Proto.Id.t ->
128
128
content_type:string ->
129
129
data:string ->
130
-
Jmap_proto.Blob.upload_response
130
+
Jmap.Proto.Blob.upload_response
131
131
(** [upload_exn client ~account_id ~content_type ~data] is like {!upload}
132
132
but raises on error. *)
133
133
134
134
val download :
135
135
t ->
136
-
account_id:Jmap_proto.Id.t ->
137
-
blob_id:Jmap_proto.Id.t ->
136
+
account_id:Jmap.Proto.Id.t ->
137
+
blob_id:Jmap.Proto.Id.t ->
138
138
?name:string ->
139
139
?accept:string ->
140
140
unit ->
···
148
148
149
149
val download_exn :
150
150
t ->
151
-
account_id:Jmap_proto.Id.t ->
152
-
blob_id:Jmap_proto.Id.t ->
151
+
account_id:Jmap.Proto.Id.t ->
152
+
blob_id:Jmap.Proto.Id.t ->
153
153
?name:string ->
154
154
?accept:string ->
155
155
unit ->
···
166
166
val echo :
167
167
call_id:string ->
168
168
Jsont.json ->
169
-
Jmap_proto.Invocation.t
169
+
Jmap.Proto.Invocation.t
170
170
(** [echo ~call_id data] builds a Core/echo invocation. *)
171
171
172
172
(** {2 Mailbox Methods} *)
173
173
174
174
val mailbox_get :
175
175
call_id:string ->
176
-
account_id:Jmap_proto.Id.t ->
177
-
?ids:Jmap_proto.Id.t list ->
176
+
account_id:Jmap.Proto.Id.t ->
177
+
?ids:Jmap.Proto.Id.t list ->
178
178
?properties:string list ->
179
179
unit ->
180
-
Jmap_proto.Invocation.t
180
+
Jmap.Proto.Invocation.t
181
181
(** [mailbox_get ~call_id ~account_id ?ids ?properties ()] builds a
182
182
Mailbox/get invocation. *)
183
183
184
184
val mailbox_changes :
185
185
call_id:string ->
186
-
account_id:Jmap_proto.Id.t ->
186
+
account_id:Jmap.Proto.Id.t ->
187
187
since_state:string ->
188
188
?max_changes:int64 ->
189
189
unit ->
190
-
Jmap_proto.Invocation.t
190
+
Jmap.Proto.Invocation.t
191
191
(** [mailbox_changes ~call_id ~account_id ~since_state ?max_changes ()]
192
192
builds a Mailbox/changes invocation. *)
193
193
194
194
val mailbox_query :
195
195
call_id:string ->
196
-
account_id:Jmap_proto.Id.t ->
197
-
?filter:Jmap_mail.Mail_filter.mailbox_filter ->
198
-
?sort:Jmap_proto.Filter.comparator list ->
196
+
account_id:Jmap.Proto.Id.t ->
197
+
?filter:Jmap.Proto.Mail_filter.mailbox_filter ->
198
+
?sort:Jmap.Proto.Filter.comparator list ->
199
199
?position:int64 ->
200
200
?limit:int64 ->
201
201
unit ->
202
-
Jmap_proto.Invocation.t
202
+
Jmap.Proto.Invocation.t
203
203
(** [mailbox_query ~call_id ~account_id ?filter ?sort ?position ?limit ()]
204
204
builds a Mailbox/query invocation. *)
205
205
···
207
207
208
208
val email_get :
209
209
call_id:string ->
210
-
account_id:Jmap_proto.Id.t ->
211
-
?ids:Jmap_proto.Id.t list ->
210
+
account_id:Jmap.Proto.Id.t ->
211
+
?ids:Jmap.Proto.Id.t list ->
212
212
?properties:string list ->
213
213
?body_properties:string list ->
214
214
?fetch_text_body_values:bool ->
···
216
216
?fetch_all_body_values:bool ->
217
217
?max_body_value_bytes:int64 ->
218
218
unit ->
219
-
Jmap_proto.Invocation.t
219
+
Jmap.Proto.Invocation.t
220
220
(** [email_get ~call_id ~account_id ?ids ?properties ...] builds an
221
221
Email/get invocation. *)
222
222
223
223
val email_changes :
224
224
call_id:string ->
225
-
account_id:Jmap_proto.Id.t ->
225
+
account_id:Jmap.Proto.Id.t ->
226
226
since_state:string ->
227
227
?max_changes:int64 ->
228
228
unit ->
229
-
Jmap_proto.Invocation.t
229
+
Jmap.Proto.Invocation.t
230
230
(** [email_changes ~call_id ~account_id ~since_state ?max_changes ()]
231
231
builds an Email/changes invocation. *)
232
232
233
233
val email_query :
234
234
call_id:string ->
235
-
account_id:Jmap_proto.Id.t ->
236
-
?filter:Jmap_mail.Mail_filter.email_filter ->
237
-
?sort:Jmap_proto.Filter.comparator list ->
235
+
account_id:Jmap.Proto.Id.t ->
236
+
?filter:Jmap.Proto.Mail_filter.email_filter ->
237
+
?sort:Jmap.Proto.Filter.comparator list ->
238
238
?position:int64 ->
239
239
?limit:int64 ->
240
240
?collapse_threads:bool ->
241
241
unit ->
242
-
Jmap_proto.Invocation.t
242
+
Jmap.Proto.Invocation.t
243
243
(** [email_query ~call_id ~account_id ?filter ?sort ?position ?limit
244
244
?collapse_threads ()] builds an Email/query invocation. *)
245
245
···
247
247
248
248
val thread_get :
249
249
call_id:string ->
250
-
account_id:Jmap_proto.Id.t ->
251
-
?ids:Jmap_proto.Id.t list ->
250
+
account_id:Jmap.Proto.Id.t ->
251
+
?ids:Jmap.Proto.Id.t list ->
252
252
unit ->
253
-
Jmap_proto.Invocation.t
253
+
Jmap.Proto.Invocation.t
254
254
(** [thread_get ~call_id ~account_id ?ids ()] builds a Thread/get invocation. *)
255
255
256
256
val thread_changes :
257
257
call_id:string ->
258
-
account_id:Jmap_proto.Id.t ->
258
+
account_id:Jmap.Proto.Id.t ->
259
259
since_state:string ->
260
260
?max_changes:int64 ->
261
261
unit ->
262
-
Jmap_proto.Invocation.t
262
+
Jmap.Proto.Invocation.t
263
263
(** [thread_changes ~call_id ~account_id ~since_state ?max_changes ()]
264
264
builds a Thread/changes invocation. *)
265
265
···
267
267
268
268
val identity_get :
269
269
call_id:string ->
270
-
account_id:Jmap_proto.Id.t ->
271
-
?ids:Jmap_proto.Id.t list ->
270
+
account_id:Jmap.Proto.Id.t ->
271
+
?ids:Jmap.Proto.Id.t list ->
272
272
?properties:string list ->
273
273
unit ->
274
-
Jmap_proto.Invocation.t
274
+
Jmap.Proto.Invocation.t
275
275
(** [identity_get ~call_id ~account_id ?ids ?properties ()] builds an
276
276
Identity/get invocation. *)
277
277
···
279
279
280
280
val email_submission_get :
281
281
call_id:string ->
282
-
account_id:Jmap_proto.Id.t ->
283
-
?ids:Jmap_proto.Id.t list ->
282
+
account_id:Jmap.Proto.Id.t ->
283
+
?ids:Jmap.Proto.Id.t list ->
284
284
?properties:string list ->
285
285
unit ->
286
-
Jmap_proto.Invocation.t
286
+
Jmap.Proto.Invocation.t
287
287
(** [email_submission_get ~call_id ~account_id ?ids ?properties ()]
288
288
builds an EmailSubmission/get invocation. *)
289
289
290
290
val email_submission_query :
291
291
call_id:string ->
292
-
account_id:Jmap_proto.Id.t ->
293
-
?filter:Jmap_mail.Mail_filter.submission_filter ->
294
-
?sort:Jmap_proto.Filter.comparator list ->
292
+
account_id:Jmap.Proto.Id.t ->
293
+
?filter:Jmap.Proto.Mail_filter.submission_filter ->
294
+
?sort:Jmap.Proto.Filter.comparator list ->
295
295
?position:int64 ->
296
296
?limit:int64 ->
297
297
unit ->
298
-
Jmap_proto.Invocation.t
298
+
Jmap.Proto.Invocation.t
299
299
(** [email_submission_query ~call_id ~account_id ?filter ?sort ?position
300
300
?limit ()] builds an EmailSubmission/query invocation. *)
301
301
···
303
303
304
304
val vacation_response_get :
305
305
call_id:string ->
306
-
account_id:Jmap_proto.Id.t ->
306
+
account_id:Jmap.Proto.Id.t ->
307
307
unit ->
308
-
Jmap_proto.Invocation.t
308
+
Jmap.Proto.Invocation.t
309
309
(** [vacation_response_get ~call_id ~account_id ()] builds a
310
310
VacationResponse/get invocation. The singleton ID is automatically used. *)
311
311
312
312
(** {2 Request Building} *)
313
313
314
314
val make_request :
315
-
?created_ids:(Jmap_proto.Id.t * Jmap_proto.Id.t) list ->
315
+
?created_ids:(Jmap.Proto.Id.t * Jmap.Proto.Id.t) list ->
316
316
capabilities:string list ->
317
-
Jmap_proto.Invocation.t list ->
318
-
Jmap_proto.Request.t
317
+
Jmap.Proto.Invocation.t list ->
318
+
Jmap.Proto.Request.t
319
319
(** [make_request ?created_ids ~capabilities invocations] builds a JMAP request.
320
320
321
321
@param created_ids Optional client-created ID mappings.
···
330
330
module Parse : sig
331
331
val find_invocation :
332
332
call_id:string ->
333
-
Jmap_proto.Response.t ->
334
-
Jmap_proto.Invocation.t option
333
+
Jmap.Proto.Response.t ->
334
+
Jmap.Proto.Invocation.t option
335
335
(** [find_invocation ~call_id response] finds an invocation by call ID. *)
336
336
337
337
val get_invocation_exn :
338
338
call_id:string ->
339
-
Jmap_proto.Response.t ->
340
-
Jmap_proto.Invocation.t
339
+
Jmap.Proto.Response.t ->
340
+
Jmap.Proto.Invocation.t
341
341
(** [get_invocation_exn ~call_id response] finds an invocation by call ID.
342
342
@raise Failure if not found. *)
343
343
344
344
val parse_invocation :
345
345
'a Jsont.t ->
346
-
Jmap_proto.Invocation.t ->
346
+
Jmap.Proto.Invocation.t ->
347
347
('a, Jsont.Error.t) result
348
348
(** [parse_invocation jsont inv] decodes the invocation's arguments. *)
349
349
350
350
val parse_response :
351
351
call_id:string ->
352
352
'a Jsont.t ->
353
-
Jmap_proto.Response.t ->
353
+
Jmap.Proto.Response.t ->
354
354
('a, Jsont.Error.t) result
355
355
(** [parse_response ~call_id jsont response] finds and parses an invocation. *)
356
356
357
357
(** {2 Typed Response Codecs} *)
358
358
359
-
val get_response : 'a Jsont.t -> 'a Jmap_proto.Method.get_response Jsont.t
359
+
val get_response : 'a Jsont.t -> 'a Jmap.Proto.Method.get_response Jsont.t
360
360
(** [get_response obj_jsont] creates a Foo/get response codec. *)
361
361
362
-
val query_response : Jmap_proto.Method.query_response Jsont.t
362
+
val query_response : Jmap.Proto.Method.query_response Jsont.t
363
363
(** Codec for Foo/query responses. *)
364
364
365
-
val changes_response : Jmap_proto.Method.changes_response Jsont.t
365
+
val changes_response : Jmap.Proto.Method.changes_response Jsont.t
366
366
(** Codec for Foo/changes responses. *)
367
367
368
-
val set_response : 'a Jsont.t -> 'a Jmap_proto.Method.set_response Jsont.t
368
+
val set_response : 'a Jsont.t -> 'a Jmap.Proto.Method.set_response Jsont.t
369
369
(** [set_response obj_jsont] creates a Foo/set response codec. *)
370
370
371
371
(** {2 Mail-specific Codecs} *)
372
372
373
-
val mailbox_get_response : Jmap_mail.Mailbox.t Jmap_proto.Method.get_response Jsont.t
374
-
val email_get_response : Jmap_mail.Email.t Jmap_proto.Method.get_response Jsont.t
375
-
val thread_get_response : Jmap_mail.Thread.t Jmap_proto.Method.get_response Jsont.t
376
-
val identity_get_response : Jmap_mail.Identity.t Jmap_proto.Method.get_response Jsont.t
373
+
val mailbox_get_response : Jmap.Proto.Mailbox.t Jmap.Proto.Method.get_response Jsont.t
374
+
val email_get_response : Jmap.Proto.Email.t Jmap.Proto.Method.get_response Jsont.t
375
+
val thread_get_response : Jmap.Proto.Thread.t Jmap.Proto.Method.get_response Jsont.t
376
+
val identity_get_response : Jmap.Proto.Identity.t Jmap.Proto.Method.get_response Jsont.t
377
377
378
378
(** {2 Convenience Parsers} *)
379
379
380
380
val parse_mailbox_get :
381
381
call_id:string ->
382
-
Jmap_proto.Response.t ->
383
-
(Jmap_mail.Mailbox.t Jmap_proto.Method.get_response, Jsont.Error.t) result
382
+
Jmap.Proto.Response.t ->
383
+
(Jmap.Proto.Mailbox.t Jmap.Proto.Method.get_response, Jsont.Error.t) result
384
384
385
385
val parse_email_get :
386
386
call_id:string ->
387
-
Jmap_proto.Response.t ->
388
-
(Jmap_mail.Email.t Jmap_proto.Method.get_response, Jsont.Error.t) result
387
+
Jmap.Proto.Response.t ->
388
+
(Jmap.Proto.Email.t Jmap.Proto.Method.get_response, Jsont.Error.t) result
389
389
390
390
val parse_email_query :
391
391
call_id:string ->
392
-
Jmap_proto.Response.t ->
393
-
(Jmap_proto.Method.query_response, Jsont.Error.t) result
392
+
Jmap.Proto.Response.t ->
393
+
(Jmap.Proto.Method.query_response, Jsont.Error.t) result
394
394
395
395
val parse_thread_get :
396
396
call_id:string ->
397
-
Jmap_proto.Response.t ->
398
-
(Jmap_mail.Thread.t Jmap_proto.Method.get_response, Jsont.Error.t) result
397
+
Jmap.Proto.Response.t ->
398
+
(Jmap.Proto.Thread.t Jmap.Proto.Method.get_response, Jsont.Error.t) result
399
399
400
400
val parse_changes :
401
401
call_id:string ->
402
-
Jmap_proto.Response.t ->
403
-
(Jmap_proto.Method.changes_response, Jsont.Error.t) result
402
+
Jmap.Proto.Response.t ->
403
+
(Jmap.Proto.Method.changes_response, Jsont.Error.t) result
404
404
end
+4
-4
eio/codec.ml
+4
-4
eio/codec.ml
···
10
10
Jsont_bytesrw.decode_string' ?locs jsont json
11
11
12
12
let encode_request ?format request =
13
-
encode ?format Jmap_proto.Request.jsont request
13
+
encode ?format Jmap.Proto.Request.jsont request
14
14
15
15
let encode_request_exn ?format request =
16
16
match encode_request ?format request with
···
18
18
| Error e -> failwith (Jsont.Error.to_string e)
19
19
20
20
let decode_response ?locs json =
21
-
decode ?locs Jmap_proto.Response.jsont json
21
+
decode ?locs Jmap.Proto.Response.jsont json
22
22
23
23
let decode_response_exn ?locs json =
24
24
match decode_response ?locs json with
···
26
26
| Error e -> failwith (Jsont.Error.to_string e)
27
27
28
28
let decode_session ?locs json =
29
-
decode ?locs Jmap_proto.Session.jsont json
29
+
decode ?locs Jmap.Proto.Session.jsont json
30
30
31
31
let decode_session_exn ?locs json =
32
32
match decode_session ?locs json with
···
34
34
| Error e -> failwith (Jsont.Error.to_string e)
35
35
36
36
let decode_upload_response ?locs json =
37
-
decode ?locs Jmap_proto.Blob.upload_response_jsont json
37
+
decode ?locs Jmap.Proto.Blob.upload_response_jsont json
38
38
39
39
let decode_upload_response_exn ?locs json =
40
40
match decode_upload_response ?locs json with
+8
-8
eio/codec.mli
+8
-8
eio/codec.mli
···
11
11
12
12
val encode_request :
13
13
?format:Jsont.format ->
14
-
Jmap_proto.Request.t ->
14
+
Jmap.Proto.Request.t ->
15
15
(string, Jsont.Error.t) result
16
16
(** [encode_request ?format request] encodes a JMAP request to a JSON string.
17
17
···
19
19
20
20
val encode_request_exn :
21
21
?format:Jsont.format ->
22
-
Jmap_proto.Request.t ->
22
+
Jmap.Proto.Request.t ->
23
23
string
24
24
(** [encode_request_exn ?format request] is like {!encode_request} but raises
25
25
on encoding errors. *)
···
29
29
val decode_response :
30
30
?locs:bool ->
31
31
string ->
32
-
(Jmap_proto.Response.t, Jsont.Error.t) result
32
+
(Jmap.Proto.Response.t, Jsont.Error.t) result
33
33
(** [decode_response ?locs json] decodes a JMAP response from a JSON string.
34
34
35
35
@param locs If [true], location information is preserved for error messages.
···
38
38
val decode_response_exn :
39
39
?locs:bool ->
40
40
string ->
41
-
Jmap_proto.Response.t
41
+
Jmap.Proto.Response.t
42
42
(** [decode_response_exn ?locs json] is like {!decode_response} but raises
43
43
on decoding errors. *)
44
44
···
47
47
val decode_session :
48
48
?locs:bool ->
49
49
string ->
50
-
(Jmap_proto.Session.t, Jsont.Error.t) result
50
+
(Jmap.Proto.Session.t, Jsont.Error.t) result
51
51
(** [decode_session ?locs json] decodes a JMAP session from a JSON string.
52
52
53
53
@param locs If [true], location information is preserved for error messages.
···
56
56
val decode_session_exn :
57
57
?locs:bool ->
58
58
string ->
59
-
Jmap_proto.Session.t
59
+
Jmap.Proto.Session.t
60
60
(** [decode_session_exn ?locs json] is like {!decode_session} but raises
61
61
on decoding errors. *)
62
62
···
65
65
val decode_upload_response :
66
66
?locs:bool ->
67
67
string ->
68
-
(Jmap_proto.Blob.upload_response, Jsont.Error.t) result
68
+
(Jmap.Proto.Blob.upload_response, Jsont.Error.t) result
69
69
(** [decode_upload_response ?locs json] decodes a blob upload response. *)
70
70
71
71
val decode_upload_response_exn :
72
72
?locs:bool ->
73
73
string ->
74
-
Jmap_proto.Blob.upload_response
74
+
Jmap.Proto.Blob.upload_response
75
75
(** [decode_upload_response_exn ?locs json] is like {!decode_upload_response}
76
76
but raises on decoding errors. *)
77
77
+4
-3
eio/dune
+4
-3
eio/dune
···
1
1
(library
2
2
(name jmap_eio)
3
-
(public_name jmap-eio)
4
-
(libraries jmap jmap.mail jsont jsont.bytesrw eio requests uri str)
5
-
(modules jmap_eio codec client))
3
+
(public_name jmap.eio)
4
+
(optional)
5
+
(libraries jmap jsont jsont.bytesrw eio requests uri str cmdliner fmt.tty)
6
+
(modules jmap_eio codec client cli))
+2
eio/jmap_eio.ml
+2
eio/jmap_eio.ml
+17
-7
eio/jmap_eio.mli
+17
-7
eio/jmap_eio.mli
···
34
34
35
35
(* Get session info *)
36
36
let session = Jmap_eio.Client.session client in
37
-
Printf.printf "API URL: %s\n" (Jmap_proto.Session.api_url session);
37
+
Printf.printf "API URL: %s\n" (Jmap.Proto.Session.api_url session);
38
38
39
39
(* Build and execute a request *)
40
40
let account_id = (* get from session *) ... in
41
41
let req = Jmap_eio.Client.Build.(
42
42
make_request
43
-
~capabilities:[Jmap_proto.Capability.core_uri;
44
-
Jmap_proto.Capability.mail_uri]
43
+
~capabilities:[Jmap.Proto.Capability.core_uri;
44
+
Jmap.Proto.Capability.mail_uri]
45
45
[mailbox_get ~call_id:"0" ~account_id ()]
46
46
) in
47
47
let response = Jmap_eio.Client.request_exn client req in
···
49
49
(* Process response *)
50
50
List.iter (fun inv ->
51
51
Printf.printf "Method: %s, CallId: %s\n"
52
-
(Jmap_proto.Invocation.name inv)
53
-
(Jmap_proto.Invocation.method_call_id inv)
54
-
) (Jmap_proto.Response.method_responses response)
52
+
(Jmap.Proto.Invocation.name inv)
53
+
(Jmap.Proto.Invocation.method_call_id inv)
54
+
) (Jmap.Proto.Response.method_responses response)
55
55
]}
56
56
57
57
{2 Capabilities}
···
63
63
- [urn:ietf:params:jmap:submission] - EmailSubmission
64
64
- [urn:ietf:params:jmap:vacationresponse] - VacationResponse
65
65
66
-
These are available as constants in {!Jmap_proto.Capability}.
66
+
These are available as constants in {!Jmap.Proto.Capability}.
67
67
*)
68
68
69
69
(** Low-level JSON codec for JMAP messages. *)
···
71
71
72
72
(** High-level JMAP client with session management. *)
73
73
module Client = Client
74
+
75
+
(** CLI configuration and cmdliner terms for JMAP tools. *)
76
+
module Cli = Cli
77
+
78
+
(** Method chaining with automatic result references.
79
+
80
+
Provides a monadic interface for building JMAP requests where method
81
+
calls can reference results from previous calls in the same request.
82
+
Call IDs are generated automatically. *)
83
+
module Chain = Jmap.Chain
-35
jmap-eio.opam
-35
jmap-eio.opam
···
1
-
# This file is generated by dune, edit dune-project instead
2
-
opam-version: "2.0"
3
-
synopsis: "JMAP client for Eio"
4
-
description:
5
-
"High-level JMAP client using Eio for async I/O and the Requests HTTP library."
6
-
maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
7
-
authors: ["Anil Madhavapeddy <anil@recoil.org>"]
8
-
license: "ISC"
9
-
homepage: "https://github.com/avsm/ocaml-jmap"
10
-
doc: "https://avsm.github.io/ocaml-jmap"
11
-
bug-reports: "https://github.com/avsm/ocaml-jmap/issues"
12
-
depends: [
13
-
"dune" {>= "3.0"}
14
-
"ocaml" {>= "5.4.0"}
15
-
"jmap" {= version}
16
-
"jsont" {>= "0.2.0"}
17
-
"eio"
18
-
"requests"
19
-
"odoc" {with-doc}
20
-
]
21
-
build: [
22
-
["dune" "subst"] {dev}
23
-
[
24
-
"dune"
25
-
"build"
26
-
"-p"
27
-
name
28
-
"-j"
29
-
jobs
30
-
"@install"
31
-
"@runtest" {with-test}
32
-
"@doc" {with-doc}
33
-
]
34
-
]
35
-
dev-repo: "git+https://github.com/avsm/ocaml-jmap.git"
+9
-6
jmap.opam
+9
-6
jmap.opam
···
2
2
opam-version: "2.0"
3
3
synopsis: "JMAP protocol implementation for OCaml"
4
4
description:
5
-
"A complete implementation of the JSON Meta Application Protocol (JMAP) as specified in RFC 8620 (core) and RFC 8621 (mail)."
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
-
homepage: "https://github.com/avsm/ocaml-jmap"
10
-
doc: "https://avsm.github.io/ocaml-jmap"
11
-
bug-reports: "https://github.com/avsm/ocaml-jmap/issues"
9
+
homepage: "https://tangled.org/@anil.recoil.org/ocaml-jmap"
10
+
bug-reports: "https://tangled.org/@anil.recoil.org/ocaml-jmap/issues"
12
11
depends: [
13
-
"dune" {>= "3.0"}
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
+
"eio" {with-test}
18
+
"requests" {with-test}
19
+
"brr" {with-test}
18
20
"odoc" {with-doc}
19
21
]
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
-
dev-repo: "git+https://github.com/avsm/ocaml-jmap.git"
37
+
x-maintenance-intent: ["(latest)"]
+851
lib/core/chain.ml
+851
lib/core/chain.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Jmap_proto
7
+
8
+
(* Phantom types for handle kinds *)
9
+
type query
10
+
type get
11
+
type changes
12
+
type set
13
+
type query_changes
14
+
type copy
15
+
type import
16
+
type parse
17
+
18
+
(* Internal handle representation with GADT for response type *)
19
+
type (_, _) handle =
20
+
| Query_handle : {
21
+
call_id : string;
22
+
method_name : string;
23
+
} -> (query, Method.query_response) handle
24
+
| Query_changes_handle : {
25
+
call_id : string;
26
+
method_name : string;
27
+
} -> (query_changes, Method.query_changes_response) handle
28
+
| Email_get_handle : {
29
+
call_id : string;
30
+
method_name : string;
31
+
} -> (get, Email.t Method.get_response) handle
32
+
| Thread_get_handle : {
33
+
call_id : string;
34
+
method_name : string;
35
+
} -> (get, Thread.t Method.get_response) handle
36
+
| Mailbox_get_handle : {
37
+
call_id : string;
38
+
method_name : string;
39
+
} -> (get, Mailbox.t Method.get_response) handle
40
+
| Identity_get_handle : {
41
+
call_id : string;
42
+
method_name : string;
43
+
} -> (get, Identity.t Method.get_response) handle
44
+
| Submission_get_handle : {
45
+
call_id : string;
46
+
method_name : string;
47
+
} -> (get, Submission.t Method.get_response) handle
48
+
| Search_snippet_get_handle : {
49
+
call_id : string;
50
+
method_name : string;
51
+
} -> (get, Search_snippet.t Method.get_response) handle
52
+
| Vacation_get_handle : {
53
+
call_id : string;
54
+
method_name : string;
55
+
} -> (get, Vacation.t Method.get_response) handle
56
+
| Changes_handle : {
57
+
call_id : string;
58
+
method_name : string;
59
+
} -> (changes, Method.changes_response) handle
60
+
| Email_set_handle : {
61
+
call_id : string;
62
+
method_name : string;
63
+
} -> (set, Email.t Method.set_response) handle
64
+
| Mailbox_set_handle : {
65
+
call_id : string;
66
+
method_name : string;
67
+
} -> (set, Mailbox.t Method.set_response) handle
68
+
| Identity_set_handle : {
69
+
call_id : string;
70
+
method_name : string;
71
+
} -> (set, Identity.t Method.set_response) handle
72
+
| Submission_set_handle : {
73
+
call_id : string;
74
+
method_name : string;
75
+
} -> (set, Submission.t Method.set_response) handle
76
+
| Vacation_set_handle : {
77
+
call_id : string;
78
+
method_name : string;
79
+
} -> (set, Vacation.t Method.set_response) handle
80
+
| Email_copy_handle : {
81
+
call_id : string;
82
+
method_name : string;
83
+
} -> (copy, Email.t Method.copy_response) handle
84
+
| Raw_handle : {
85
+
call_id : string;
86
+
method_name : string;
87
+
} -> (unit, Jsont.Json.t) handle
88
+
89
+
let call_id : type k r. (k, r) handle -> string = function
90
+
| Query_handle h -> h.call_id
91
+
| Query_changes_handle h -> h.call_id
92
+
| Email_get_handle h -> h.call_id
93
+
| Thread_get_handle h -> h.call_id
94
+
| Mailbox_get_handle h -> h.call_id
95
+
| Identity_get_handle h -> h.call_id
96
+
| Submission_get_handle h -> h.call_id
97
+
| Search_snippet_get_handle h -> h.call_id
98
+
| Vacation_get_handle h -> h.call_id
99
+
| Changes_handle h -> h.call_id
100
+
| Email_set_handle h -> h.call_id
101
+
| Mailbox_set_handle h -> h.call_id
102
+
| Identity_set_handle h -> h.call_id
103
+
| Submission_set_handle h -> h.call_id
104
+
| Vacation_set_handle h -> h.call_id
105
+
| Email_copy_handle h -> h.call_id
106
+
| Raw_handle h -> h.call_id
107
+
108
+
let method_name : type k r. (k, r) handle -> string = function
109
+
| Query_handle h -> h.method_name
110
+
| Query_changes_handle h -> h.method_name
111
+
| Email_get_handle h -> h.method_name
112
+
| Thread_get_handle h -> h.method_name
113
+
| Mailbox_get_handle h -> h.method_name
114
+
| Identity_get_handle h -> h.method_name
115
+
| Submission_get_handle h -> h.method_name
116
+
| Search_snippet_get_handle h -> h.method_name
117
+
| Vacation_get_handle h -> h.method_name
118
+
| Changes_handle h -> h.method_name
119
+
| Email_set_handle h -> h.method_name
120
+
| Mailbox_set_handle h -> h.method_name
121
+
| Identity_set_handle h -> h.method_name
122
+
| Submission_set_handle h -> h.method_name
123
+
| Vacation_set_handle h -> h.method_name
124
+
| Email_copy_handle h -> h.method_name
125
+
| Raw_handle h -> h.method_name
126
+
127
+
(* Creation IDs *)
128
+
type 'a create_id = string
129
+
130
+
let created_id cid = Id.of_string_exn ("#" ^ cid)
131
+
let created_id_of_string s = Id.of_string_exn ("#" ^ s)
132
+
133
+
(* ID sources *)
134
+
type id_source =
135
+
| Ids of Id.t list
136
+
| Ref of Invocation.result_reference
137
+
138
+
let ids lst = Ids lst
139
+
let id x = Ids [x]
140
+
141
+
let make_ref ~call_id ~method_name ~path =
142
+
Ref (Invocation.result_reference_of_strings
143
+
~result_of:call_id
144
+
~name:method_name
145
+
~path)
146
+
147
+
let from_query : type r. (query, r) handle -> id_source = fun h ->
148
+
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/ids"
149
+
150
+
let from_get_ids : type r. (get, r) handle -> id_source = fun h ->
151
+
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/list/*/id"
152
+
153
+
let from_get_field : type r. (get, r) handle -> string -> id_source = fun h field ->
154
+
make_ref ~call_id:(call_id h) ~method_name:(method_name h)
155
+
~path:(Printf.sprintf "/list/*/%s" field)
156
+
157
+
let from_changes_created : type r. (changes, r) handle -> id_source = fun h ->
158
+
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/created"
159
+
160
+
let from_changes_updated : type r. (changes, r) handle -> id_source = fun h ->
161
+
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/updated"
162
+
163
+
let from_changes_destroyed : type r. (changes, r) handle -> id_source = fun h ->
164
+
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/destroyed"
165
+
166
+
let from_set_created : type r. (set, r) handle -> id_source = fun h ->
167
+
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/created/*/id"
168
+
169
+
let from_set_updated : type r. (set, r) handle -> id_source = fun h ->
170
+
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/updated"
171
+
172
+
let from_query_changes_removed : type r. (query_changes, r) handle -> id_source = fun h ->
173
+
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/removed"
174
+
175
+
let from_query_changes_added : type r. (query_changes, r) handle -> id_source = fun h ->
176
+
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/added/*/id"
177
+
178
+
let from_copy_created : type r. (copy, r) handle -> id_source = fun h ->
179
+
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/created/*/id"
180
+
181
+
let from_import_created : type r. (import, r) handle -> id_source = fun h ->
182
+
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/created/*/id"
183
+
184
+
(* Chain state *)
185
+
type state = {
186
+
mutable next_id : int;
187
+
mutable next_create_id : int;
188
+
mutable invocations : Invocation.t list;
189
+
}
190
+
191
+
(* Chain monad *)
192
+
type 'a t = state -> 'a
193
+
194
+
let return x _state = x
195
+
196
+
let bind m f state =
197
+
let a = m state in
198
+
f a state
199
+
200
+
let map f m state =
201
+
f (m state)
202
+
203
+
let both a b state =
204
+
let x = a state in
205
+
let y = b state in
206
+
(x, y)
207
+
208
+
let ( let* ) = bind
209
+
let ( let+ ) m f = map f m
210
+
let ( and* ) = both
211
+
let ( and+ ) = both
212
+
213
+
(* Building *)
214
+
let fresh_call_id state =
215
+
let id = Printf.sprintf "c%d" state.next_id in
216
+
state.next_id <- state.next_id + 1;
217
+
id
218
+
219
+
let fresh_create_id () state =
220
+
let id = Printf.sprintf "k%d" state.next_create_id in
221
+
state.next_create_id <- state.next_create_id + 1;
222
+
id
223
+
224
+
let record_invocation inv state =
225
+
state.invocations <- inv :: state.invocations
226
+
227
+
let build ~capabilities chain =
228
+
let state = { next_id = 0; next_create_id = 0; invocations = [] } in
229
+
let result = chain state in
230
+
let request = Request.create
231
+
~using:capabilities
232
+
~method_calls:(List.rev state.invocations)
233
+
()
234
+
in
235
+
(request, result)
236
+
237
+
let build_request ~capabilities chain =
238
+
fst (build ~capabilities chain)
239
+
240
+
(* JSON helpers - exported *)
241
+
let json_null = Jsont.Null ((), Jsont.Meta.none)
242
+
243
+
let json_bool b = Jsont.Bool (b, Jsont.Meta.none)
244
+
245
+
let json_string s = Jsont.String (s, Jsont.Meta.none)
246
+
247
+
let json_int n = Jsont.Number (Int64.to_float n, Jsont.Meta.none)
248
+
249
+
let json_name s = (s, Jsont.Meta.none)
250
+
251
+
let json_obj fields =
252
+
let fields' = List.map (fun (k, v) -> (json_name k, v)) fields in
253
+
Jsont.Object (fields', Jsont.Meta.none)
254
+
255
+
let json_array items = Jsont.Array (items, Jsont.Meta.none)
256
+
257
+
(* JSON helpers - internal *)
258
+
let json_of_id id =
259
+
Jsont.String (Id.to_string id, Jsont.Meta.none)
260
+
261
+
let json_of_id_list ids =
262
+
let items = List.map json_of_id ids in
263
+
Jsont.Array (items, Jsont.Meta.none)
264
+
265
+
let json_of_string_list strs =
266
+
let items = List.map json_string strs in
267
+
Jsont.Array (items, Jsont.Meta.none)
268
+
269
+
let json_map pairs =
270
+
let fields' = List.map (fun (k, v) -> (json_name k, v)) pairs in
271
+
Jsont.Object (fields', Jsont.Meta.none)
272
+
273
+
let encode_to_json jsont value =
274
+
match Jsont.Json.encode' jsont value with
275
+
| Ok j -> j
276
+
| Error _ -> json_obj []
277
+
278
+
let encode_list_to_json jsont values =
279
+
match Jsont.Json.encode' (Jsont.list jsont) values with
280
+
| Ok j -> j
281
+
| Error _ -> Jsont.Array ([], Jsont.Meta.none)
282
+
283
+
(* Add id_source to args *)
284
+
let add_ids_arg args = function
285
+
| None -> args
286
+
| Some (Ids ids) ->
287
+
("ids", json_of_id_list ids) :: args
288
+
| Some (Ref ref_) ->
289
+
let ref_json = encode_to_json Invocation.result_reference_jsont ref_ in
290
+
("#ids", ref_json) :: args
291
+
292
+
let add_destroy_arg args = function
293
+
| None -> args
294
+
| Some (Ids ids) ->
295
+
("destroy", json_of_id_list ids) :: args
296
+
| Some (Ref ref_) ->
297
+
let ref_json = encode_to_json Invocation.result_reference_jsont ref_ in
298
+
("#destroy", ref_json) :: args
299
+
300
+
(* Query builder helper *)
301
+
let build_query_args ~account_id ?filter ?filter_jsont ?sort ?position ?anchor
302
+
?anchor_offset ?limit ?calculate_total () =
303
+
let args = [ ("accountId", json_of_id account_id) ] in
304
+
let args = match filter, filter_jsont with
305
+
| Some f, Some jsont -> ("filter", encode_to_json jsont f) :: args
306
+
| _ -> args
307
+
in
308
+
let args = match sort with
309
+
| None -> args
310
+
| Some comparators -> ("sort", encode_list_to_json Filter.comparator_jsont comparators) :: args
311
+
in
312
+
let args = match position with
313
+
| None -> args
314
+
| Some n -> ("position", json_int n) :: args
315
+
in
316
+
let args = match anchor with
317
+
| None -> args
318
+
| Some id -> ("anchor", json_of_id id) :: args
319
+
in
320
+
let args = match anchor_offset with
321
+
| None -> args
322
+
| Some n -> ("anchorOffset", json_int n) :: args
323
+
in
324
+
let args = match limit with
325
+
| None -> args
326
+
| Some n -> ("limit", json_int n) :: args
327
+
in
328
+
let args = match calculate_total with
329
+
| None -> args
330
+
| Some b -> ("calculateTotal", json_bool b) :: args
331
+
in
332
+
args
333
+
334
+
(* Changes builder helper *)
335
+
let build_changes_args ~account_id ~since_state ?max_changes () =
336
+
let args = [
337
+
("accountId", json_of_id account_id);
338
+
("sinceState", json_string since_state);
339
+
] in
340
+
let args = match max_changes with
341
+
| None -> args
342
+
| Some n -> ("maxChanges", json_int n) :: args
343
+
in
344
+
args
345
+
346
+
(* QueryChanges builder helper *)
347
+
let build_query_changes_args ~account_id ~since_query_state ?filter ?filter_jsont
348
+
?sort ?max_changes ?up_to_id ?calculate_total () =
349
+
let args = [
350
+
("accountId", json_of_id account_id);
351
+
("sinceQueryState", json_string since_query_state);
352
+
] in
353
+
let args = match filter, filter_jsont with
354
+
| Some f, Some jsont -> ("filter", encode_to_json jsont f) :: args
355
+
| _ -> args
356
+
in
357
+
let args = match sort with
358
+
| None -> args
359
+
| Some comparators -> ("sort", encode_list_to_json Filter.comparator_jsont comparators) :: args
360
+
in
361
+
let args = match max_changes with
362
+
| None -> args
363
+
| Some n -> ("maxChanges", json_int n) :: args
364
+
in
365
+
let args = match up_to_id with
366
+
| None -> args
367
+
| Some id -> ("upToId", json_of_id id) :: args
368
+
in
369
+
let args = match calculate_total with
370
+
| None -> args
371
+
| Some b -> ("calculateTotal", json_bool b) :: args
372
+
in
373
+
args
374
+
375
+
(* Set builder helper *)
376
+
let build_set_args ~account_id ?if_in_state ?create ?update ?destroy () =
377
+
let args = [ ("accountId", json_of_id account_id) ] in
378
+
let args = match if_in_state with
379
+
| None -> args
380
+
| Some s -> ("ifInState", json_string s) :: args
381
+
in
382
+
let args = match create with
383
+
| None | Some [] -> args
384
+
| Some items ->
385
+
let create_map = json_map (List.map (fun (cid, obj) -> (cid, obj)) items) in
386
+
("create", create_map) :: args
387
+
in
388
+
let args = match update with
389
+
| None | Some [] -> args
390
+
| Some items ->
391
+
let update_map = json_map (List.map (fun (id, patch) -> (Id.to_string id, patch)) items) in
392
+
("update", update_map) :: args
393
+
in
394
+
let args = add_destroy_arg args destroy in
395
+
args
396
+
397
+
(* Method builders *)
398
+
399
+
let email_query ~account_id ?filter ?sort ?position ?anchor ?anchor_offset
400
+
?limit ?calculate_total ?collapse_threads () state =
401
+
let call_id = fresh_call_id state in
402
+
let args = build_query_args ~account_id ?filter
403
+
~filter_jsont:Mail_filter.email_filter_jsont
404
+
?sort ?position ?anchor ?anchor_offset ?limit ?calculate_total () in
405
+
let args = match collapse_threads with
406
+
| None -> args
407
+
| Some b -> ("collapseThreads", json_bool b) :: args
408
+
in
409
+
let inv = Invocation.create
410
+
~name:"Email/query"
411
+
~arguments:(json_obj args)
412
+
~method_call_id:call_id
413
+
in
414
+
record_invocation inv state;
415
+
Query_handle { call_id; method_name = "Email/query" }
416
+
417
+
let email_get ~account_id ?ids ?properties ?body_properties
418
+
?fetch_text_body_values ?fetch_html_body_values ?fetch_all_body_values
419
+
?max_body_value_bytes () state =
420
+
let call_id = fresh_call_id state in
421
+
let args = [ ("accountId", json_of_id account_id) ] in
422
+
let args = add_ids_arg args ids in
423
+
let args = match properties with
424
+
| None -> args
425
+
| Some props -> ("properties", json_of_string_list props) :: args
426
+
in
427
+
let args = match body_properties with
428
+
| None -> args
429
+
| Some props -> ("bodyProperties", json_of_string_list props) :: args
430
+
in
431
+
let args = match fetch_text_body_values with
432
+
| None -> args
433
+
| Some b -> ("fetchTextBodyValues", json_bool b) :: args
434
+
in
435
+
let args = match fetch_html_body_values with
436
+
| None -> args
437
+
| Some b -> ("fetchHTMLBodyValues", json_bool b) :: args
438
+
in
439
+
let args = match fetch_all_body_values with
440
+
| None -> args
441
+
| Some b -> ("fetchAllBodyValues", json_bool b) :: args
442
+
in
443
+
let args = match max_body_value_bytes with
444
+
| None -> args
445
+
| Some n -> ("maxBodyValueBytes", json_int n) :: args
446
+
in
447
+
let inv = Invocation.create
448
+
~name:"Email/get"
449
+
~arguments:(json_obj args)
450
+
~method_call_id:call_id
451
+
in
452
+
record_invocation inv state;
453
+
Email_get_handle { call_id; method_name = "Email/get" }
454
+
455
+
let email_changes ~account_id ~since_state ?max_changes () state =
456
+
let call_id = fresh_call_id state in
457
+
let args = build_changes_args ~account_id ~since_state ?max_changes () in
458
+
let inv = Invocation.create
459
+
~name:"Email/changes"
460
+
~arguments:(json_obj args)
461
+
~method_call_id:call_id
462
+
in
463
+
record_invocation inv state;
464
+
Changes_handle { call_id; method_name = "Email/changes" }
465
+
466
+
let email_query_changes ~account_id ~since_query_state ?filter ?sort
467
+
?max_changes ?up_to_id ?calculate_total () state =
468
+
let call_id = fresh_call_id state in
469
+
let args = build_query_changes_args ~account_id ~since_query_state
470
+
?filter ~filter_jsont:Mail_filter.email_filter_jsont
471
+
?sort ?max_changes ?up_to_id ?calculate_total () in
472
+
let inv = Invocation.create
473
+
~name:"Email/queryChanges"
474
+
~arguments:(json_obj args)
475
+
~method_call_id:call_id
476
+
in
477
+
record_invocation inv state;
478
+
Query_changes_handle { call_id; method_name = "Email/queryChanges" }
479
+
480
+
let email_set ~account_id ?if_in_state ?create ?update ?destroy () state =
481
+
let call_id = fresh_call_id state in
482
+
let args = build_set_args ~account_id ?if_in_state ?create ?update ?destroy () in
483
+
let inv = Invocation.create
484
+
~name:"Email/set"
485
+
~arguments:(json_obj args)
486
+
~method_call_id:call_id
487
+
in
488
+
record_invocation inv state;
489
+
Email_set_handle { call_id; method_name = "Email/set" }
490
+
491
+
let email_copy ~from_account_id ~account_id ?if_from_in_state ?if_in_state
492
+
?create ?on_success_destroy_original ?destroy_from_if_in_state () state =
493
+
let call_id = fresh_call_id state in
494
+
let args = [
495
+
("fromAccountId", json_of_id from_account_id);
496
+
("accountId", json_of_id account_id);
497
+
] in
498
+
let args = match if_from_in_state with
499
+
| None -> args
500
+
| Some s -> ("ifFromInState", json_string s) :: args
501
+
in
502
+
let args = match if_in_state with
503
+
| None -> args
504
+
| Some s -> ("ifInState", json_string s) :: args
505
+
in
506
+
let args = match create with
507
+
| None | Some [] -> args
508
+
| Some items ->
509
+
let create_map = json_map (List.map (fun (id, obj) -> (Id.to_string id, obj)) items) in
510
+
("create", create_map) :: args
511
+
in
512
+
let args = match on_success_destroy_original with
513
+
| None -> args
514
+
| Some b -> ("onSuccessDestroyOriginal", json_bool b) :: args
515
+
in
516
+
let args = match destroy_from_if_in_state with
517
+
| None -> args
518
+
| Some s -> ("destroyFromIfInState", json_string s) :: args
519
+
in
520
+
let inv = Invocation.create
521
+
~name:"Email/copy"
522
+
~arguments:(json_obj args)
523
+
~method_call_id:call_id
524
+
in
525
+
record_invocation inv state;
526
+
Email_copy_handle { call_id; method_name = "Email/copy" }
527
+
528
+
let thread_get ~account_id ?ids () state =
529
+
let call_id = fresh_call_id state in
530
+
let args = [ ("accountId", json_of_id account_id) ] in
531
+
let args = add_ids_arg args ids in
532
+
let inv = Invocation.create
533
+
~name:"Thread/get"
534
+
~arguments:(json_obj args)
535
+
~method_call_id:call_id
536
+
in
537
+
record_invocation inv state;
538
+
Thread_get_handle { call_id; method_name = "Thread/get" }
539
+
540
+
let thread_changes ~account_id ~since_state ?max_changes () state =
541
+
let call_id = fresh_call_id state in
542
+
let args = build_changes_args ~account_id ~since_state ?max_changes () in
543
+
let inv = Invocation.create
544
+
~name:"Thread/changes"
545
+
~arguments:(json_obj args)
546
+
~method_call_id:call_id
547
+
in
548
+
record_invocation inv state;
549
+
Changes_handle { call_id; method_name = "Thread/changes" }
550
+
551
+
let mailbox_query ~account_id ?filter ?sort ?position ?anchor ?anchor_offset
552
+
?limit ?calculate_total () state =
553
+
let call_id = fresh_call_id state in
554
+
let args = build_query_args ~account_id ?filter
555
+
~filter_jsont:Mail_filter.mailbox_filter_jsont
556
+
?sort ?position ?anchor ?anchor_offset ?limit ?calculate_total () in
557
+
let inv = Invocation.create
558
+
~name:"Mailbox/query"
559
+
~arguments:(json_obj args)
560
+
~method_call_id:call_id
561
+
in
562
+
record_invocation inv state;
563
+
Query_handle { call_id; method_name = "Mailbox/query" }
564
+
565
+
let mailbox_get ~account_id ?ids ?properties () state =
566
+
let call_id = fresh_call_id state in
567
+
let args = [ ("accountId", json_of_id account_id) ] in
568
+
let args = add_ids_arg args ids in
569
+
let args = match properties with
570
+
| None -> args
571
+
| Some props -> ("properties", json_of_string_list props) :: args
572
+
in
573
+
let inv = Invocation.create
574
+
~name:"Mailbox/get"
575
+
~arguments:(json_obj args)
576
+
~method_call_id:call_id
577
+
in
578
+
record_invocation inv state;
579
+
Mailbox_get_handle { call_id; method_name = "Mailbox/get" }
580
+
581
+
let mailbox_changes ~account_id ~since_state ?max_changes () state =
582
+
let call_id = fresh_call_id state in
583
+
let args = build_changes_args ~account_id ~since_state ?max_changes () in
584
+
let inv = Invocation.create
585
+
~name:"Mailbox/changes"
586
+
~arguments:(json_obj args)
587
+
~method_call_id:call_id
588
+
in
589
+
record_invocation inv state;
590
+
Changes_handle { call_id; method_name = "Mailbox/changes" }
591
+
592
+
let mailbox_query_changes ~account_id ~since_query_state ?filter ?sort
593
+
?max_changes ?up_to_id ?calculate_total () state =
594
+
let call_id = fresh_call_id state in
595
+
let args = build_query_changes_args ~account_id ~since_query_state
596
+
?filter ~filter_jsont:Mail_filter.mailbox_filter_jsont
597
+
?sort ?max_changes ?up_to_id ?calculate_total () in
598
+
let inv = Invocation.create
599
+
~name:"Mailbox/queryChanges"
600
+
~arguments:(json_obj args)
601
+
~method_call_id:call_id
602
+
in
603
+
record_invocation inv state;
604
+
Query_changes_handle { call_id; method_name = "Mailbox/queryChanges" }
605
+
606
+
let mailbox_set ~account_id ?if_in_state ?create ?update ?destroy
607
+
?on_destroy_remove_emails () state =
608
+
let call_id = fresh_call_id state in
609
+
let args = build_set_args ~account_id ?if_in_state ?create ?update ?destroy () in
610
+
let args = match on_destroy_remove_emails with
611
+
| None -> args
612
+
| Some b -> ("onDestroyRemoveEmails", json_bool b) :: args
613
+
in
614
+
let inv = Invocation.create
615
+
~name:"Mailbox/set"
616
+
~arguments:(json_obj args)
617
+
~method_call_id:call_id
618
+
in
619
+
record_invocation inv state;
620
+
Mailbox_set_handle { call_id; method_name = "Mailbox/set" }
621
+
622
+
let identity_get ~account_id ?ids ?properties () state =
623
+
let call_id = fresh_call_id state in
624
+
let args = [ ("accountId", json_of_id account_id) ] in
625
+
let args = add_ids_arg args ids in
626
+
let args = match properties with
627
+
| None -> args
628
+
| Some props -> ("properties", json_of_string_list props) :: args
629
+
in
630
+
let inv = Invocation.create
631
+
~name:"Identity/get"
632
+
~arguments:(json_obj args)
633
+
~method_call_id:call_id
634
+
in
635
+
record_invocation inv state;
636
+
Identity_get_handle { call_id; method_name = "Identity/get" }
637
+
638
+
let identity_changes ~account_id ~since_state ?max_changes () state =
639
+
let call_id = fresh_call_id state in
640
+
let args = build_changes_args ~account_id ~since_state ?max_changes () in
641
+
let inv = Invocation.create
642
+
~name:"Identity/changes"
643
+
~arguments:(json_obj args)
644
+
~method_call_id:call_id
645
+
in
646
+
record_invocation inv state;
647
+
Changes_handle { call_id; method_name = "Identity/changes" }
648
+
649
+
let identity_set ~account_id ?if_in_state ?create ?update ?destroy () state =
650
+
let call_id = fresh_call_id state in
651
+
let args = build_set_args ~account_id ?if_in_state ?create ?update ?destroy () in
652
+
let inv = Invocation.create
653
+
~name:"Identity/set"
654
+
~arguments:(json_obj args)
655
+
~method_call_id:call_id
656
+
in
657
+
record_invocation inv state;
658
+
Identity_set_handle { call_id; method_name = "Identity/set" }
659
+
660
+
let email_submission_query ~account_id ?filter ?sort ?position ?anchor
661
+
?anchor_offset ?limit ?calculate_total () state =
662
+
let call_id = fresh_call_id state in
663
+
let args = build_query_args ~account_id ?filter
664
+
~filter_jsont:Mail_filter.submission_filter_jsont
665
+
?sort ?position ?anchor ?anchor_offset ?limit ?calculate_total () in
666
+
let inv = Invocation.create
667
+
~name:"EmailSubmission/query"
668
+
~arguments:(json_obj args)
669
+
~method_call_id:call_id
670
+
in
671
+
record_invocation inv state;
672
+
Query_handle { call_id; method_name = "EmailSubmission/query" }
673
+
674
+
let email_submission_get ~account_id ?ids ?properties () state =
675
+
let call_id = fresh_call_id state in
676
+
let args = [ ("accountId", json_of_id account_id) ] in
677
+
let args = add_ids_arg args ids in
678
+
let args = match properties with
679
+
| None -> args
680
+
| Some props -> ("properties", json_of_string_list props) :: args
681
+
in
682
+
let inv = Invocation.create
683
+
~name:"EmailSubmission/get"
684
+
~arguments:(json_obj args)
685
+
~method_call_id:call_id
686
+
in
687
+
record_invocation inv state;
688
+
Submission_get_handle { call_id; method_name = "EmailSubmission/get" }
689
+
690
+
let email_submission_changes ~account_id ~since_state ?max_changes () state =
691
+
let call_id = fresh_call_id state in
692
+
let args = build_changes_args ~account_id ~since_state ?max_changes () in
693
+
let inv = Invocation.create
694
+
~name:"EmailSubmission/changes"
695
+
~arguments:(json_obj args)
696
+
~method_call_id:call_id
697
+
in
698
+
record_invocation inv state;
699
+
Changes_handle { call_id; method_name = "EmailSubmission/changes" }
700
+
701
+
let email_submission_query_changes ~account_id ~since_query_state ?filter ?sort
702
+
?max_changes ?up_to_id ?calculate_total () state =
703
+
let call_id = fresh_call_id state in
704
+
let args = build_query_changes_args ~account_id ~since_query_state
705
+
?filter ~filter_jsont:Mail_filter.submission_filter_jsont
706
+
?sort ?max_changes ?up_to_id ?calculate_total () in
707
+
let inv = Invocation.create
708
+
~name:"EmailSubmission/queryChanges"
709
+
~arguments:(json_obj args)
710
+
~method_call_id:call_id
711
+
in
712
+
record_invocation inv state;
713
+
Query_changes_handle { call_id; method_name = "EmailSubmission/queryChanges" }
714
+
715
+
let email_submission_set ~account_id ?if_in_state ?create ?update ?destroy
716
+
?on_success_update_email ?on_success_destroy_email () state =
717
+
let call_id = fresh_call_id state in
718
+
let args = build_set_args ~account_id ?if_in_state ?create ?update ?destroy () in
719
+
let args = match on_success_update_email with
720
+
| None | Some [] -> args
721
+
| Some items ->
722
+
let update_map = json_map items in
723
+
("onSuccessUpdateEmail", update_map) :: args
724
+
in
725
+
let args = match on_success_destroy_email with
726
+
| None | Some [] -> args
727
+
| Some ids ->
728
+
("onSuccessDestroyEmail", json_of_string_list ids) :: args
729
+
in
730
+
let inv = Invocation.create
731
+
~name:"EmailSubmission/set"
732
+
~arguments:(json_obj args)
733
+
~method_call_id:call_id
734
+
in
735
+
record_invocation inv state;
736
+
Submission_set_handle { call_id; method_name = "EmailSubmission/set" }
737
+
738
+
let search_snippet_get ~account_id ~filter ~email_ids () state =
739
+
let call_id = fresh_call_id state in
740
+
let args = [ ("accountId", json_of_id account_id) ] in
741
+
let args = ("filter", encode_to_json Mail_filter.email_filter_jsont filter) :: args in
742
+
let args = match email_ids with
743
+
| Ids ids -> ("emailIds", json_of_id_list ids) :: args
744
+
| Ref ref_ ->
745
+
let ref_json = encode_to_json Invocation.result_reference_jsont ref_ in
746
+
("#emailIds", ref_json) :: args
747
+
in
748
+
let inv = Invocation.create
749
+
~name:"SearchSnippet/get"
750
+
~arguments:(json_obj args)
751
+
~method_call_id:call_id
752
+
in
753
+
record_invocation inv state;
754
+
Search_snippet_get_handle { call_id; method_name = "SearchSnippet/get" }
755
+
756
+
let vacation_response_get ~account_id ?properties () state =
757
+
let call_id = fresh_call_id state in
758
+
let args = [ ("accountId", json_of_id account_id) ] in
759
+
let args = match properties with
760
+
| None -> args
761
+
| Some props -> ("properties", json_of_string_list props) :: args
762
+
in
763
+
let inv = Invocation.create
764
+
~name:"VacationResponse/get"
765
+
~arguments:(json_obj args)
766
+
~method_call_id:call_id
767
+
in
768
+
record_invocation inv state;
769
+
Vacation_get_handle { call_id; method_name = "VacationResponse/get" }
770
+
771
+
let vacation_response_set ~account_id ?if_in_state ~update () state =
772
+
let call_id = fresh_call_id state in
773
+
let args = [ ("accountId", json_of_id account_id) ] in
774
+
let args = match if_in_state with
775
+
| None -> args
776
+
| Some s -> ("ifInState", json_string s) :: args
777
+
in
778
+
let args = ("update", json_map [("singleton", update)]) :: args in
779
+
let inv = Invocation.create
780
+
~name:"VacationResponse/set"
781
+
~arguments:(json_obj args)
782
+
~method_call_id:call_id
783
+
in
784
+
record_invocation inv state;
785
+
Vacation_set_handle { call_id; method_name = "VacationResponse/set" }
786
+
787
+
let raw_invocation ~name ~arguments state =
788
+
let call_id = fresh_call_id state in
789
+
let inv = Invocation.create
790
+
~name
791
+
~arguments
792
+
~method_call_id:call_id
793
+
in
794
+
record_invocation inv state;
795
+
Raw_handle { call_id; method_name = name }
796
+
797
+
(* Response parsing *)
798
+
799
+
let find_invocation ~call_id response =
800
+
List.find_opt
801
+
(fun inv -> Invocation.method_call_id inv = call_id)
802
+
(Response.method_responses response)
803
+
804
+
let parse : type k r. (k, r) handle -> Response.t -> (r, Jsont.Error.t) result =
805
+
fun handle response ->
806
+
let cid = call_id handle in
807
+
match find_invocation ~call_id:cid response with
808
+
| None ->
809
+
Error (Jsont.Error.msgf Jsont.Meta.none "No response found for call_id: %s" cid)
810
+
| Some inv ->
811
+
let args = Invocation.arguments inv in
812
+
match handle with
813
+
| Query_handle _ ->
814
+
Jsont.Json.decode' Method.query_response_jsont args
815
+
| Query_changes_handle _ ->
816
+
Jsont.Json.decode' Method.query_changes_response_jsont args
817
+
| Email_get_handle _ ->
818
+
Jsont.Json.decode' (Method.get_response_jsont Email.jsont) args
819
+
| Thread_get_handle _ ->
820
+
Jsont.Json.decode' (Method.get_response_jsont Thread.jsont) args
821
+
| Mailbox_get_handle _ ->
822
+
Jsont.Json.decode' (Method.get_response_jsont Mailbox.jsont) args
823
+
| Identity_get_handle _ ->
824
+
Jsont.Json.decode' (Method.get_response_jsont Identity.jsont) args
825
+
| Submission_get_handle _ ->
826
+
Jsont.Json.decode' (Method.get_response_jsont Submission.jsont) args
827
+
| Search_snippet_get_handle _ ->
828
+
Jsont.Json.decode' (Method.get_response_jsont Search_snippet.jsont) args
829
+
| Vacation_get_handle _ ->
830
+
Jsont.Json.decode' (Method.get_response_jsont Vacation.jsont) args
831
+
| Changes_handle _ ->
832
+
Jsont.Json.decode' Method.changes_response_jsont args
833
+
| Email_set_handle _ ->
834
+
Jsont.Json.decode' (Method.set_response_jsont Email.jsont) args
835
+
| Mailbox_set_handle _ ->
836
+
Jsont.Json.decode' (Method.set_response_jsont Mailbox.jsont) args
837
+
| Identity_set_handle _ ->
838
+
Jsont.Json.decode' (Method.set_response_jsont Identity.jsont) args
839
+
| Submission_set_handle _ ->
840
+
Jsont.Json.decode' (Method.set_response_jsont Submission.jsont) args
841
+
| Vacation_set_handle _ ->
842
+
Jsont.Json.decode' (Method.set_response_jsont Vacation.jsont) args
843
+
| Email_copy_handle _ ->
844
+
Jsont.Json.decode' (Method.copy_response_jsont Email.jsont) args
845
+
| Raw_handle _ ->
846
+
Ok args
847
+
848
+
let parse_exn handle response =
849
+
match parse handle response with
850
+
| Ok r -> r
851
+
| Error e -> failwith (Jsont.Error.to_string e)
+556
lib/core/chain.mli
+556
lib/core/chain.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP method chaining with automatic result references.
7
+
8
+
This module provides a monadic interface for building JMAP requests
9
+
where method calls can reference results from previous calls in the
10
+
same request. Call IDs are generated automatically.
11
+
12
+
{2 Basic Example}
13
+
14
+
Query for emails and fetch their details in a single request:
15
+
{[
16
+
let open Jmap.Chain in
17
+
let request, emails = build ~capabilities:[core; mail] begin
18
+
let* query = email_query ~account_id
19
+
~filter:(Condition { in_mailbox = Some inbox_id; _ })
20
+
~limit:50L ()
21
+
in
22
+
let* emails = email_get ~account_id
23
+
~ids:(from_query query)
24
+
~properties:["subject"; "from"; "receivedAt"]
25
+
()
26
+
in
27
+
return emails
28
+
end in
29
+
match Client.request client request with
30
+
| Ok response ->
31
+
let emails = parse emails response in
32
+
...
33
+
]}
34
+
35
+
{2 Creation and Submission}
36
+
37
+
Create a draft email and submit it in one request:
38
+
{[
39
+
let* set_h, draft_cid = email_set ~account_id
40
+
~create:[email_create ~mailbox_ids:[drafts_id] ~subject:"Hello" ...]
41
+
()
42
+
in
43
+
let* _ = email_submission_set ~account_id
44
+
~create:[submission_create
45
+
~email_id:(created_id draft_cid)
46
+
~identity_id]
47
+
()
48
+
in
49
+
return set_h
50
+
]}
51
+
52
+
{2 Multi-step Chains}
53
+
54
+
The RFC 8620 example - fetch from/date/subject for all emails in
55
+
the first 10 threads in the inbox:
56
+
{[
57
+
let* q = email_query ~account_id
58
+
~filter:(Condition { in_mailbox = Some inbox_id; _ })
59
+
~sort:[comparator ~is_ascending:false "receivedAt"]
60
+
~collapse_threads:true ~limit:10L ()
61
+
in
62
+
let* e1 = email_get ~account_id
63
+
~ids:(from_query q)
64
+
~properties:["threadId"]
65
+
()
66
+
in
67
+
let* threads = thread_get ~account_id
68
+
~ids:(from_get_field e1 "threadId")
69
+
()
70
+
in
71
+
let* e2 = email_get ~account_id
72
+
~ids:(from_get_field threads "emailIds")
73
+
~properties:["from"; "receivedAt"; "subject"]
74
+
()
75
+
in
76
+
return e2
77
+
]} *)
78
+
79
+
(** {1 Handles}
80
+
81
+
Method invocations return handles that encode both the method kind
82
+
(for building result references) and the exact response type
83
+
(for type-safe parsing). *)
84
+
85
+
(** Phantom type for query method handles. *)
86
+
type query
87
+
88
+
(** Phantom type for get method handles. *)
89
+
type get
90
+
91
+
(** Phantom type for changes method handles. *)
92
+
type changes
93
+
94
+
(** Phantom type for set method handles. *)
95
+
type set
96
+
97
+
(** Phantom type for query_changes method handles. *)
98
+
type query_changes
99
+
100
+
(** Phantom type for copy method handles. *)
101
+
type copy
102
+
103
+
(** Phantom type for import method handles. *)
104
+
type import
105
+
106
+
(** Phantom type for parse method handles. *)
107
+
type parse
108
+
109
+
(** A handle to a method invocation.
110
+
111
+
The first type parameter indicates the method kind (query/get/changes/set/...),
112
+
used for building result references. The second type parameter is the
113
+
parsed response type, enabling type-safe parsing via {!parse}. *)
114
+
type (_, _) handle
115
+
116
+
val call_id : (_, _) handle -> string
117
+
(** [call_id h] returns the auto-generated call ID for this invocation. *)
118
+
119
+
val method_name : (_, _) handle -> string
120
+
(** [method_name h] returns the method name (e.g., "Email/query"). *)
121
+
122
+
(** {1 Creation IDs}
123
+
124
+
When creating objects via [/set] methods, you can reference the
125
+
server-assigned ID before the request completes using creation IDs. *)
126
+
127
+
type 'a create_id
128
+
(** A creation ID for an object of type ['a]. Used to reference
129
+
newly created objects within the same request. *)
130
+
131
+
val created_id : _ create_id -> Jmap_proto.Id.t
132
+
(** [created_id cid] returns a placeholder ID (["#cN"]) that the server
133
+
will substitute with the real ID. Use this to reference a created
134
+
object in subsequent method calls within the same request. *)
135
+
136
+
val created_id_of_string : string -> Jmap_proto.Id.t
137
+
(** [created_id_of_string s] returns a placeholder ID for a string creation ID.
138
+
For example, [created_id_of_string "draft1"] returns ["#draft1"]. *)
139
+
140
+
(** {1 ID Sources}
141
+
142
+
Methods that accept IDs can take them either as concrete values
143
+
or as references to results from previous method calls. *)
144
+
145
+
type id_source =
146
+
| Ids of Jmap_proto.Id.t list
147
+
(** Concrete list of IDs. *)
148
+
| Ref of Jmap_proto.Invocation.result_reference
149
+
(** Back-reference to a previous method's result. *)
150
+
151
+
val ids : Jmap_proto.Id.t list -> id_source
152
+
(** [ids lst] provides concrete IDs. *)
153
+
154
+
val id : Jmap_proto.Id.t -> id_source
155
+
(** [id x] provides a single concrete ID. *)
156
+
157
+
(** {2 References from Query} *)
158
+
159
+
val from_query : (query, _) handle -> id_source
160
+
(** [from_query h] references [/ids] from a query response. *)
161
+
162
+
(** {2 References from Get} *)
163
+
164
+
val from_get_ids : (get, _) handle -> id_source
165
+
(** [from_get_ids h] references [/list/*/id] from a get response. *)
166
+
167
+
val from_get_field : (get, _) handle -> string -> id_source
168
+
(** [from_get_field h field] references [/list/*/field] from a get response.
169
+
Common fields: ["threadId"], ["emailIds"], ["mailboxIds"]. *)
170
+
171
+
(** {2 References from Changes} *)
172
+
173
+
val from_changes_created : (changes, _) handle -> id_source
174
+
(** [from_changes_created h] references [/created] from a changes response. *)
175
+
176
+
val from_changes_updated : (changes, _) handle -> id_source
177
+
(** [from_changes_updated h] references [/updated] from a changes response. *)
178
+
179
+
val from_changes_destroyed : (changes, _) handle -> id_source
180
+
(** [from_changes_destroyed h] references [/destroyed] from a changes response. *)
181
+
182
+
(** {2 References from Set} *)
183
+
184
+
val from_set_created : (set, _) handle -> id_source
185
+
(** [from_set_created h] references [/created/*/id] - IDs of objects created
186
+
by a set operation. *)
187
+
188
+
val from_set_updated : (set, _) handle -> id_source
189
+
(** [from_set_updated h] references [/updated] - IDs of objects updated. *)
190
+
191
+
(** {2 References from QueryChanges} *)
192
+
193
+
val from_query_changes_removed : (query_changes, _) handle -> id_source
194
+
(** [from_query_changes_removed h] references [/removed] from queryChanges. *)
195
+
196
+
val from_query_changes_added : (query_changes, _) handle -> id_source
197
+
(** [from_query_changes_added h] references [/added/*/id] from queryChanges. *)
198
+
199
+
(** {2 References from Copy} *)
200
+
201
+
val from_copy_created : (copy, _) handle -> id_source
202
+
(** [from_copy_created h] references [/created/*/id] from copy response. *)
203
+
204
+
(** {2 References from Import} *)
205
+
206
+
val from_import_created : (import, _) handle -> id_source
207
+
(** [from_import_created h] references [/created/*/id] from import response. *)
208
+
209
+
(** {1 Chain Monad}
210
+
211
+
A monad for building JMAP requests with automatic call ID generation
212
+
and invocation collection. *)
213
+
214
+
type 'a t
215
+
(** A chain computation that produces ['a] (typically a handle). *)
216
+
217
+
val return : 'a -> 'a t
218
+
(** [return x] is a computation that produces [x] without adding any
219
+
method invocations. *)
220
+
221
+
val bind : 'a t -> ('a -> 'b t) -> 'b t
222
+
(** [bind m f] sequences computations, threading the chain state. *)
223
+
224
+
val map : ('a -> 'b) -> 'a t -> 'b t
225
+
(** [map f m] applies [f] to the result of [m]. *)
226
+
227
+
val both : 'a t -> 'b t -> ('a * 'b) t
228
+
(** [both a b] runs both computations, returning their results as a pair. *)
229
+
230
+
(** {2 Syntax} *)
231
+
232
+
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
233
+
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
234
+
val ( and* ) : 'a t -> 'b t -> ('a * 'b) t
235
+
val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t
236
+
237
+
(** {1 Building Requests} *)
238
+
239
+
val build :
240
+
capabilities:string list ->
241
+
'a t ->
242
+
Jmap_proto.Request.t * 'a
243
+
(** [build ~capabilities chain] runs the chain computation, returning
244
+
the JMAP request and the final value (typically a handle for parsing). *)
245
+
246
+
val build_request :
247
+
capabilities:string list ->
248
+
'a t ->
249
+
Jmap_proto.Request.t
250
+
(** [build_request ~capabilities chain] is like {!build} but discards
251
+
the final value. *)
252
+
253
+
(** {1 Method Builders}
254
+
255
+
Each builder returns a handle wrapped in the chain monad.
256
+
Call IDs are assigned automatically based on invocation order. *)
257
+
258
+
(** {2 Email Methods} *)
259
+
260
+
val email_query :
261
+
account_id:Jmap_proto.Id.t ->
262
+
?filter:Jmap_proto.Mail_filter.email_filter ->
263
+
?sort:Jmap_proto.Filter.comparator list ->
264
+
?position:int64 ->
265
+
?anchor:Jmap_proto.Id.t ->
266
+
?anchor_offset:int64 ->
267
+
?limit:int64 ->
268
+
?calculate_total:bool ->
269
+
?collapse_threads:bool ->
270
+
unit ->
271
+
(query, Jmap_proto.Method.query_response) handle t
272
+
273
+
val email_get :
274
+
account_id:Jmap_proto.Id.t ->
275
+
?ids:id_source ->
276
+
?properties:string list ->
277
+
?body_properties:string list ->
278
+
?fetch_text_body_values:bool ->
279
+
?fetch_html_body_values:bool ->
280
+
?fetch_all_body_values:bool ->
281
+
?max_body_value_bytes:int64 ->
282
+
unit ->
283
+
(get, Jmap_proto.Email.t Jmap_proto.Method.get_response) handle t
284
+
285
+
val email_changes :
286
+
account_id:Jmap_proto.Id.t ->
287
+
since_state:string ->
288
+
?max_changes:int64 ->
289
+
unit ->
290
+
(changes, Jmap_proto.Method.changes_response) handle t
291
+
292
+
val email_query_changes :
293
+
account_id:Jmap_proto.Id.t ->
294
+
since_query_state:string ->
295
+
?filter:Jmap_proto.Mail_filter.email_filter ->
296
+
?sort:Jmap_proto.Filter.comparator list ->
297
+
?max_changes:int64 ->
298
+
?up_to_id:Jmap_proto.Id.t ->
299
+
?calculate_total:bool ->
300
+
unit ->
301
+
(query_changes, Jmap_proto.Method.query_changes_response) handle t
302
+
303
+
val email_set :
304
+
account_id:Jmap_proto.Id.t ->
305
+
?if_in_state:string ->
306
+
?create:(string * Jsont.Json.t) list ->
307
+
?update:(Jmap_proto.Id.t * Jsont.Json.t) list ->
308
+
?destroy:id_source ->
309
+
unit ->
310
+
(set, Jmap_proto.Email.t Jmap_proto.Method.set_response) handle t
311
+
(** Build an Email/set invocation.
312
+
313
+
[create] is a list of [(creation_id, email_object)] pairs where
314
+
[creation_id] is a client-chosen string (e.g., "draft1") and
315
+
[email_object] is the JSON representation of the email to create.
316
+
317
+
Use {!created_id_of_string} to reference created objects in later calls. *)
318
+
319
+
val email_copy :
320
+
from_account_id:Jmap_proto.Id.t ->
321
+
account_id:Jmap_proto.Id.t ->
322
+
?if_from_in_state:string ->
323
+
?if_in_state:string ->
324
+
?create:(Jmap_proto.Id.t * Jsont.Json.t) list ->
325
+
?on_success_destroy_original:bool ->
326
+
?destroy_from_if_in_state:string ->
327
+
unit ->
328
+
(copy, Jmap_proto.Email.t Jmap_proto.Method.copy_response) handle t
329
+
(** Build an Email/copy invocation.
330
+
331
+
[create] maps source email IDs to override objects. The source email
332
+
is copied to the target account with any overridden properties. *)
333
+
334
+
(** {2 Thread Methods} *)
335
+
336
+
val thread_get :
337
+
account_id:Jmap_proto.Id.t ->
338
+
?ids:id_source ->
339
+
unit ->
340
+
(get, Jmap_proto.Thread.t Jmap_proto.Method.get_response) handle t
341
+
342
+
val thread_changes :
343
+
account_id:Jmap_proto.Id.t ->
344
+
since_state:string ->
345
+
?max_changes:int64 ->
346
+
unit ->
347
+
(changes, Jmap_proto.Method.changes_response) handle t
348
+
349
+
(** {2 Mailbox Methods} *)
350
+
351
+
val mailbox_query :
352
+
account_id:Jmap_proto.Id.t ->
353
+
?filter:Jmap_proto.Mail_filter.mailbox_filter ->
354
+
?sort:Jmap_proto.Filter.comparator list ->
355
+
?position:int64 ->
356
+
?anchor:Jmap_proto.Id.t ->
357
+
?anchor_offset:int64 ->
358
+
?limit:int64 ->
359
+
?calculate_total:bool ->
360
+
unit ->
361
+
(query, Jmap_proto.Method.query_response) handle t
362
+
363
+
val mailbox_get :
364
+
account_id:Jmap_proto.Id.t ->
365
+
?ids:id_source ->
366
+
?properties:string list ->
367
+
unit ->
368
+
(get, Jmap_proto.Mailbox.t Jmap_proto.Method.get_response) handle t
369
+
370
+
val mailbox_changes :
371
+
account_id:Jmap_proto.Id.t ->
372
+
since_state:string ->
373
+
?max_changes:int64 ->
374
+
unit ->
375
+
(changes, Jmap_proto.Method.changes_response) handle t
376
+
377
+
val mailbox_query_changes :
378
+
account_id:Jmap_proto.Id.t ->
379
+
since_query_state:string ->
380
+
?filter:Jmap_proto.Mail_filter.mailbox_filter ->
381
+
?sort:Jmap_proto.Filter.comparator list ->
382
+
?max_changes:int64 ->
383
+
?up_to_id:Jmap_proto.Id.t ->
384
+
?calculate_total:bool ->
385
+
unit ->
386
+
(query_changes, Jmap_proto.Method.query_changes_response) handle t
387
+
388
+
val mailbox_set :
389
+
account_id:Jmap_proto.Id.t ->
390
+
?if_in_state:string ->
391
+
?create:(string * Jsont.Json.t) list ->
392
+
?update:(Jmap_proto.Id.t * Jsont.Json.t) list ->
393
+
?destroy:id_source ->
394
+
?on_destroy_remove_emails:bool ->
395
+
unit ->
396
+
(set, Jmap_proto.Mailbox.t Jmap_proto.Method.set_response) handle t
397
+
398
+
(** {2 Identity Methods} *)
399
+
400
+
val identity_get :
401
+
account_id:Jmap_proto.Id.t ->
402
+
?ids:id_source ->
403
+
?properties:string list ->
404
+
unit ->
405
+
(get, Jmap_proto.Identity.t Jmap_proto.Method.get_response) handle t
406
+
407
+
val identity_changes :
408
+
account_id:Jmap_proto.Id.t ->
409
+
since_state:string ->
410
+
?max_changes:int64 ->
411
+
unit ->
412
+
(changes, Jmap_proto.Method.changes_response) handle t
413
+
414
+
val identity_set :
415
+
account_id:Jmap_proto.Id.t ->
416
+
?if_in_state:string ->
417
+
?create:(string * Jsont.Json.t) list ->
418
+
?update:(Jmap_proto.Id.t * Jsont.Json.t) list ->
419
+
?destroy:id_source ->
420
+
unit ->
421
+
(set, Jmap_proto.Identity.t Jmap_proto.Method.set_response) handle t
422
+
423
+
(** {2 EmailSubmission Methods} *)
424
+
425
+
val email_submission_query :
426
+
account_id:Jmap_proto.Id.t ->
427
+
?filter:Jmap_proto.Mail_filter.submission_filter ->
428
+
?sort:Jmap_proto.Filter.comparator list ->
429
+
?position:int64 ->
430
+
?anchor:Jmap_proto.Id.t ->
431
+
?anchor_offset:int64 ->
432
+
?limit:int64 ->
433
+
?calculate_total:bool ->
434
+
unit ->
435
+
(query, Jmap_proto.Method.query_response) handle t
436
+
437
+
val email_submission_get :
438
+
account_id:Jmap_proto.Id.t ->
439
+
?ids:id_source ->
440
+
?properties:string list ->
441
+
unit ->
442
+
(get, Jmap_proto.Submission.t Jmap_proto.Method.get_response) handle t
443
+
444
+
val email_submission_changes :
445
+
account_id:Jmap_proto.Id.t ->
446
+
since_state:string ->
447
+
?max_changes:int64 ->
448
+
unit ->
449
+
(changes, Jmap_proto.Method.changes_response) handle t
450
+
451
+
val email_submission_query_changes :
452
+
account_id:Jmap_proto.Id.t ->
453
+
since_query_state:string ->
454
+
?filter:Jmap_proto.Mail_filter.submission_filter ->
455
+
?sort:Jmap_proto.Filter.comparator list ->
456
+
?max_changes:int64 ->
457
+
?up_to_id:Jmap_proto.Id.t ->
458
+
?calculate_total:bool ->
459
+
unit ->
460
+
(query_changes, Jmap_proto.Method.query_changes_response) handle t
461
+
462
+
val email_submission_set :
463
+
account_id:Jmap_proto.Id.t ->
464
+
?if_in_state:string ->
465
+
?create:(string * Jsont.Json.t) list ->
466
+
?update:(Jmap_proto.Id.t * Jsont.Json.t) list ->
467
+
?destroy:id_source ->
468
+
?on_success_update_email:(string * Jsont.Json.t) list ->
469
+
?on_success_destroy_email:string list ->
470
+
unit ->
471
+
(set, Jmap_proto.Submission.t Jmap_proto.Method.set_response) handle t
472
+
(** Build an EmailSubmission/set invocation.
473
+
474
+
[on_success_update_email] and [on_success_destroy_email] take creation IDs
475
+
(like ["#draft1"]) or real email IDs to update/destroy the email after
476
+
successful submission. *)
477
+
478
+
(** {2 SearchSnippet Methods} *)
479
+
480
+
val search_snippet_get :
481
+
account_id:Jmap_proto.Id.t ->
482
+
filter:Jmap_proto.Mail_filter.email_filter ->
483
+
email_ids:id_source ->
484
+
unit ->
485
+
(get, Jmap_proto.Search_snippet.t Jmap_proto.Method.get_response) handle t
486
+
(** Build a SearchSnippet/get invocation. Note that the filter must match
487
+
the filter used in the Email/query that produced the email IDs. *)
488
+
489
+
(** {2 VacationResponse Methods} *)
490
+
491
+
val vacation_response_get :
492
+
account_id:Jmap_proto.Id.t ->
493
+
?properties:string list ->
494
+
unit ->
495
+
(get, Jmap_proto.Vacation.t Jmap_proto.Method.get_response) handle t
496
+
497
+
val vacation_response_set :
498
+
account_id:Jmap_proto.Id.t ->
499
+
?if_in_state:string ->
500
+
update:Jsont.Json.t ->
501
+
unit ->
502
+
(set, Jmap_proto.Vacation.t Jmap_proto.Method.set_response) handle t
503
+
(** VacationResponse is a singleton - you can only update "singleton". *)
504
+
505
+
(** {1 Response Parsing} *)
506
+
507
+
val parse :
508
+
(_, 'resp) handle ->
509
+
Jmap_proto.Response.t ->
510
+
('resp, Jsont.Error.t) result
511
+
(** [parse handle response] extracts and parses the response for [handle].
512
+
513
+
The response type is determined by the handle's type parameter,
514
+
providing compile-time type safety. *)
515
+
516
+
val parse_exn : (_, 'resp) handle -> Jmap_proto.Response.t -> 'resp
517
+
(** [parse_exn handle response] is like {!parse} but raises on error. *)
518
+
519
+
(** {1 JSON Helpers}
520
+
521
+
Convenience functions for building JSON patch objects for /set methods. *)
522
+
523
+
val json_null : Jsont.Json.t
524
+
(** A JSON null value. Use to unset a property. *)
525
+
526
+
val json_bool : bool -> Jsont.Json.t
527
+
(** [json_bool b] creates a JSON boolean. *)
528
+
529
+
val json_string : string -> Jsont.Json.t
530
+
(** [json_string s] creates a JSON string. *)
531
+
532
+
val json_int : int64 -> Jsont.Json.t
533
+
(** [json_int n] creates a JSON number from an int64. *)
534
+
535
+
val json_obj : (string * Jsont.Json.t) list -> Jsont.Json.t
536
+
(** [json_obj fields] creates a JSON object from key-value pairs. *)
537
+
538
+
val json_array : Jsont.Json.t list -> Jsont.Json.t
539
+
(** [json_array items] creates a JSON array. *)
540
+
541
+
(** {1 Creation ID Helpers} *)
542
+
543
+
val fresh_create_id : unit -> 'a create_id t
544
+
(** [fresh_create_id ()] generates a fresh creation ID within the chain.
545
+
The ID is unique within the request. *)
546
+
547
+
(** {1 Low-Level Access}
548
+
549
+
For users who need direct access to the underlying invocation. *)
550
+
551
+
val raw_invocation :
552
+
name:string ->
553
+
arguments:Jsont.Json.t ->
554
+
(unit, Jsont.Json.t) handle t
555
+
(** [raw_invocation ~name ~arguments] adds a raw method invocation.
556
+
Use this for methods not yet supported by the high-level API. *)
+446
lib/core/jmap.ml
+446
lib/core/jmap.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Unified JMAP interface for OCaml
7
+
8
+
This module provides a clean, ergonomic API for working with JMAP
9
+
(RFC 8620/8621), combining the protocol and mail layers with abstract
10
+
types and polymorphic variants.
11
+
12
+
{2 Quick Start}
13
+
14
+
{[
15
+
open Jmap
16
+
17
+
(* Keywords use polymorphic variants *)
18
+
let is_unread email =
19
+
not (List.mem `Seen (Email.keywords email))
20
+
21
+
(* Mailbox roles are also polymorphic *)
22
+
let find_inbox mailboxes =
23
+
List.find_opt (fun m -> Mailbox.role m = Some `Inbox) mailboxes
24
+
]}
25
+
26
+
{2 Module Structure}
27
+
28
+
- {!Proto} - Low-level protocol and mail types (RFC 8620/8621)
29
+
- {!Error}, {!Id}, {!Keyword}, {!Role}, {!Capability} - Core types
30
+
- {!Session}, {!Email}, {!Mailbox}, etc. - Abstract type accessors
31
+
*)
32
+
33
+
(** {1 Protocol Layer Re-exports} *)
34
+
35
+
(** Low-level JMAP protocol types (RFC 8620/8621).
36
+
37
+
These are the raw protocol and mail types. For most use cases, prefer the
38
+
higher-level types in this module. *)
39
+
module Proto = Jmap_proto
40
+
41
+
(** {1 Core Types} *)
42
+
43
+
(** Unified error type for JMAP operations.
44
+
45
+
All errors from JSON parsing, HTTP, session management, and JMAP method
46
+
calls are represented as polymorphic variants. *)
47
+
module Error = Jmap_types.Error
48
+
49
+
(** JMAP identifier type.
50
+
51
+
Identifiers are opaque strings assigned by the server. *)
52
+
module Id = Jmap_types.Id
53
+
54
+
(** Email keyword type.
55
+
56
+
Standard keywords are represented as polymorphic variants.
57
+
Custom keywords use [`Custom of string]. *)
58
+
module Keyword = Jmap_types.Keyword
59
+
60
+
(** Mailbox role type.
61
+
62
+
Standard roles are represented as polymorphic variants.
63
+
Custom roles use [`Custom of string]. *)
64
+
module Role = Jmap_types.Role
65
+
66
+
(** JMAP capability type.
67
+
68
+
Standard capabilities are represented as polymorphic variants.
69
+
Custom capabilities use [`Custom of string]. *)
70
+
module Capability = Jmap_types.Capability
71
+
72
+
(** {1 Session Types} *)
73
+
74
+
(** JMAP session information.
75
+
76
+
The session contains server capabilities, account information,
77
+
and API endpoint URLs. *)
78
+
module Session = struct
79
+
(** Account information. *)
80
+
module Account = struct
81
+
type t = Jmap_types.account
82
+
83
+
let name a = Proto.Session.Account.name a
84
+
let is_personal a = Proto.Session.Account.is_personal a
85
+
let is_read_only a = Proto.Session.Account.is_read_only a
86
+
end
87
+
88
+
type t = Jmap_types.session
89
+
90
+
let capabilities s = Proto.Session.capabilities s
91
+
let accounts s = Proto.Session.accounts s
92
+
let primary_accounts s = Proto.Session.primary_accounts s
93
+
let username s = Proto.Session.username s
94
+
let api_url s = Proto.Session.api_url s
95
+
let download_url s = Proto.Session.download_url s
96
+
let upload_url s = Proto.Session.upload_url s
97
+
let event_source_url s = Proto.Session.event_source_url s
98
+
let state s = Proto.Session.state s
99
+
100
+
let get_account id s = Proto.Session.get_account id s
101
+
let primary_account_for cap s = Proto.Session.primary_account_for cap s
102
+
let has_capability uri s = Proto.Session.has_capability uri s
103
+
end
104
+
105
+
(** {1 Mail Types} *)
106
+
107
+
(** Email address with optional display name. *)
108
+
module Email_address = struct
109
+
type t = Jmap_types.email_address
110
+
111
+
let name a = Proto.Email_address.name a
112
+
let email a = Proto.Email_address.email a
113
+
114
+
let create ?name email =
115
+
Proto.Email_address.create ?name email
116
+
end
117
+
118
+
(** Email mailbox. *)
119
+
module Mailbox = struct
120
+
type t = Jmap_types.mailbox
121
+
122
+
let id m = Proto.Mailbox.id m
123
+
let name m = Proto.Mailbox.name m
124
+
let parent_id m = Proto.Mailbox.parent_id m
125
+
let sort_order m = Proto.Mailbox.sort_order m
126
+
let total_emails m = Proto.Mailbox.total_emails m
127
+
let unread_emails m = Proto.Mailbox.unread_emails m
128
+
let total_threads m = Proto.Mailbox.total_threads m
129
+
let unread_threads m = Proto.Mailbox.unread_threads m
130
+
let is_subscribed m = Proto.Mailbox.is_subscribed m
131
+
132
+
let role m =
133
+
(* Proto.Mailbox.role now returns polymorphic variants directly *)
134
+
let convert_role : Proto.Mailbox.role -> Role.t = function
135
+
| `Inbox -> `Inbox
136
+
| `Sent -> `Sent
137
+
| `Drafts -> `Drafts
138
+
| `Trash -> `Trash
139
+
| `Junk -> `Junk
140
+
| `Archive -> `Archive
141
+
| `Flagged -> `Flagged
142
+
| `Important -> `Important
143
+
| `All -> `All
144
+
| `Subscribed -> `Subscribed
145
+
| `Snoozed -> `Snoozed
146
+
| `Scheduled -> `Scheduled
147
+
| `Memos -> `Memos
148
+
| `Other s -> `Custom s
149
+
in
150
+
Option.map convert_role (Proto.Mailbox.role m)
151
+
152
+
(** Mailbox rights. *)
153
+
module Rights = struct
154
+
type t = Proto.Mailbox.Rights.t
155
+
156
+
let may_read_items r = Proto.Mailbox.Rights.may_read_items r
157
+
let may_add_items r = Proto.Mailbox.Rights.may_add_items r
158
+
let may_remove_items r = Proto.Mailbox.Rights.may_remove_items r
159
+
let may_set_seen r = Proto.Mailbox.Rights.may_set_seen r
160
+
let may_set_keywords r = Proto.Mailbox.Rights.may_set_keywords r
161
+
let may_create_child r = Proto.Mailbox.Rights.may_create_child r
162
+
let may_rename r = Proto.Mailbox.Rights.may_rename r
163
+
let may_delete r = Proto.Mailbox.Rights.may_delete r
164
+
let may_submit r = Proto.Mailbox.Rights.may_submit r
165
+
end
166
+
167
+
let my_rights m = Proto.Mailbox.my_rights m
168
+
end
169
+
170
+
(** Email thread. *)
171
+
module Thread = struct
172
+
type t = Jmap_types.thread
173
+
174
+
let id t = Proto.Thread.id t
175
+
let email_ids t = Proto.Thread.email_ids t
176
+
end
177
+
178
+
(** Email message. *)
179
+
module Email = struct
180
+
(** Email body part. *)
181
+
module Body = struct
182
+
type part = Proto.Email_body.Part.t
183
+
type value = Proto.Email_body.Value.t
184
+
185
+
let part_id p = Proto.Email_body.Part.part_id p
186
+
let blob_id p = Proto.Email_body.Part.blob_id p
187
+
let size p = Proto.Email_body.Part.size p
188
+
let name p = Proto.Email_body.Part.name p
189
+
let type_ p = Proto.Email_body.Part.type_ p
190
+
let charset p = Proto.Email_body.Part.charset p
191
+
let disposition p = Proto.Email_body.Part.disposition p
192
+
let cid p = Proto.Email_body.Part.cid p
193
+
let language p = Proto.Email_body.Part.language p
194
+
let location p = Proto.Email_body.Part.location p
195
+
196
+
let value_text v = Proto.Email_body.Value.value v
197
+
let value_is_truncated v = Proto.Email_body.Value.is_truncated v
198
+
let value_is_encoding_problem v = Proto.Email_body.Value.is_encoding_problem v
199
+
end
200
+
201
+
type t = Jmap_types.email
202
+
203
+
let id e = Proto.Email.id e
204
+
let blob_id e = Proto.Email.blob_id e
205
+
let thread_id e = Proto.Email.thread_id e
206
+
let mailbox_ids e = Proto.Email.mailbox_ids e
207
+
let size e = Proto.Email.size e
208
+
let received_at e = Proto.Email.received_at e
209
+
let message_id e = Proto.Email.message_id e
210
+
let in_reply_to e = Proto.Email.in_reply_to e
211
+
let references e = Proto.Email.references e
212
+
let subject e = Proto.Email.subject e
213
+
let sent_at e = Proto.Email.sent_at e
214
+
let has_attachment e = Proto.Email.has_attachment e
215
+
let preview e = Proto.Email.preview e
216
+
217
+
(** Get active keywords as polymorphic variants. *)
218
+
let keywords e =
219
+
match Proto.Email.keywords e with
220
+
| None -> []
221
+
| Some kw_map ->
222
+
List.filter_map (fun (k, v) ->
223
+
if v then Some (Keyword.of_string k) else None
224
+
) kw_map
225
+
226
+
(** Check if email has a specific keyword. *)
227
+
let has_keyword kw e =
228
+
let kw_str = Keyword.to_string kw in
229
+
match Proto.Email.keywords e with
230
+
| None -> false
231
+
| Some kw_map -> List.exists (fun (k, v) -> k = kw_str && v) kw_map
232
+
233
+
let from e = Proto.Email.from e
234
+
let to_ e = Proto.Email.to_ e
235
+
let cc e = Proto.Email.cc e
236
+
let bcc e = Proto.Email.bcc e
237
+
let reply_to e = Proto.Email.reply_to e
238
+
let sender e = Proto.Email.sender e
239
+
240
+
let text_body e = Proto.Email.text_body e
241
+
let html_body e = Proto.Email.html_body e
242
+
let attachments e = Proto.Email.attachments e
243
+
let body_values e = Proto.Email.body_values e
244
+
end
245
+
246
+
(** Email identity for sending. *)
247
+
module Identity = struct
248
+
type t = Jmap_types.identity
249
+
250
+
let id i = Proto.Identity.id i
251
+
let name i = Proto.Identity.name i
252
+
let email i = Proto.Identity.email i
253
+
let reply_to i = Proto.Identity.reply_to i
254
+
let bcc i = Proto.Identity.bcc i
255
+
let text_signature i = Proto.Identity.text_signature i
256
+
let html_signature i = Proto.Identity.html_signature i
257
+
let may_delete i = Proto.Identity.may_delete i
258
+
end
259
+
260
+
(** Email submission for outgoing mail. *)
261
+
module Submission = struct
262
+
type t = Jmap_types.submission
263
+
264
+
let id s = Proto.Submission.id s
265
+
let identity_id s = Proto.Submission.identity_id s
266
+
let email_id s = Proto.Submission.email_id s
267
+
let thread_id s = Proto.Submission.thread_id s
268
+
let send_at s = Proto.Submission.send_at s
269
+
let undo_status s = Proto.Submission.undo_status s
270
+
let delivery_status s = Proto.Submission.delivery_status s
271
+
let dsn_blob_ids s = Proto.Submission.dsn_blob_ids s
272
+
let mdn_blob_ids s = Proto.Submission.mdn_blob_ids s
273
+
end
274
+
275
+
(** Vacation auto-response. *)
276
+
module Vacation = struct
277
+
type t = Jmap_types.vacation
278
+
279
+
let id v = Proto.Vacation.id v
280
+
let is_enabled v = Proto.Vacation.is_enabled v
281
+
let from_date v = Proto.Vacation.from_date v
282
+
let to_date v = Proto.Vacation.to_date v
283
+
let subject v = Proto.Vacation.subject v
284
+
let text_body v = Proto.Vacation.text_body v
285
+
let html_body v = Proto.Vacation.html_body v
286
+
end
287
+
288
+
(** Search snippet with highlighted matches. *)
289
+
module Search_snippet = struct
290
+
type t = Jmap_types.search_snippet
291
+
292
+
let email_id s = Proto.Search_snippet.email_id s
293
+
let subject s = Proto.Search_snippet.subject s
294
+
let preview s = Proto.Search_snippet.preview s
295
+
end
296
+
297
+
(** {1 Filter Types} *)
298
+
299
+
(** Email filter conditions for queries. *)
300
+
module Email_filter = struct
301
+
type condition = Proto.Email.Filter_condition.t
302
+
303
+
(** Create an email filter condition.
304
+
305
+
All parameters are optional. Omitted parameters are not included
306
+
in the filter. Use [make ()] for an empty filter. *)
307
+
let make
308
+
?in_mailbox
309
+
?in_mailbox_other_than
310
+
?before
311
+
?after
312
+
?min_size
313
+
?max_size
314
+
?(all_in_thread_have_keyword : Keyword.t option)
315
+
?(some_in_thread_have_keyword : Keyword.t option)
316
+
?(none_in_thread_have_keyword : Keyword.t option)
317
+
?(has_keyword : Keyword.t option)
318
+
?(not_keyword : Keyword.t option)
319
+
?has_attachment
320
+
?text
321
+
?from
322
+
?to_
323
+
?cc
324
+
?bcc
325
+
?subject
326
+
?body
327
+
?header
328
+
() : condition =
329
+
{
330
+
in_mailbox;
331
+
in_mailbox_other_than;
332
+
before;
333
+
after;
334
+
min_size;
335
+
max_size;
336
+
all_in_thread_have_keyword = Option.map Keyword.to_string all_in_thread_have_keyword;
337
+
some_in_thread_have_keyword = Option.map Keyword.to_string some_in_thread_have_keyword;
338
+
none_in_thread_have_keyword = Option.map Keyword.to_string none_in_thread_have_keyword;
339
+
has_keyword = Option.map Keyword.to_string has_keyword;
340
+
not_keyword = Option.map Keyword.to_string not_keyword;
341
+
has_attachment;
342
+
text;
343
+
from;
344
+
to_;
345
+
cc;
346
+
bcc;
347
+
subject;
348
+
body;
349
+
header;
350
+
}
351
+
end
352
+
353
+
(** Mailbox filter conditions for queries. *)
354
+
module Mailbox_filter = struct
355
+
type condition = Proto.Mailbox.Filter_condition.t
356
+
357
+
let convert_role : Role.t -> Proto.Mailbox.role = function
358
+
| `Inbox -> `Inbox
359
+
| `Sent -> `Sent
360
+
| `Drafts -> `Drafts
361
+
| `Trash -> `Trash
362
+
| `Junk -> `Junk
363
+
| `Archive -> `Archive
364
+
| `Flagged -> `Flagged
365
+
| `Important -> `Important
366
+
| `All -> `All
367
+
| `Subscribed -> `Subscribed
368
+
| `Snoozed -> `Snoozed
369
+
| `Scheduled -> `Scheduled
370
+
| `Memos -> `Memos
371
+
| `Custom s -> `Other s
372
+
373
+
(** Create a mailbox filter condition.
374
+
375
+
All parameters are optional.
376
+
For [role]: [Some (Some r)] filters by role [r], [Some None] filters for
377
+
mailboxes with no role, [None] doesn't filter by role. *)
378
+
let make
379
+
?parent_id
380
+
?name
381
+
?role
382
+
?has_any_role
383
+
?is_subscribed
384
+
() : condition =
385
+
{
386
+
parent_id;
387
+
name;
388
+
role = Option.map (Option.map convert_role) role;
389
+
has_any_role;
390
+
is_subscribed;
391
+
}
392
+
end
393
+
394
+
(** {1 Response Types} *)
395
+
396
+
(** Generic /get response wrapper. *)
397
+
module Get_response = struct
398
+
type 'a t = 'a Proto.Method.get_response
399
+
400
+
let account_id (r : 'a t) = r.Proto.Method.account_id
401
+
let state (r : 'a t) = r.Proto.Method.state
402
+
let list (r : 'a t) = r.Proto.Method.list
403
+
let not_found (r : 'a t) = r.Proto.Method.not_found
404
+
end
405
+
406
+
(** Query response. *)
407
+
module Query_response = struct
408
+
type t = Proto.Method.query_response
409
+
410
+
let account_id (r : t) = r.Proto.Method.account_id
411
+
let query_state (r : t) = r.Proto.Method.query_state
412
+
let can_calculate_changes (r : t) = r.Proto.Method.can_calculate_changes
413
+
let position (r : t) = r.Proto.Method.position
414
+
let ids (r : t) = r.Proto.Method.ids
415
+
let total (r : t) = r.Proto.Method.total
416
+
end
417
+
418
+
(** Changes response. *)
419
+
module Changes_response = struct
420
+
type t = Proto.Method.changes_response
421
+
422
+
let account_id (r : t) = r.Proto.Method.account_id
423
+
let old_state (r : t) = r.Proto.Method.old_state
424
+
let new_state (r : t) = r.Proto.Method.new_state
425
+
let has_more_changes (r : t) = r.Proto.Method.has_more_changes
426
+
let created (r : t) = r.Proto.Method.created
427
+
let updated (r : t) = r.Proto.Method.updated
428
+
let destroyed (r : t) = r.Proto.Method.destroyed
429
+
end
430
+
431
+
(** {1 JSONABLE Interface} *)
432
+
433
+
(** Module type for types that can be serialized to/from JSON bytes. *)
434
+
module type JSONABLE = sig
435
+
type t
436
+
437
+
val of_string : string -> (t, Error.t) result
438
+
val to_string : t -> (string, Error.t) result
439
+
end
440
+
441
+
(** {1 Request Chaining} *)
442
+
443
+
(** JMAP method chaining with automatic result references.
444
+
445
+
See {!Chain} for the full interface. *)
446
+
module Chain = Chain
+532
lib/core/jmap.mli
+532
lib/core/jmap.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Unified JMAP interface for OCaml
7
+
8
+
This module provides a clean, ergonomic API for working with JMAP
9
+
(RFC 8620/8621), combining the protocol and mail layers with abstract
10
+
types and polymorphic variants.
11
+
12
+
{2 Quick Start}
13
+
14
+
{[
15
+
open Jmap
16
+
17
+
(* Keywords use polymorphic variants *)
18
+
let is_unread email =
19
+
not (List.mem `Seen (Email.keywords email))
20
+
21
+
(* Mailbox roles are also polymorphic *)
22
+
let find_inbox mailboxes =
23
+
List.find_opt (fun m -> Mailbox.role m = Some `Inbox) mailboxes
24
+
]}
25
+
26
+
{2 Module Structure}
27
+
28
+
- {!Proto} - Low-level protocol and mail types (RFC 8620/8621)
29
+
- {!Error}, {!Id}, {!Keyword}, {!Role}, {!Capability} - Core types
30
+
- {!Session}, {!Email}, {!Mailbox}, etc. - Abstract type accessors
31
+
*)
32
+
33
+
(** {1 Protocol Layer Re-exports} *)
34
+
35
+
(** Low-level JMAP protocol types (RFC 8620/8621).
36
+
37
+
These are the raw protocol and mail types. For most use cases, prefer the
38
+
higher-level types in this module. *)
39
+
module Proto = Jmap_proto
40
+
41
+
(** {1 Core Types} *)
42
+
43
+
(** Unified error type for JMAP operations. *)
44
+
module Error : sig
45
+
(** Request-level error (RFC 7807 Problem Details). *)
46
+
type request = {
47
+
type_ : string;
48
+
status : int option;
49
+
title : string option;
50
+
detail : string option;
51
+
limit : string option;
52
+
}
53
+
54
+
(** Method-level error. *)
55
+
type method_ = {
56
+
type_ : string;
57
+
description : string option;
58
+
}
59
+
60
+
(** Set operation error for a specific object. *)
61
+
type set = {
62
+
type_ : string;
63
+
description : string option;
64
+
properties : string list option;
65
+
}
66
+
67
+
(** Unified error type.
68
+
69
+
All errors from JSON parsing, HTTP, session management, and JMAP method
70
+
calls are represented as polymorphic variants. *)
71
+
type t = [
72
+
| `Request of request
73
+
| `Method of method_
74
+
| `Set of string * set
75
+
| `Json of string
76
+
| `Http of int * string
77
+
| `Connection of string
78
+
| `Session of string
79
+
]
80
+
81
+
val pp : Format.formatter -> t -> unit
82
+
val to_string : t -> string
83
+
end
84
+
85
+
(** JMAP identifier type. *)
86
+
module Id : sig
87
+
type t
88
+
89
+
val of_string : string -> (t, string) result
90
+
val of_string_exn : string -> t
91
+
val to_string : t -> string
92
+
val compare : t -> t -> int
93
+
val equal : t -> t -> bool
94
+
val pp : Format.formatter -> t -> unit
95
+
end
96
+
97
+
(** Email keyword type.
98
+
99
+
Standard keywords are represented as polymorphic variants.
100
+
Custom keywords use [`Custom of string]. *)
101
+
module Keyword : sig
102
+
(** RFC 8621 standard keywords *)
103
+
type standard = [
104
+
| `Seen
105
+
| `Flagged
106
+
| `Answered
107
+
| `Draft
108
+
| `Forwarded
109
+
| `Phishing
110
+
| `Junk
111
+
| `NotJunk
112
+
]
113
+
114
+
(** draft-ietf-mailmaint extended keywords *)
115
+
type extended = [
116
+
| `Notify
117
+
| `Muted
118
+
| `Followed
119
+
| `Memo
120
+
| `HasMemo
121
+
| `HasAttachment
122
+
| `HasNoAttachment
123
+
| `AutoSent
124
+
| `Unsubscribed
125
+
| `CanUnsubscribe
126
+
| `Imported
127
+
| `IsTrusted
128
+
| `MaskedEmail
129
+
| `New
130
+
]
131
+
132
+
(** Apple Mail flag color keywords *)
133
+
type flag_bits = [
134
+
| `MailFlagBit0
135
+
| `MailFlagBit1
136
+
| `MailFlagBit2
137
+
]
138
+
139
+
type t = [
140
+
| standard
141
+
| extended
142
+
| flag_bits
143
+
| `Custom of string
144
+
]
145
+
146
+
val of_string : string -> t
147
+
val to_string : t -> string
148
+
val pp : Format.formatter -> t -> unit
149
+
150
+
(** Apple Mail flag colors *)
151
+
type flag_color = [
152
+
| `Red
153
+
| `Orange
154
+
| `Yellow
155
+
| `Green
156
+
| `Blue
157
+
| `Purple
158
+
| `Gray
159
+
]
160
+
161
+
val flag_color_of_keywords : t list -> flag_color option
162
+
(** [flag_color_of_keywords keywords] extracts the flag color from a list
163
+
of keywords. Returns [None] for invalid bit combinations. *)
164
+
165
+
val flag_color_to_keywords : flag_color -> t list
166
+
(** [flag_color_to_keywords color] returns the keywords to set for the color. *)
167
+
end
168
+
169
+
(** Mailbox role type.
170
+
171
+
Standard roles are represented as polymorphic variants.
172
+
Custom roles use [`Custom of string]. *)
173
+
module Role : sig
174
+
(** RFC 8621 standard roles *)
175
+
type standard = [
176
+
| `Inbox
177
+
| `Sent
178
+
| `Drafts
179
+
| `Trash
180
+
| `Junk
181
+
| `Archive
182
+
| `Flagged
183
+
| `Important
184
+
| `All
185
+
| `Subscribed
186
+
]
187
+
188
+
(** draft-ietf-mailmaint extended roles *)
189
+
type extended = [
190
+
| `Snoozed
191
+
| `Scheduled
192
+
| `Memos
193
+
]
194
+
195
+
type t = [
196
+
| standard
197
+
| extended
198
+
| `Custom of string
199
+
]
200
+
201
+
val of_string : string -> t
202
+
val to_string : t -> string
203
+
val pp : Format.formatter -> t -> unit
204
+
end
205
+
206
+
(** JMAP capability type.
207
+
208
+
Standard capabilities are represented as polymorphic variants.
209
+
Custom capabilities use [`Custom of string]. *)
210
+
module Capability : sig
211
+
type t = [
212
+
| `Core
213
+
| `Mail
214
+
| `Submission
215
+
| `VacationResponse
216
+
| `Custom of string
217
+
]
218
+
219
+
val core_uri : string
220
+
val mail_uri : string
221
+
val submission_uri : string
222
+
val vacation_uri : string
223
+
224
+
val of_string : string -> t
225
+
val to_string : t -> string
226
+
val pp : Format.formatter -> t -> unit
227
+
end
228
+
229
+
(** {1 Session Types} *)
230
+
231
+
(** JMAP session information. *)
232
+
module Session : sig
233
+
(** Account information. *)
234
+
module Account : sig
235
+
type t
236
+
237
+
val name : t -> string
238
+
val is_personal : t -> bool
239
+
val is_read_only : t -> bool
240
+
end
241
+
242
+
type t
243
+
244
+
val capabilities : t -> (string * Jsont.json) list
245
+
val accounts : t -> (Id.t * Account.t) list
246
+
val primary_accounts : t -> (string * Id.t) list
247
+
val username : t -> string
248
+
val api_url : t -> string
249
+
val download_url : t -> string
250
+
val upload_url : t -> string
251
+
val event_source_url : t -> string
252
+
val state : t -> string
253
+
254
+
val get_account : Id.t -> t -> Account.t option
255
+
val primary_account_for : string -> t -> Id.t option
256
+
val has_capability : string -> t -> bool
257
+
end
258
+
259
+
(** {1 Mail Types} *)
260
+
261
+
(** Email address with optional display name. *)
262
+
module Email_address : sig
263
+
type t
264
+
265
+
val name : t -> string option
266
+
val email : t -> string
267
+
val create : ?name:string -> string -> t
268
+
end
269
+
270
+
(** Email mailbox.
271
+
All accessors return option types since responses only include requested properties. *)
272
+
module Mailbox : sig
273
+
type t
274
+
275
+
val id : t -> Id.t option
276
+
val name : t -> string option
277
+
val parent_id : t -> Id.t option
278
+
val sort_order : t -> int64 option
279
+
val total_emails : t -> int64 option
280
+
val unread_emails : t -> int64 option
281
+
val total_threads : t -> int64 option
282
+
val unread_threads : t -> int64 option
283
+
val is_subscribed : t -> bool option
284
+
val role : t -> Role.t option
285
+
286
+
(** Mailbox rights. *)
287
+
module Rights : sig
288
+
type t
289
+
290
+
val may_read_items : t -> bool
291
+
val may_add_items : t -> bool
292
+
val may_remove_items : t -> bool
293
+
val may_set_seen : t -> bool
294
+
val may_set_keywords : t -> bool
295
+
val may_create_child : t -> bool
296
+
val may_rename : t -> bool
297
+
val may_delete : t -> bool
298
+
val may_submit : t -> bool
299
+
end
300
+
301
+
val my_rights : t -> Rights.t option
302
+
end
303
+
304
+
(** Email thread.
305
+
All accessors return option types since responses only include requested properties. *)
306
+
module Thread : sig
307
+
type t
308
+
309
+
val id : t -> Id.t option
310
+
val email_ids : t -> Id.t list option
311
+
end
312
+
313
+
(** Email message. *)
314
+
module Email : sig
315
+
(** Email body part. *)
316
+
module Body : sig
317
+
type part
318
+
type value
319
+
320
+
val part_id : part -> string option
321
+
val blob_id : part -> Id.t option
322
+
val size : part -> int64 option
323
+
val name : part -> string option
324
+
val type_ : part -> string
325
+
val charset : part -> string option
326
+
val disposition : part -> string option
327
+
val cid : part -> string option
328
+
val language : part -> string list option
329
+
val location : part -> string option
330
+
331
+
val value_text : value -> string
332
+
val value_is_truncated : value -> bool
333
+
val value_is_encoding_problem : value -> bool
334
+
end
335
+
336
+
(** All accessors return option types since responses only include requested properties. *)
337
+
type t
338
+
339
+
val id : t -> Id.t option
340
+
val blob_id : t -> Id.t option
341
+
val thread_id : t -> Id.t option
342
+
val mailbox_ids : t -> (Id.t * bool) list option
343
+
val size : t -> int64 option
344
+
val received_at : t -> Ptime.t option
345
+
val message_id : t -> string list option
346
+
val in_reply_to : t -> string list option
347
+
val references : t -> string list option
348
+
val subject : t -> string option
349
+
val sent_at : t -> Ptime.t option
350
+
val has_attachment : t -> bool option
351
+
val preview : t -> string option
352
+
353
+
(** Get active keywords as polymorphic variants.
354
+
Returns empty list if keywords property was not requested. *)
355
+
val keywords : t -> Keyword.t list
356
+
357
+
(** Check if email has a specific keyword.
358
+
Returns false if keywords property was not requested. *)
359
+
val has_keyword : Keyword.t -> t -> bool
360
+
361
+
val from : t -> Email_address.t list option
362
+
val to_ : t -> Email_address.t list option
363
+
val cc : t -> Email_address.t list option
364
+
val bcc : t -> Email_address.t list option
365
+
val reply_to : t -> Email_address.t list option
366
+
val sender : t -> Email_address.t list option
367
+
368
+
val text_body : t -> Body.part list option
369
+
val html_body : t -> Body.part list option
370
+
val attachments : t -> Body.part list option
371
+
val body_values : t -> (string * Body.value) list option
372
+
end
373
+
374
+
(** Email identity for sending.
375
+
All accessors return option types since responses only include requested properties. *)
376
+
module Identity : sig
377
+
type t
378
+
379
+
val id : t -> Id.t option
380
+
val name : t -> string option
381
+
val email : t -> string option
382
+
val reply_to : t -> Email_address.t list option
383
+
val bcc : t -> Email_address.t list option
384
+
val text_signature : t -> string option
385
+
val html_signature : t -> string option
386
+
val may_delete : t -> bool option
387
+
end
388
+
389
+
(** Email submission for outgoing mail.
390
+
All accessors return option types since responses only include requested properties. *)
391
+
module Submission : sig
392
+
type t
393
+
394
+
val id : t -> Id.t option
395
+
val identity_id : t -> Id.t option
396
+
val email_id : t -> Id.t option
397
+
val thread_id : t -> Id.t option
398
+
val send_at : t -> Ptime.t option
399
+
val undo_status : t -> Proto.Submission.undo_status option
400
+
val delivery_status : t -> (string * Proto.Submission.Delivery_status.t) list option
401
+
val dsn_blob_ids : t -> Id.t list option
402
+
val mdn_blob_ids : t -> Id.t list option
403
+
end
404
+
405
+
(** Vacation auto-response. *)
406
+
module Vacation : sig
407
+
type t
408
+
409
+
val id : t -> Id.t
410
+
val is_enabled : t -> bool
411
+
val from_date : t -> Ptime.t option
412
+
val to_date : t -> Ptime.t option
413
+
val subject : t -> string option
414
+
val text_body : t -> string option
415
+
val html_body : t -> string option
416
+
end
417
+
418
+
(** Search snippet with highlighted matches. *)
419
+
module Search_snippet : sig
420
+
type t
421
+
422
+
val email_id : t -> Id.t
423
+
val subject : t -> string option
424
+
val preview : t -> string option
425
+
end
426
+
427
+
(** {1 Filter Types} *)
428
+
429
+
(** Email filter conditions for queries. *)
430
+
module Email_filter : sig
431
+
type condition
432
+
433
+
(** Create an email filter condition.
434
+
435
+
All parameters are optional. Omitted parameters are not included
436
+
in the filter. Use [make ()] for an empty filter. *)
437
+
val make :
438
+
?in_mailbox:Id.t ->
439
+
?in_mailbox_other_than:Id.t list ->
440
+
?before:Ptime.t ->
441
+
?after:Ptime.t ->
442
+
?min_size:int64 ->
443
+
?max_size:int64 ->
444
+
?all_in_thread_have_keyword:Keyword.t ->
445
+
?some_in_thread_have_keyword:Keyword.t ->
446
+
?none_in_thread_have_keyword:Keyword.t ->
447
+
?has_keyword:Keyword.t ->
448
+
?not_keyword:Keyword.t ->
449
+
?has_attachment:bool ->
450
+
?text:string ->
451
+
?from:string ->
452
+
?to_:string ->
453
+
?cc:string ->
454
+
?bcc:string ->
455
+
?subject:string ->
456
+
?body:string ->
457
+
?header:(string * string option) ->
458
+
unit -> condition
459
+
end
460
+
461
+
(** Mailbox filter conditions for queries. *)
462
+
module Mailbox_filter : sig
463
+
type condition
464
+
465
+
(** Create a mailbox filter condition.
466
+
467
+
All parameters are optional.
468
+
For [role]: [Some (Some r)] filters by role [r], [Some None] filters for
469
+
mailboxes with no role, [None] doesn't filter by role. *)
470
+
val make :
471
+
?parent_id:Id.t option ->
472
+
?name:string ->
473
+
?role:Role.t option ->
474
+
?has_any_role:bool ->
475
+
?is_subscribed:bool ->
476
+
unit -> condition
477
+
end
478
+
479
+
(** {1 Response Types} *)
480
+
481
+
(** Generic /get response wrapper. *)
482
+
module Get_response : sig
483
+
type 'a t
484
+
485
+
val account_id : 'a t -> Id.t
486
+
val state : 'a t -> string
487
+
val list : 'a t -> 'a list
488
+
val not_found : 'a t -> Id.t list
489
+
end
490
+
491
+
(** Query response. *)
492
+
module Query_response : sig
493
+
type t
494
+
495
+
val account_id : t -> Id.t
496
+
val query_state : t -> string
497
+
val can_calculate_changes : t -> bool
498
+
val position : t -> int64
499
+
val ids : t -> Id.t list
500
+
val total : t -> int64 option
501
+
end
502
+
503
+
(** Changes response. *)
504
+
module Changes_response : sig
505
+
type t
506
+
507
+
val account_id : t -> Id.t
508
+
val old_state : t -> string
509
+
val new_state : t -> string
510
+
val has_more_changes : t -> bool
511
+
val created : t -> Id.t list
512
+
val updated : t -> Id.t list
513
+
val destroyed : t -> Id.t list
514
+
end
515
+
516
+
(** {1 JSONABLE Interface} *)
517
+
518
+
(** Module type for types that can be serialized to/from JSON bytes. *)
519
+
module type JSONABLE = sig
520
+
type t
521
+
522
+
val of_string : string -> (t, Error.t) result
523
+
val to_string : t -> (string, Error.t) result
524
+
end
525
+
526
+
(** {1 Request Chaining} *)
527
+
528
+
(** JMAP method chaining with automatic result references.
529
+
530
+
This module provides a monadic interface for building JMAP requests
531
+
where method calls can reference results from previous calls. *)
532
+
module Chain = Chain
+361
lib/core/jmap_types.ml
+361
lib/core/jmap_types.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Internal types for the unified Jmap interface *)
7
+
8
+
(** {1 Error Types} *)
9
+
10
+
module Error = struct
11
+
(** Request-level error (RFC 7807 Problem Details) *)
12
+
type request = {
13
+
type_ : string;
14
+
status : int option;
15
+
title : string option;
16
+
detail : string option;
17
+
limit : string option;
18
+
}
19
+
20
+
(** Method-level error *)
21
+
type method_ = {
22
+
type_ : string;
23
+
description : string option;
24
+
}
25
+
26
+
(** Set operation error for a specific object *)
27
+
type set = {
28
+
type_ : string;
29
+
description : string option;
30
+
properties : string list option;
31
+
}
32
+
33
+
(** Unified error type *)
34
+
type t = [
35
+
| `Request of request
36
+
| `Method of method_
37
+
| `Set of string * set
38
+
| `Json of string
39
+
| `Http of int * string
40
+
| `Connection of string
41
+
| `Session of string
42
+
]
43
+
44
+
let pp_request ppf (r : request) =
45
+
Format.fprintf ppf "Request error: %s" r.type_;
46
+
Option.iter (Format.fprintf ppf " (status %d)") r.status;
47
+
Option.iter (Format.fprintf ppf ": %s") r.detail
48
+
49
+
let pp_method ppf (m : method_) =
50
+
Format.fprintf ppf "Method error: %s" m.type_;
51
+
Option.iter (Format.fprintf ppf ": %s") m.description
52
+
53
+
let pp_set ppf (id, (s : set)) =
54
+
Format.fprintf ppf "Set error for %s: %s" id s.type_;
55
+
Option.iter (Format.fprintf ppf ": %s") s.description
56
+
57
+
let pp ppf = function
58
+
| `Request r -> pp_request ppf r
59
+
| `Method m -> pp_method ppf m
60
+
| `Set (id, s) -> pp_set ppf (id, s)
61
+
| `Json msg -> Format.fprintf ppf "JSON error: %s" msg
62
+
| `Http (code, msg) -> Format.fprintf ppf "HTTP error %d: %s" code msg
63
+
| `Connection msg -> Format.fprintf ppf "Connection error: %s" msg
64
+
| `Session msg -> Format.fprintf ppf "Session error: %s" msg
65
+
66
+
let to_string e = Format.asprintf "%a" pp e
67
+
end
68
+
69
+
(** {1 Identifier Type} *)
70
+
71
+
module Id = struct
72
+
type t = Jmap_proto.Id.t
73
+
74
+
let of_string s = Jmap_proto.Id.of_string s
75
+
let of_string_exn s = Jmap_proto.Id.of_string_exn s
76
+
let to_string = Jmap_proto.Id.to_string
77
+
let compare = Jmap_proto.Id.compare
78
+
let equal = Jmap_proto.Id.equal
79
+
let pp = Jmap_proto.Id.pp
80
+
end
81
+
82
+
(** {1 Keyword Type} *)
83
+
84
+
module Keyword = struct
85
+
(** RFC 8621 standard keywords *)
86
+
type standard = [
87
+
| `Seen
88
+
| `Flagged
89
+
| `Answered
90
+
| `Draft
91
+
| `Forwarded
92
+
| `Phishing
93
+
| `Junk
94
+
| `NotJunk
95
+
]
96
+
97
+
(** draft-ietf-mailmaint extended keywords *)
98
+
type extended = [
99
+
| `Notify
100
+
| `Muted
101
+
| `Followed
102
+
| `Memo
103
+
| `HasMemo
104
+
| `HasAttachment
105
+
| `HasNoAttachment
106
+
| `AutoSent
107
+
| `Unsubscribed
108
+
| `CanUnsubscribe
109
+
| `Imported
110
+
| `IsTrusted
111
+
| `MaskedEmail
112
+
| `New
113
+
]
114
+
115
+
(** Apple Mail flag color keywords *)
116
+
type flag_bits = [
117
+
| `MailFlagBit0
118
+
| `MailFlagBit1
119
+
| `MailFlagBit2
120
+
]
121
+
122
+
type t = [
123
+
| standard
124
+
| extended
125
+
| flag_bits
126
+
| `Custom of string
127
+
]
128
+
129
+
let of_string = function
130
+
(* RFC 8621 standard keywords *)
131
+
| "$seen" -> `Seen
132
+
| "$flagged" -> `Flagged
133
+
| "$answered" -> `Answered
134
+
| "$draft" -> `Draft
135
+
| "$forwarded" -> `Forwarded
136
+
| "$phishing" -> `Phishing
137
+
| "$junk" -> `Junk
138
+
| "$notjunk" -> `NotJunk
139
+
(* draft-ietf-mailmaint extended keywords *)
140
+
| "$notify" -> `Notify
141
+
| "$muted" -> `Muted
142
+
| "$followed" -> `Followed
143
+
| "$memo" -> `Memo
144
+
| "$hasmemo" -> `HasMemo
145
+
| "$hasattachment" -> `HasAttachment
146
+
| "$hasnoattachment" -> `HasNoAttachment
147
+
| "$autosent" -> `AutoSent
148
+
| "$unsubscribed" -> `Unsubscribed
149
+
| "$canunsubscribe" -> `CanUnsubscribe
150
+
| "$imported" -> `Imported
151
+
| "$istrusted" -> `IsTrusted
152
+
| "$maskedemail" -> `MaskedEmail
153
+
| "$new" -> `New
154
+
(* Apple Mail flag color keywords *)
155
+
| "$MailFlagBit0" -> `MailFlagBit0
156
+
| "$MailFlagBit1" -> `MailFlagBit1
157
+
| "$MailFlagBit2" -> `MailFlagBit2
158
+
| s -> `Custom s
159
+
160
+
let to_string = function
161
+
(* RFC 8621 standard keywords *)
162
+
| `Seen -> "$seen"
163
+
| `Flagged -> "$flagged"
164
+
| `Answered -> "$answered"
165
+
| `Draft -> "$draft"
166
+
| `Forwarded -> "$forwarded"
167
+
| `Phishing -> "$phishing"
168
+
| `Junk -> "$junk"
169
+
| `NotJunk -> "$notjunk"
170
+
(* draft-ietf-mailmaint extended keywords *)
171
+
| `Notify -> "$notify"
172
+
| `Muted -> "$muted"
173
+
| `Followed -> "$followed"
174
+
| `Memo -> "$memo"
175
+
| `HasMemo -> "$hasmemo"
176
+
| `HasAttachment -> "$hasattachment"
177
+
| `HasNoAttachment -> "$hasnoattachment"
178
+
| `AutoSent -> "$autosent"
179
+
| `Unsubscribed -> "$unsubscribed"
180
+
| `CanUnsubscribe -> "$canunsubscribe"
181
+
| `Imported -> "$imported"
182
+
| `IsTrusted -> "$istrusted"
183
+
| `MaskedEmail -> "$maskedemail"
184
+
| `New -> "$new"
185
+
(* Apple Mail flag color keywords *)
186
+
| `MailFlagBit0 -> "$MailFlagBit0"
187
+
| `MailFlagBit1 -> "$MailFlagBit1"
188
+
| `MailFlagBit2 -> "$MailFlagBit2"
189
+
| `Custom s -> s
190
+
191
+
let pp ppf k = Format.pp_print_string ppf (to_string k)
192
+
193
+
(** Apple Mail flag colors *)
194
+
type flag_color = [
195
+
| `Red
196
+
| `Orange
197
+
| `Yellow
198
+
| `Green
199
+
| `Blue
200
+
| `Purple
201
+
| `Gray
202
+
]
203
+
204
+
let flag_color_of_keywords (keywords : t list) : flag_color option =
205
+
let has k = List.mem k keywords in
206
+
let bit0 = has `MailFlagBit0 in
207
+
let bit1 = has `MailFlagBit1 in
208
+
let bit2 = has `MailFlagBit2 in
209
+
match (bit0, bit1, bit2) with
210
+
| (false, false, false) -> Some `Red
211
+
| (true, false, false) -> Some `Orange
212
+
| (false, true, false) -> Some `Yellow
213
+
| (true, true, true) -> Some `Green
214
+
| (false, false, true) -> Some `Blue
215
+
| (true, false, true) -> Some `Purple
216
+
| (false, true, true) -> Some `Gray
217
+
| (true, true, false) -> None
218
+
219
+
let flag_color_to_keywords : flag_color -> t list = function
220
+
| `Red -> []
221
+
| `Orange -> [`MailFlagBit0]
222
+
| `Yellow -> [`MailFlagBit1]
223
+
| `Green -> [`MailFlagBit0; `MailFlagBit1; `MailFlagBit2]
224
+
| `Blue -> [`MailFlagBit2]
225
+
| `Purple -> [`MailFlagBit0; `MailFlagBit2]
226
+
| `Gray -> [`MailFlagBit1; `MailFlagBit2]
227
+
end
228
+
229
+
(** {1 Mailbox Role Type} *)
230
+
231
+
module Role = struct
232
+
(** RFC 8621 standard roles *)
233
+
type standard = [
234
+
| `Inbox
235
+
| `Sent
236
+
| `Drafts
237
+
| `Trash
238
+
| `Junk
239
+
| `Archive
240
+
| `Flagged
241
+
| `Important
242
+
| `All
243
+
| `Subscribed
244
+
]
245
+
246
+
(** draft-ietf-mailmaint extended roles *)
247
+
type extended = [
248
+
| `Snoozed
249
+
| `Scheduled
250
+
| `Memos
251
+
]
252
+
253
+
type t = [
254
+
| standard
255
+
| extended
256
+
| `Custom of string
257
+
]
258
+
259
+
let of_string = function
260
+
(* RFC 8621 standard roles *)
261
+
| "inbox" -> `Inbox
262
+
| "sent" -> `Sent
263
+
| "drafts" -> `Drafts
264
+
| "trash" -> `Trash
265
+
| "junk" -> `Junk
266
+
| "archive" -> `Archive
267
+
| "flagged" -> `Flagged
268
+
| "important" -> `Important
269
+
| "all" -> `All
270
+
| "subscribed" -> `Subscribed
271
+
(* draft-ietf-mailmaint extended roles *)
272
+
| "snoozed" -> `Snoozed
273
+
| "scheduled" -> `Scheduled
274
+
| "memos" -> `Memos
275
+
| s -> `Custom s
276
+
277
+
let to_string = function
278
+
(* RFC 8621 standard roles *)
279
+
| `Inbox -> "inbox"
280
+
| `Sent -> "sent"
281
+
| `Drafts -> "drafts"
282
+
| `Trash -> "trash"
283
+
| `Junk -> "junk"
284
+
| `Archive -> "archive"
285
+
| `Flagged -> "flagged"
286
+
| `Important -> "important"
287
+
| `All -> "all"
288
+
| `Subscribed -> "subscribed"
289
+
(* draft-ietf-mailmaint extended roles *)
290
+
| `Snoozed -> "snoozed"
291
+
| `Scheduled -> "scheduled"
292
+
| `Memos -> "memos"
293
+
| `Custom s -> s
294
+
295
+
let pp ppf r = Format.pp_print_string ppf (to_string r)
296
+
end
297
+
298
+
(** {1 Capability Type} *)
299
+
300
+
module Capability = struct
301
+
type t = [
302
+
| `Core
303
+
| `Mail
304
+
| `Submission
305
+
| `VacationResponse
306
+
| `Custom of string
307
+
]
308
+
309
+
let core_uri = "urn:ietf:params:jmap:core"
310
+
let mail_uri = "urn:ietf:params:jmap:mail"
311
+
let submission_uri = "urn:ietf:params:jmap:submission"
312
+
let vacation_uri = "urn:ietf:params:jmap:vacationresponse"
313
+
314
+
let of_string = function
315
+
| s when s = core_uri -> `Core
316
+
| s when s = mail_uri -> `Mail
317
+
| s when s = submission_uri -> `Submission
318
+
| s when s = vacation_uri -> `VacationResponse
319
+
| s -> `Custom s
320
+
321
+
let to_string = function
322
+
| `Core -> core_uri
323
+
| `Mail -> mail_uri
324
+
| `Submission -> submission_uri
325
+
| `VacationResponse -> vacation_uri
326
+
| `Custom s -> s
327
+
328
+
let pp ppf c = Format.pp_print_string ppf (to_string c)
329
+
end
330
+
331
+
(** {1 Abstract Type Wrappers} *)
332
+
333
+
(** Wrapped session type *)
334
+
type session = Jmap_proto.Session.t
335
+
336
+
(** Wrapped account type *)
337
+
type account = Jmap_proto.Session.Account.t
338
+
339
+
(** Wrapped mailbox type *)
340
+
type mailbox = Jmap_proto.Mailbox.t
341
+
342
+
(** Wrapped email type *)
343
+
type email = Jmap_proto.Email.t
344
+
345
+
(** Wrapped thread type *)
346
+
type thread = Jmap_proto.Thread.t
347
+
348
+
(** Wrapped identity type *)
349
+
type identity = Jmap_proto.Identity.t
350
+
351
+
(** Wrapped email submission type *)
352
+
type submission = Jmap_proto.Submission.t
353
+
354
+
(** Wrapped vacation response type *)
355
+
type vacation = Jmap_proto.Vacation.t
356
+
357
+
(** Wrapped email address type *)
358
+
type email_address = Jmap_proto.Email_address.t
359
+
360
+
(** Wrapped search snippet type *)
361
+
type search_snippet = Jmap_proto.Search_snippet.t
+41
lib/dune
+41
lib/dune
···
1
+
(include_subdirs unqualified)
2
+
3
+
(library
4
+
(name jmap)
5
+
(public_name jmap)
6
+
(libraries jsont json-pointer ptime)
7
+
(modules
8
+
; Core unified interface
9
+
jmap
10
+
jmap_types
11
+
chain
12
+
; Protocol layer wrapper (combines core + mail)
13
+
jmap_proto
14
+
; Core protocol modules
15
+
proto_id
16
+
proto_int53
17
+
proto_date
18
+
proto_json_map
19
+
proto_unknown
20
+
proto_error
21
+
proto_capability
22
+
proto_filter
23
+
proto_method
24
+
proto_invocation
25
+
proto_request
26
+
proto_response
27
+
proto_session
28
+
proto_push
29
+
proto_blob
30
+
; Mail modules
31
+
mail_address
32
+
mail_header
33
+
mail_body
34
+
mail_mailbox
35
+
mail_thread
36
+
mail_email
37
+
mail_snippet
38
+
mail_identity
39
+
mail_submission
40
+
mail_vacation
41
+
mail_filter))
+8
lib/js/dune
+8
lib/js/dune
+174
lib/js/jmap_brr.ml
+174
lib/js/jmap_brr.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Brr
7
+
open Fut.Syntax
8
+
9
+
type connection = {
10
+
session : Jmap.Proto.Session.t;
11
+
api_url : Jstr.t;
12
+
token : Jstr.t;
13
+
}
14
+
15
+
let session conn = conn.session
16
+
let api_url conn = conn.api_url
17
+
18
+
(* JSON logging callbacks *)
19
+
let on_request : (string -> string -> unit) option ref = ref None
20
+
let on_response : (string -> string -> unit) option ref = ref None
21
+
22
+
let set_request_logger f = on_request := Some f
23
+
let set_response_logger f = on_response := Some f
24
+
25
+
let log_request label json =
26
+
match !on_request with
27
+
| Some f -> f label json
28
+
| None -> ()
29
+
30
+
let log_response label json =
31
+
match !on_response with
32
+
| Some f -> f label json
33
+
| None -> ()
34
+
35
+
(* JSON encoding/decoding using jsont.brr *)
36
+
37
+
let encode_request req =
38
+
Jsont_brr.encode Jmap.Proto.Request.jsont req
39
+
40
+
let encode_response resp =
41
+
Jsont_brr.encode Jmap.Proto.Response.jsont resp
42
+
43
+
let encode_session session =
44
+
Jsont_brr.encode Jmap.Proto.Session.jsont session
45
+
46
+
let decode_json s =
47
+
match Brr.Json.decode s with
48
+
| Ok jv -> Ok (Obj.magic jv : Jsont.json) (* Jv.t and Jsont.json are compatible *)
49
+
| Error e -> Error e
50
+
51
+
let encode_json json =
52
+
Ok (Brr.Json.encode (Obj.magic json : Jv.t))
53
+
54
+
let pp_json ppf json =
55
+
match encode_json json with
56
+
| Ok s -> Format.pp_print_string ppf (Jstr.to_string s)
57
+
| Error _ -> Format.pp_print_string ppf "<json encoding error>"
58
+
59
+
(* HTTP helpers *)
60
+
61
+
let make_headers token =
62
+
Brr_io.Fetch.Headers.of_assoc [
63
+
Jstr.v "Authorization", Jstr.(v "Bearer " + token);
64
+
Jstr.v "Content-Type", Jstr.v "application/json";
65
+
Jstr.v "Accept", Jstr.v "application/json";
66
+
]
67
+
68
+
let fetch_json ~url ~meth ~headers ?body () =
69
+
Console.(log [str ">>> Request:"; str (Jstr.to_string meth); str (Jstr.to_string url)]);
70
+
(match body with
71
+
| Some b -> Console.(log [str ">>> Body:"; b])
72
+
| None -> Console.(log [str ">>> No body"]));
73
+
let init = Brr_io.Fetch.Request.init
74
+
~method':meth
75
+
~headers
76
+
?body
77
+
()
78
+
in
79
+
let req = Brr_io.Fetch.Request.v ~init url in
80
+
let* response = Brr_io.Fetch.request req in
81
+
match response with
82
+
| Error e ->
83
+
Console.(error [str "<<< Fetch error:"; e]);
84
+
Fut.return (Error e)
85
+
| Ok resp ->
86
+
let status = Brr_io.Fetch.Response.status resp in
87
+
Console.(log [str "<<< Response status:"; str (Jstr.of_int status)]);
88
+
if not (Brr_io.Fetch.Response.ok resp) then begin
89
+
let msg = Jstr.(v "HTTP error: " + of_int status) in
90
+
(* Try to get response body for error details *)
91
+
let body = Brr_io.Fetch.Response.as_body resp in
92
+
let* text = Brr_io.Fetch.Body.text body in
93
+
(match text with
94
+
| Ok t -> Console.(error [str "<<< Error body:"; str (Jstr.to_string t)])
95
+
| Error _ -> ());
96
+
Fut.return (Error (Jv.Error.v msg))
97
+
end else begin
98
+
let body = Brr_io.Fetch.Response.as_body resp in
99
+
let* text = Brr_io.Fetch.Body.text body in
100
+
match text with
101
+
| Error e ->
102
+
Console.(error [str "<<< Body read error:"; e]);
103
+
Fut.return (Error e)
104
+
| Ok text ->
105
+
Console.(log [str "<<< Response body:"; str (Jstr.to_string text)]);
106
+
Fut.return (Ok text)
107
+
end
108
+
109
+
(* Session establishment *)
110
+
111
+
let get_session ~url ~token =
112
+
Console.(log [str "get_session: token length ="; str (Jstr.of_int (Jstr.length token))]);
113
+
log_request "GET Session" (Printf.sprintf "{\"url\": \"%s\"}" (Jstr.to_string url));
114
+
let headers = make_headers token in
115
+
let* result = fetch_json ~url ~meth:(Jstr.v "GET") ~headers () in
116
+
match result with
117
+
| Error e -> Fut.return (Error e)
118
+
| Ok text ->
119
+
log_response "Session" (Jstr.to_string text);
120
+
match Jsont_brr.decode Jmap.Proto.Session.jsont text with
121
+
| Error e -> Fut.return (Error e)
122
+
| Ok session ->
123
+
let api_url = Jstr.v (Jmap.Proto.Session.api_url session) in
124
+
Fut.return (Ok { session; api_url; token })
125
+
126
+
(* Making requests *)
127
+
128
+
let request conn req =
129
+
let headers = make_headers conn.token in
130
+
match Jsont_brr.encode Jmap.Proto.Request.jsont req with
131
+
| Error e -> Fut.return (Error e)
132
+
| Ok body_str ->
133
+
log_request "JMAP Request" (Jstr.to_string body_str);
134
+
let body = Brr_io.Fetch.Body.of_jstr body_str in
135
+
let* result = fetch_json
136
+
~url:conn.api_url
137
+
~meth:(Jstr.v "POST")
138
+
~headers
139
+
~body
140
+
()
141
+
in
142
+
match result with
143
+
| Error e -> Fut.return (Error e)
144
+
| Ok text ->
145
+
log_response "JMAP Response" (Jstr.to_string text);
146
+
match Jsont_brr.decode Jmap.Proto.Response.jsont text with
147
+
| Error e -> Fut.return (Error e)
148
+
| Ok response -> Fut.return (Ok response)
149
+
150
+
let request_json conn json =
151
+
let headers = make_headers conn.token in
152
+
match encode_json json with
153
+
| Error e -> Fut.return (Error e)
154
+
| Ok body_str ->
155
+
let body = Brr_io.Fetch.Body.of_jstr body_str in
156
+
let* result = fetch_json
157
+
~url:conn.api_url
158
+
~meth:(Jstr.v "POST")
159
+
~headers
160
+
~body
161
+
()
162
+
in
163
+
match result with
164
+
| Error e -> Fut.return (Error e)
165
+
| Ok text ->
166
+
match decode_json text with
167
+
| Error e -> Fut.return (Error e)
168
+
| Ok json -> Fut.return (Ok json)
169
+
170
+
(* Toplevel support *)
171
+
172
+
let install_printers () =
173
+
(* In browser context, printers are registered via the OCaml console *)
174
+
Console.(log [str "JMAP printers installed"])
+107
lib/js/jmap_brr.mli
+107
lib/js/jmap_brr.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP client for browsers using Brr.
7
+
8
+
This module provides a JMAP client that runs in web browsers using
9
+
the Fetch API. It can be used with js_of_ocaml to build browser-based
10
+
email clients.
11
+
12
+
{2 Example}
13
+
14
+
{[
15
+
open Fut.Syntax
16
+
17
+
let main () =
18
+
let* session = Jmap_brr.get_session
19
+
~url:(Jstr.v "https://api.fastmail.com/jmap/session")
20
+
~token:(Jstr.v "your-api-token")
21
+
in
22
+
match session with
23
+
| Error e -> Brr.Console.(error [str "Session error:"; e]); Fut.return ()
24
+
| Ok session ->
25
+
Brr.Console.(log [str "Connected as:"; str (Jmap.Session.username session)]);
26
+
Fut.return ()
27
+
28
+
let () = ignore (main ())
29
+
]} *)
30
+
31
+
(** {1 Connection} *)
32
+
33
+
type connection
34
+
(** A JMAP connection to a server. *)
35
+
36
+
val session : connection -> Jmap.Proto.Session.t
37
+
(** [session conn] returns the session information. *)
38
+
39
+
val api_url : connection -> Jstr.t
40
+
(** [api_url conn] returns the API URL for requests. *)
41
+
42
+
(** {1 Session Establishment} *)
43
+
44
+
val get_session :
45
+
url:Jstr.t ->
46
+
token:Jstr.t ->
47
+
(connection, Jv.Error.t) result Fut.t
48
+
(** [get_session ~url ~token] establishes a JMAP session.
49
+
50
+
[url] is the session URL (e.g., ["https://api.fastmail.com/jmap/session"]).
51
+
[token] is the Bearer authentication token. *)
52
+
53
+
(** {1 Making Requests} *)
54
+
55
+
val request :
56
+
connection ->
57
+
Jmap.Proto.Request.t ->
58
+
(Jmap.Proto.Response.t, Jv.Error.t) result Fut.t
59
+
(** [request conn req] sends a JMAP request and returns the response. *)
60
+
61
+
val request_json :
62
+
connection ->
63
+
Jsont.json ->
64
+
(Jsont.json, Jv.Error.t) result Fut.t
65
+
(** [request_json conn json] sends a raw JSON request and returns the
66
+
JSON response. Useful for debugging or custom requests. *)
67
+
68
+
(** {1 JSON Encoding Utilities}
69
+
70
+
These functions help visualize how OCaml types map to JMAP JSON,
71
+
useful for the tutorial and debugging. *)
72
+
73
+
val encode_request : Jmap.Proto.Request.t -> (Jstr.t, Jv.Error.t) result
74
+
(** [encode_request req] encodes a request to JSON string. *)
75
+
76
+
val encode_response : Jmap.Proto.Response.t -> (Jstr.t, Jv.Error.t) result
77
+
(** [encode_response resp] encodes a response to JSON string. *)
78
+
79
+
val encode_session : Jmap.Proto.Session.t -> (Jstr.t, Jv.Error.t) result
80
+
(** [encode_session session] encodes a session to JSON string. *)
81
+
82
+
val decode_json : Jstr.t -> (Jsont.json, Jv.Error.t) result
83
+
(** [decode_json s] parses a JSON string to a Jsont.json value. *)
84
+
85
+
val encode_json : Jsont.json -> (Jstr.t, Jv.Error.t) result
86
+
(** [encode_json json] encodes a Jsont.json value to a string. *)
87
+
88
+
val pp_json : Format.formatter -> Jsont.json -> unit
89
+
(** [pp_json ppf json] pretty-prints JSON. For toplevel use. *)
90
+
91
+
(** {1 Protocol Logging} *)
92
+
93
+
val set_request_logger : (string -> string -> unit) -> unit
94
+
(** [set_request_logger f] registers a callback [f label json] that will be
95
+
called with each outgoing JMAP request. Useful for debugging and
96
+
educational displays. *)
97
+
98
+
val set_response_logger : (string -> string -> unit) -> unit
99
+
(** [set_response_logger f] registers a callback [f label json] that will be
100
+
called with each incoming JMAP response. Useful for debugging and
101
+
educational displays. *)
102
+
103
+
(** {1 Toplevel Support} *)
104
+
105
+
val install_printers : unit -> unit
106
+
(** [install_printers ()] installs toplevel pretty printers for JMAP types.
107
+
This is useful when using the OCaml console in the browser. *)
+56
lib/mail/mail_address.ml
+56
lib/mail/mail_address.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type t = {
7
+
name : string option;
8
+
email : string;
9
+
}
10
+
11
+
let create ?name email = { name; email }
12
+
13
+
let name t = t.name
14
+
let email t = t.email
15
+
16
+
let equal a b = a.email = b.email
17
+
18
+
let pp ppf t =
19
+
match t.name with
20
+
| Some name -> Format.fprintf ppf "%s <%s>" name t.email
21
+
| None -> Format.pp_print_string ppf t.email
22
+
23
+
let make name email = { name; email }
24
+
25
+
let jsont =
26
+
let kind = "EmailAddress" in
27
+
(* name can be absent, null, or a string - all map to string option *)
28
+
(* Jsont.option maps null -> None and string -> Some string *)
29
+
Jsont.Object.map ~kind make
30
+
|> Jsont.Object.mem "name" Jsont.(option string)
31
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:name
32
+
|> Jsont.Object.mem "email" Jsont.string ~enc:email
33
+
|> Jsont.Object.finish
34
+
35
+
module Group = struct
36
+
type address = t
37
+
38
+
type t = {
39
+
name : string option;
40
+
addresses : address list;
41
+
}
42
+
43
+
let create ?name addresses = { name; addresses }
44
+
45
+
let name t = t.name
46
+
let addresses t = t.addresses
47
+
48
+
let make name addresses = { name; addresses }
49
+
50
+
let jsont =
51
+
let kind = "EmailAddressGroup" in
52
+
Jsont.Object.map ~kind make
53
+
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:name
54
+
|> Jsont.Object.mem "addresses" (Jsont.list jsont) ~enc:addresses
55
+
|> Jsont.Object.finish
56
+
end
+51
lib/mail/mail_address.mli
+51
lib/mail/mail_address.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Email address types as defined in RFC 8621 Section 4.1.2.3
7
+
8
+
@canonical Jmap.Proto.Email_address *)
9
+
10
+
(** {1 Email Address} *)
11
+
12
+
(** An email address with optional display name. *)
13
+
type t = {
14
+
name : string option;
15
+
(** The display name (from the phrase in RFC 5322). *)
16
+
email : string;
17
+
(** The email address (addr-spec in RFC 5322). *)
18
+
}
19
+
20
+
val create : ?name:string -> string -> t
21
+
(** [create ?name email] creates an email address. *)
22
+
23
+
val name : t -> string option
24
+
val email : t -> string
25
+
26
+
val equal : t -> t -> bool
27
+
val pp : Format.formatter -> t -> unit
28
+
29
+
val jsont : t Jsont.t
30
+
(** JSON codec for email addresses. *)
31
+
32
+
(** {1 Address Groups} *)
33
+
34
+
(** A group of email addresses with an optional group name. *)
35
+
module Group : sig
36
+
type address = t
37
+
38
+
type t = {
39
+
name : string option;
40
+
(** The group name, or [None] for ungrouped addresses. *)
41
+
addresses : address list;
42
+
(** The addresses in this group. *)
43
+
}
44
+
45
+
val create : ?name:string -> address list -> t
46
+
47
+
val name : t -> string option
48
+
val addresses : t -> address list
49
+
50
+
val jsont : t Jsont.t
51
+
end
+95
lib/mail/mail_body.ml
+95
lib/mail/mail_body.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module Value = struct
7
+
type t = {
8
+
value : string;
9
+
is_encoding_problem : bool;
10
+
is_truncated : bool;
11
+
}
12
+
13
+
let value t = t.value
14
+
let is_encoding_problem t = t.is_encoding_problem
15
+
let is_truncated t = t.is_truncated
16
+
17
+
let make value is_encoding_problem is_truncated =
18
+
{ value; is_encoding_problem; is_truncated }
19
+
20
+
let jsont =
21
+
let kind = "EmailBodyValue" in
22
+
Jsont.Object.map ~kind make
23
+
|> Jsont.Object.mem "value" Jsont.string ~enc:value
24
+
|> Jsont.Object.mem "isEncodingProblem" Jsont.bool ~dec_absent:false
25
+
~enc:is_encoding_problem ~enc_omit:(fun b -> not b)
26
+
|> Jsont.Object.mem "isTruncated" Jsont.bool ~dec_absent:false
27
+
~enc:is_truncated ~enc_omit:(fun b -> not b)
28
+
|> Jsont.Object.finish
29
+
end
30
+
31
+
module Part = struct
32
+
type t = {
33
+
part_id : string option;
34
+
blob_id : Proto_id.t option;
35
+
size : int64 option;
36
+
headers : Mail_header.t list option;
37
+
name : string option;
38
+
type_ : string;
39
+
charset : string option;
40
+
disposition : string option;
41
+
cid : string option;
42
+
language : string list option;
43
+
location : string option;
44
+
sub_parts : t list option;
45
+
}
46
+
47
+
let part_id t = t.part_id
48
+
let blob_id t = t.blob_id
49
+
let size t = t.size
50
+
let headers t = t.headers
51
+
let name t = t.name
52
+
let type_ t = t.type_
53
+
let charset t = t.charset
54
+
let disposition t = t.disposition
55
+
let cid t = t.cid
56
+
let language t = t.language
57
+
let location t = t.location
58
+
let sub_parts t = t.sub_parts
59
+
60
+
let rec jsont =
61
+
let kind = "EmailBodyPart" in
62
+
let make part_id blob_id size headers name type_ charset disposition
63
+
cid language location sub_parts =
64
+
{ part_id; blob_id; size; headers; name; type_; charset; disposition;
65
+
cid; language; location; sub_parts }
66
+
in
67
+
(* Many fields can be null per RFC 8621 Section 4.1.4 *)
68
+
let nullable_string = Jsont.(option string) in
69
+
let nullable_id = Jsont.(option Proto_id.jsont) in
70
+
lazy (
71
+
Jsont.Object.map ~kind make
72
+
|> Jsont.Object.mem "partId" nullable_string
73
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:part_id
74
+
|> Jsont.Object.mem "blobId" nullable_id
75
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:blob_id
76
+
|> Jsont.Object.opt_mem "size" Proto_int53.Unsigned.jsont ~enc:size
77
+
|> Jsont.Object.opt_mem "headers" (Jsont.list Mail_header.jsont) ~enc:headers
78
+
|> Jsont.Object.mem "name" nullable_string
79
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:name
80
+
|> Jsont.Object.mem "type" Jsont.string ~enc:type_
81
+
|> Jsont.Object.mem "charset" nullable_string
82
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:charset
83
+
|> Jsont.Object.mem "disposition" nullable_string
84
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:disposition
85
+
|> Jsont.Object.mem "cid" nullable_string
86
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:cid
87
+
|> Jsont.Object.opt_mem "language" (Jsont.list Jsont.string) ~enc:language
88
+
|> Jsont.Object.mem "location" nullable_string
89
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:location
90
+
|> Jsont.Object.opt_mem "subParts" (Jsont.list (Jsont.rec' jsont)) ~enc:sub_parts
91
+
|> Jsont.Object.finish
92
+
)
93
+
94
+
let jsont = Lazy.force jsont
95
+
end
+75
lib/mail/mail_body.mli
+75
lib/mail/mail_body.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Email body types as defined in RFC 8621 Section 4.1.4
7
+
8
+
@canonical Jmap.Proto.Email_body *)
9
+
10
+
(** {1 Body Value} *)
11
+
12
+
(** Fetched body part content. *)
13
+
module Value : sig
14
+
type t = {
15
+
value : string;
16
+
(** The body part content. *)
17
+
is_encoding_problem : bool;
18
+
(** True if there was a problem decoding the content transfer encoding. *)
19
+
is_truncated : bool;
20
+
(** True if the value was truncated. *)
21
+
}
22
+
23
+
val value : t -> string
24
+
val is_encoding_problem : t -> bool
25
+
val is_truncated : t -> bool
26
+
27
+
val jsont : t Jsont.t
28
+
end
29
+
30
+
(** {1 Body Part} *)
31
+
32
+
(** An email body part structure. *)
33
+
module Part : sig
34
+
type t = {
35
+
part_id : string option;
36
+
(** Identifier for this part, used to fetch content. *)
37
+
blob_id : Proto_id.t option;
38
+
(** Blob id if the part can be fetched as a blob. *)
39
+
size : int64 option;
40
+
(** Size in octets. *)
41
+
headers : Mail_header.t list option;
42
+
(** Headers specific to this part. *)
43
+
name : string option;
44
+
(** Suggested filename from Content-Disposition. *)
45
+
type_ : string;
46
+
(** MIME type (e.g., "text/plain"). *)
47
+
charset : string option;
48
+
(** Character set parameter. *)
49
+
disposition : string option;
50
+
(** Content-Disposition value. *)
51
+
cid : string option;
52
+
(** Content-ID value. *)
53
+
language : string list option;
54
+
(** Content-Language values. *)
55
+
location : string option;
56
+
(** Content-Location value. *)
57
+
sub_parts : t list option;
58
+
(** Nested parts for multipart types. *)
59
+
}
60
+
61
+
val part_id : t -> string option
62
+
val blob_id : t -> Proto_id.t option
63
+
val size : t -> int64 option
64
+
val headers : t -> Mail_header.t list option
65
+
val name : t -> string option
66
+
val type_ : t -> string
67
+
val charset : t -> string option
68
+
val disposition : t -> string option
69
+
val cid : t -> string option
70
+
val language : t -> string list option
71
+
val location : t -> string option
72
+
val sub_parts : t -> t list option
73
+
74
+
val jsont : t Jsont.t
75
+
end
+533
lib/mail/mail_email.ml
+533
lib/mail/mail_email.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module Keyword = struct
7
+
(* RFC 8621 Standard Keywords *)
8
+
let draft = "$draft"
9
+
let seen = "$seen"
10
+
let flagged = "$flagged"
11
+
let answered = "$answered"
12
+
let forwarded = "$forwarded"
13
+
let phishing = "$phishing"
14
+
let junk = "$junk"
15
+
let not_junk = "$notjunk"
16
+
17
+
(* draft-ietf-mailmaint Extended Keywords *)
18
+
let notify = "$notify"
19
+
let muted = "$muted"
20
+
let followed = "$followed"
21
+
let memo = "$memo"
22
+
let has_memo = "$hasmemo"
23
+
let has_attachment = "$hasattachment"
24
+
let has_no_attachment = "$hasnoattachment"
25
+
let auto_sent = "$autosent"
26
+
let unsubscribed = "$unsubscribed"
27
+
let can_unsubscribe = "$canunsubscribe"
28
+
let imported = "$imported"
29
+
let is_trusted = "$istrusted"
30
+
let masked_email = "$maskedemail"
31
+
let new_ = "$new"
32
+
33
+
(* Apple Mail Flag Color Keywords *)
34
+
let mail_flag_bit0 = "$MailFlagBit0"
35
+
let mail_flag_bit1 = "$MailFlagBit1"
36
+
let mail_flag_bit2 = "$MailFlagBit2"
37
+
38
+
type flag_color = [
39
+
| `Red
40
+
| `Orange
41
+
| `Yellow
42
+
| `Green
43
+
| `Blue
44
+
| `Purple
45
+
| `Gray
46
+
]
47
+
48
+
let flag_color_to_keywords = function
49
+
| `Red -> []
50
+
| `Orange -> [mail_flag_bit0]
51
+
| `Yellow -> [mail_flag_bit1]
52
+
| `Green -> [mail_flag_bit0; mail_flag_bit1; mail_flag_bit2]
53
+
| `Blue -> [mail_flag_bit2]
54
+
| `Purple -> [mail_flag_bit0; mail_flag_bit2]
55
+
| `Gray -> [mail_flag_bit1; mail_flag_bit2]
56
+
57
+
let flag_color_of_keywords keywords =
58
+
let has k = List.mem k keywords in
59
+
let bit0 = has mail_flag_bit0 in
60
+
let bit1 = has mail_flag_bit1 in
61
+
let bit2 = has mail_flag_bit2 in
62
+
match (bit0, bit1, bit2) with
63
+
| (false, false, false) -> Some `Red
64
+
| (true, false, false) -> Some `Orange
65
+
| (false, true, false) -> Some `Yellow
66
+
| (true, true, true) -> Some `Green
67
+
| (false, false, true) -> Some `Blue
68
+
| (true, false, true) -> Some `Purple
69
+
| (false, true, true) -> Some `Gray
70
+
| (true, true, false) -> None
71
+
end
72
+
73
+
(* Email property types *)
74
+
75
+
type metadata_property = [
76
+
| `Id
77
+
| `Blob_id
78
+
| `Thread_id
79
+
| `Mailbox_ids
80
+
| `Keywords
81
+
| `Size
82
+
| `Received_at
83
+
]
84
+
85
+
type header_convenience_property = [
86
+
| `Message_id
87
+
| `In_reply_to
88
+
| `References
89
+
| `Sender
90
+
| `From
91
+
| `To
92
+
| `Cc
93
+
| `Bcc
94
+
| `Reply_to
95
+
| `Subject
96
+
| `Sent_at
97
+
| `Headers
98
+
]
99
+
100
+
type body_property = [
101
+
| `Body_structure
102
+
| `Body_values
103
+
| `Text_body
104
+
| `Html_body
105
+
| `Attachments
106
+
| `Has_attachment
107
+
| `Preview
108
+
]
109
+
110
+
type standard_property = [
111
+
| metadata_property
112
+
| header_convenience_property
113
+
| body_property
114
+
]
115
+
116
+
type header_property = [ `Header of Mail_header.header_property ]
117
+
118
+
type property = [ standard_property | header_property ]
119
+
120
+
let standard_property_to_string : [< standard_property ] -> string = function
121
+
| `Id -> "id"
122
+
| `Blob_id -> "blobId"
123
+
| `Thread_id -> "threadId"
124
+
| `Mailbox_ids -> "mailboxIds"
125
+
| `Keywords -> "keywords"
126
+
| `Size -> "size"
127
+
| `Received_at -> "receivedAt"
128
+
| `Message_id -> "messageId"
129
+
| `In_reply_to -> "inReplyTo"
130
+
| `References -> "references"
131
+
| `Sender -> "sender"
132
+
| `From -> "from"
133
+
| `To -> "to"
134
+
| `Cc -> "cc"
135
+
| `Bcc -> "bcc"
136
+
| `Reply_to -> "replyTo"
137
+
| `Subject -> "subject"
138
+
| `Sent_at -> "sentAt"
139
+
| `Headers -> "headers"
140
+
| `Body_structure -> "bodyStructure"
141
+
| `Body_values -> "bodyValues"
142
+
| `Text_body -> "textBody"
143
+
| `Html_body -> "htmlBody"
144
+
| `Attachments -> "attachments"
145
+
| `Has_attachment -> "hasAttachment"
146
+
| `Preview -> "preview"
147
+
148
+
let property_to_string : [< property ] -> string = function
149
+
| `Header hp -> Mail_header.header_property_to_string hp
150
+
| #standard_property as p -> standard_property_to_string p
151
+
152
+
let standard_property_of_string s : standard_property option =
153
+
match s with
154
+
| "id" -> Some `Id
155
+
| "blobId" -> Some `Blob_id
156
+
| "threadId" -> Some `Thread_id
157
+
| "mailboxIds" -> Some `Mailbox_ids
158
+
| "keywords" -> Some `Keywords
159
+
| "size" -> Some `Size
160
+
| "receivedAt" -> Some `Received_at
161
+
| "messageId" -> Some `Message_id
162
+
| "inReplyTo" -> Some `In_reply_to
163
+
| "references" -> Some `References
164
+
| "sender" -> Some `Sender
165
+
| "from" -> Some `From
166
+
| "to" -> Some `To
167
+
| "cc" -> Some `Cc
168
+
| "bcc" -> Some `Bcc
169
+
| "replyTo" -> Some `Reply_to
170
+
| "subject" -> Some `Subject
171
+
| "sentAt" -> Some `Sent_at
172
+
| "headers" -> Some `Headers
173
+
| "bodyStructure" -> Some `Body_structure
174
+
| "bodyValues" -> Some `Body_values
175
+
| "textBody" -> Some `Text_body
176
+
| "htmlBody" -> Some `Html_body
177
+
| "attachments" -> Some `Attachments
178
+
| "hasAttachment" -> Some `Has_attachment
179
+
| "preview" -> Some `Preview
180
+
| _ -> None
181
+
182
+
let property_of_string s : property option =
183
+
match standard_property_of_string s with
184
+
| Some p -> Some (p :> property)
185
+
| None ->
186
+
match Mail_header.header_property_of_string s with
187
+
| Some hp -> Some (`Header hp)
188
+
| None -> None
189
+
190
+
(* Body part properties *)
191
+
192
+
type body_part_property = [
193
+
| `Part_id
194
+
| `Blob_id
195
+
| `Size
196
+
| `Part_headers
197
+
| `Name
198
+
| `Type
199
+
| `Charset
200
+
| `Disposition
201
+
| `Cid
202
+
| `Language
203
+
| `Location
204
+
| `Sub_parts
205
+
]
206
+
207
+
let body_part_property_to_string : [< body_part_property ] -> string = function
208
+
| `Part_id -> "partId"
209
+
| `Blob_id -> "blobId"
210
+
| `Size -> "size"
211
+
| `Part_headers -> "headers"
212
+
| `Name -> "name"
213
+
| `Type -> "type"
214
+
| `Charset -> "charset"
215
+
| `Disposition -> "disposition"
216
+
| `Cid -> "cid"
217
+
| `Language -> "language"
218
+
| `Location -> "location"
219
+
| `Sub_parts -> "subParts"
220
+
221
+
let body_part_property_of_string s : body_part_property option =
222
+
match s with
223
+
| "partId" -> Some `Part_id
224
+
| "blobId" -> Some `Blob_id
225
+
| "size" -> Some `Size
226
+
| "headers" -> Some `Part_headers
227
+
| "name" -> Some `Name
228
+
| "type" -> Some `Type
229
+
| "charset" -> Some `Charset
230
+
| "disposition" -> Some `Disposition
231
+
| "cid" -> Some `Cid
232
+
| "language" -> Some `Language
233
+
| "location" -> Some `Location
234
+
| "subParts" -> Some `Sub_parts
235
+
| _ -> None
236
+
237
+
(* Email type with optional fields *)
238
+
239
+
type t = {
240
+
id : Proto_id.t option;
241
+
blob_id : Proto_id.t option;
242
+
thread_id : Proto_id.t option;
243
+
size : int64 option;
244
+
received_at : Ptime.t option;
245
+
mailbox_ids : (Proto_id.t * bool) list option;
246
+
keywords : (string * bool) list option;
247
+
message_id : string list option;
248
+
in_reply_to : string list option;
249
+
references : string list option;
250
+
sender : Mail_address.t list option;
251
+
from : Mail_address.t list option;
252
+
to_ : Mail_address.t list option;
253
+
cc : Mail_address.t list option;
254
+
bcc : Mail_address.t list option;
255
+
reply_to : Mail_address.t list option;
256
+
subject : string option;
257
+
sent_at : Ptime.t option;
258
+
headers : Mail_header.t list option;
259
+
body_structure : Mail_body.Part.t option;
260
+
body_values : (string * Mail_body.Value.t) list option;
261
+
text_body : Mail_body.Part.t list option;
262
+
html_body : Mail_body.Part.t list option;
263
+
attachments : Mail_body.Part.t list option;
264
+
has_attachment : bool option;
265
+
preview : string option;
266
+
dynamic_headers : (string * Jsont.json) list;
267
+
}
268
+
269
+
let id t = t.id
270
+
let blob_id t = t.blob_id
271
+
let thread_id t = t.thread_id
272
+
let size t = t.size
273
+
let received_at t = t.received_at
274
+
let mailbox_ids t = t.mailbox_ids
275
+
let keywords t = t.keywords
276
+
let message_id t = t.message_id
277
+
let in_reply_to t = t.in_reply_to
278
+
let references t = t.references
279
+
let sender t = t.sender
280
+
let from t = t.from
281
+
let to_ t = t.to_
282
+
let cc t = t.cc
283
+
let bcc t = t.bcc
284
+
let reply_to t = t.reply_to
285
+
let subject t = t.subject
286
+
let sent_at t = t.sent_at
287
+
let headers t = t.headers
288
+
let body_structure t = t.body_structure
289
+
let body_values t = t.body_values
290
+
let text_body t = t.text_body
291
+
let html_body t = t.html_body
292
+
let attachments t = t.attachments
293
+
let has_attachment t = t.has_attachment
294
+
let preview t = t.preview
295
+
let dynamic_headers_raw t = t.dynamic_headers
296
+
297
+
(* Parse header property name to determine form and :all flag *)
298
+
let parse_header_prop name =
299
+
if not (String.length name > 7 && String.sub name 0 7 = "header:") then
300
+
None
301
+
else
302
+
let rest = String.sub name 7 (String.length name - 7) in
303
+
let parts = String.split_on_char ':' rest in
304
+
match parts with
305
+
| [] -> None
306
+
| [_name] -> Some (`Raw, false)
307
+
| [_name; second] ->
308
+
if second = "all" then Some (`Raw, true)
309
+
else (
310
+
match Mail_header.form_of_string second with
311
+
| Some form -> Some (form, false)
312
+
| None -> None
313
+
)
314
+
| [_name; form_str; "all"] ->
315
+
(match Mail_header.form_of_string form_str with
316
+
| Some form -> Some (form, true)
317
+
| None -> None)
318
+
| _ -> None
319
+
320
+
(* Decode a raw JSON header value into typed header_value *)
321
+
let decode_header_value prop_name json =
322
+
match parse_header_prop prop_name with
323
+
| None -> None
324
+
| Some (form, all) ->
325
+
let jsont = Mail_header.header_value_jsont ~form ~all in
326
+
match Jsont.Json.decode' jsont json with
327
+
| Ok v -> Some v
328
+
| Error _ -> None
329
+
330
+
let get_header t key =
331
+
match List.assoc_opt key t.dynamic_headers with
332
+
| None -> None
333
+
| Some json -> decode_header_value key json
334
+
335
+
let get_header_string t key =
336
+
match get_header t key with
337
+
| Some (Mail_header.String_single s) -> s
338
+
| _ -> None
339
+
340
+
let get_header_addresses t key =
341
+
match get_header t key with
342
+
| Some (Mail_header.Addresses_single addrs) -> addrs
343
+
| _ -> None
344
+
345
+
let make id blob_id thread_id size received_at mailbox_ids keywords
346
+
message_id in_reply_to references sender from to_ cc bcc reply_to
347
+
subject sent_at headers body_structure body_values text_body html_body
348
+
attachments has_attachment preview dynamic_headers =
349
+
{ id; blob_id; thread_id; size; received_at; mailbox_ids; keywords;
350
+
message_id; in_reply_to; references; sender; from; to_; cc; bcc;
351
+
reply_to; subject; sent_at; headers; body_structure; body_values;
352
+
text_body; html_body; attachments; has_attachment; preview; dynamic_headers }
353
+
354
+
(* Helper: null-safe list decoder - treats null as empty list.
355
+
This allows fields that may be null or array to decode successfully. *)
356
+
let null_safe_list inner_jsont =
357
+
Jsont.map
358
+
~dec:(function None -> [] | Some l -> l)
359
+
~enc:(fun l -> Some l)
360
+
(Jsont.option (Jsont.list inner_jsont))
361
+
362
+
module String_map = Map.Make(String)
363
+
364
+
(* Filter unknown members to only keep header:* properties *)
365
+
let filter_header_props (unknown : Jsont.json String_map.t) : (string * Jsont.json) list =
366
+
String_map.to_seq unknown
367
+
|> Seq.filter (fun (k, _) -> String.length k > 7 && String.sub k 0 7 = "header:")
368
+
|> List.of_seq
369
+
370
+
let jsont =
371
+
let kind = "Email" in
372
+
let body_values_jsont = Proto_json_map.of_string Mail_body.Value.jsont in
373
+
(* Use null_safe_list for address fields that can be null *)
374
+
let addr_list = null_safe_list Mail_address.jsont in
375
+
let str_list = null_safe_list Jsont.string in
376
+
let part_list = null_safe_list Mail_body.Part.jsont in
377
+
let hdr_list = null_safe_list Mail_header.jsont in
378
+
Jsont.Object.map ~kind (fun id blob_id thread_id size received_at mailbox_ids keywords
379
+
message_id in_reply_to references sender from to_ cc bcc reply_to
380
+
subject sent_at headers body_structure body_values text_body html_body
381
+
attachments has_attachment preview unknown ->
382
+
let dynamic_headers = filter_header_props unknown in
383
+
make id blob_id thread_id size received_at mailbox_ids keywords
384
+
message_id in_reply_to references sender from to_ cc bcc reply_to
385
+
subject sent_at headers body_structure body_values text_body html_body
386
+
attachments has_attachment preview dynamic_headers)
387
+
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
388
+
|> Jsont.Object.opt_mem "blobId" Proto_id.jsont ~enc:blob_id
389
+
|> Jsont.Object.opt_mem "threadId" Proto_id.jsont ~enc:thread_id
390
+
|> Jsont.Object.opt_mem "size" Proto_int53.Unsigned.jsont ~enc:size
391
+
|> Jsont.Object.opt_mem "receivedAt" Proto_date.Utc.jsont ~enc:received_at
392
+
|> Jsont.Object.opt_mem "mailboxIds" Proto_json_map.id_to_bool ~enc:mailbox_ids
393
+
|> Jsont.Object.opt_mem "keywords" Proto_json_map.string_to_bool ~enc:keywords
394
+
|> Jsont.Object.opt_mem "messageId" str_list ~enc:message_id
395
+
|> Jsont.Object.opt_mem "inReplyTo" str_list ~enc:in_reply_to
396
+
|> Jsont.Object.opt_mem "references" str_list ~enc:references
397
+
|> Jsont.Object.opt_mem "sender" addr_list ~enc:sender
398
+
|> Jsont.Object.opt_mem "from" addr_list ~enc:from
399
+
|> Jsont.Object.opt_mem "to" addr_list ~enc:to_
400
+
|> Jsont.Object.opt_mem "cc" addr_list ~enc:cc
401
+
|> Jsont.Object.opt_mem "bcc" addr_list ~enc:bcc
402
+
|> Jsont.Object.opt_mem "replyTo" addr_list ~enc:reply_to
403
+
|> Jsont.Object.opt_mem "subject" Jsont.string ~enc:subject
404
+
|> Jsont.Object.opt_mem "sentAt" Proto_date.Rfc3339.jsont ~enc:sent_at
405
+
|> Jsont.Object.opt_mem "headers" hdr_list ~enc:headers
406
+
|> Jsont.Object.opt_mem "bodyStructure" Mail_body.Part.jsont ~enc:body_structure
407
+
|> Jsont.Object.opt_mem "bodyValues" body_values_jsont ~enc:body_values
408
+
|> Jsont.Object.opt_mem "textBody" part_list ~enc:text_body
409
+
|> Jsont.Object.opt_mem "htmlBody" part_list ~enc:html_body
410
+
|> Jsont.Object.opt_mem "attachments" part_list ~enc:attachments
411
+
|> Jsont.Object.opt_mem "hasAttachment" Jsont.bool ~enc:has_attachment
412
+
|> Jsont.Object.opt_mem "preview" Jsont.string ~enc:preview
413
+
|> Jsont.Object.keep_unknown
414
+
(Jsont.Object.Mems.string_map Jsont.json)
415
+
~enc:(fun t -> String_map.of_list t.dynamic_headers)
416
+
|> Jsont.Object.finish
417
+
418
+
module Filter_condition = struct
419
+
type t = {
420
+
in_mailbox : Proto_id.t option;
421
+
in_mailbox_other_than : Proto_id.t list option;
422
+
before : Ptime.t option;
423
+
after : Ptime.t option;
424
+
min_size : int64 option;
425
+
max_size : int64 option;
426
+
all_in_thread_have_keyword : string option;
427
+
some_in_thread_have_keyword : string option;
428
+
none_in_thread_have_keyword : string option;
429
+
has_keyword : string option;
430
+
not_keyword : string option;
431
+
has_attachment : bool option;
432
+
text : string option;
433
+
from : string option;
434
+
to_ : string option;
435
+
cc : string option;
436
+
bcc : string option;
437
+
subject : string option;
438
+
body : string option;
439
+
header : (string * string option) option;
440
+
}
441
+
442
+
let make in_mailbox in_mailbox_other_than before after min_size max_size
443
+
all_in_thread_have_keyword some_in_thread_have_keyword
444
+
none_in_thread_have_keyword has_keyword not_keyword has_attachment
445
+
text from to_ cc bcc subject body header =
446
+
{ in_mailbox; in_mailbox_other_than; before; after; min_size; max_size;
447
+
all_in_thread_have_keyword; some_in_thread_have_keyword;
448
+
none_in_thread_have_keyword; has_keyword; not_keyword; has_attachment;
449
+
text; from; to_; cc; bcc; subject; body; header }
450
+
451
+
let header_jsont =
452
+
let kind = "HeaderFilter" in
453
+
let dec json =
454
+
match json with
455
+
| Jsont.Array ([Jsont.String (name, _)], _) ->
456
+
(name, None)
457
+
| Jsont.Array ([Jsont.String (name, _); Jsont.String (value, _)], _) ->
458
+
(name, Some value)
459
+
| _ ->
460
+
Jsont.Error.msgf Jsont.Meta.none "%s: expected [name] or [name, value]" kind
461
+
in
462
+
let enc (name, value) =
463
+
match value with
464
+
| None -> Jsont.Array ([Jsont.String (name, Jsont.Meta.none)], Jsont.Meta.none)
465
+
| Some v -> Jsont.Array ([Jsont.String (name, Jsont.Meta.none); Jsont.String (v, Jsont.Meta.none)], Jsont.Meta.none)
466
+
in
467
+
Jsont.map ~kind ~dec ~enc Jsont.json
468
+
469
+
let jsont =
470
+
let kind = "EmailFilterCondition" in
471
+
Jsont.Object.map ~kind make
472
+
|> Jsont.Object.opt_mem "inMailbox" Proto_id.jsont ~enc:(fun f -> f.in_mailbox)
473
+
|> Jsont.Object.opt_mem "inMailboxOtherThan" (Jsont.list Proto_id.jsont) ~enc:(fun f -> f.in_mailbox_other_than)
474
+
|> Jsont.Object.opt_mem "before" Proto_date.Utc.jsont ~enc:(fun f -> f.before)
475
+
|> Jsont.Object.opt_mem "after" Proto_date.Utc.jsont ~enc:(fun f -> f.after)
476
+
|> Jsont.Object.opt_mem "minSize" Proto_int53.Unsigned.jsont ~enc:(fun f -> f.min_size)
477
+
|> Jsont.Object.opt_mem "maxSize" Proto_int53.Unsigned.jsont ~enc:(fun f -> f.max_size)
478
+
|> Jsont.Object.opt_mem "allInThreadHaveKeyword" Jsont.string ~enc:(fun f -> f.all_in_thread_have_keyword)
479
+
|> Jsont.Object.opt_mem "someInThreadHaveKeyword" Jsont.string ~enc:(fun f -> f.some_in_thread_have_keyword)
480
+
|> Jsont.Object.opt_mem "noneInThreadHaveKeyword" Jsont.string ~enc:(fun f -> f.none_in_thread_have_keyword)
481
+
|> Jsont.Object.opt_mem "hasKeyword" Jsont.string ~enc:(fun f -> f.has_keyword)
482
+
|> Jsont.Object.opt_mem "notKeyword" Jsont.string ~enc:(fun f -> f.not_keyword)
483
+
|> Jsont.Object.opt_mem "hasAttachment" Jsont.bool ~enc:(fun f -> f.has_attachment)
484
+
|> Jsont.Object.opt_mem "text" Jsont.string ~enc:(fun f -> f.text)
485
+
|> Jsont.Object.opt_mem "from" Jsont.string ~enc:(fun f -> f.from)
486
+
|> Jsont.Object.opt_mem "to" Jsont.string ~enc:(fun f -> f.to_)
487
+
|> Jsont.Object.opt_mem "cc" Jsont.string ~enc:(fun f -> f.cc)
488
+
|> Jsont.Object.opt_mem "bcc" Jsont.string ~enc:(fun f -> f.bcc)
489
+
|> Jsont.Object.opt_mem "subject" Jsont.string ~enc:(fun f -> f.subject)
490
+
|> Jsont.Object.opt_mem "body" Jsont.string ~enc:(fun f -> f.body)
491
+
|> Jsont.Object.opt_mem "header" header_jsont ~enc:(fun f -> f.header)
492
+
|> Jsont.Object.finish
493
+
end
494
+
495
+
type get_args_extra = {
496
+
body_properties : body_part_property list option;
497
+
fetch_text_body_values : bool;
498
+
fetch_html_body_values : bool;
499
+
fetch_all_body_values : bool;
500
+
max_body_value_bytes : int64 option;
501
+
}
502
+
503
+
let get_args_extra ?body_properties ?(fetch_text_body_values=false)
504
+
?(fetch_html_body_values=false) ?(fetch_all_body_values=false)
505
+
?max_body_value_bytes () =
506
+
{ body_properties; fetch_text_body_values; fetch_html_body_values;
507
+
fetch_all_body_values; max_body_value_bytes }
508
+
509
+
let body_part_property_list_jsont =
510
+
Jsont.list (Jsont.map ~kind:"body_part_property"
511
+
~dec:(fun s -> match body_part_property_of_string s with
512
+
| Some p -> p
513
+
| None -> Jsont.Error.msgf Jsont.Meta.none "Unknown body property: %s" s)
514
+
~enc:body_part_property_to_string
515
+
Jsont.string)
516
+
517
+
let get_args_extra_jsont =
518
+
let kind = "Email/get extra args" in
519
+
Jsont.Object.map ~kind (fun body_properties fetch_text_body_values
520
+
fetch_html_body_values fetch_all_body_values max_body_value_bytes ->
521
+
{ body_properties; fetch_text_body_values; fetch_html_body_values;
522
+
fetch_all_body_values; max_body_value_bytes })
523
+
|> Jsont.Object.opt_mem "bodyProperties" body_part_property_list_jsont
524
+
~enc:(fun a -> a.body_properties)
525
+
|> Jsont.Object.mem "fetchTextBodyValues" Jsont.bool ~dec_absent:false
526
+
~enc:(fun a -> a.fetch_text_body_values) ~enc_omit:(fun b -> not b)
527
+
|> Jsont.Object.mem "fetchHTMLBodyValues" Jsont.bool ~dec_absent:false
528
+
~enc:(fun a -> a.fetch_html_body_values) ~enc_omit:(fun b -> not b)
529
+
|> Jsont.Object.mem "fetchAllBodyValues" Jsont.bool ~dec_absent:false
530
+
~enc:(fun a -> a.fetch_all_body_values) ~enc_omit:(fun b -> not b)
531
+
|> Jsont.Object.opt_mem "maxBodyValueBytes" Proto_int53.Unsigned.jsont
532
+
~enc:(fun a -> a.max_body_value_bytes)
533
+
|> Jsont.Object.finish
+401
lib/mail/mail_email.mli
+401
lib/mail/mail_email.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Email type as defined in RFC 8621 Section 4
7
+
8
+
@canonical Jmap.Proto.Email *)
9
+
10
+
(** {1 Standard Keywords} *)
11
+
12
+
(** Standard email keywords per RFC 8621 and draft-ietf-mailmaint.
13
+
14
+
Keywords are stored as strings in JMAP, but these constants provide
15
+
type-safe access to standard keywords. *)
16
+
module Keyword : sig
17
+
18
+
(** {2 RFC 8621 Standard Keywords} *)
19
+
20
+
val draft : string
21
+
(** ["$draft"] - The Email is a draft the user is composing. *)
22
+
23
+
val seen : string
24
+
(** ["$seen"] - The Email has been read. *)
25
+
26
+
val flagged : string
27
+
(** ["$flagged"] - The Email has been flagged for urgent/special attention. *)
28
+
29
+
val answered : string
30
+
(** ["$answered"] - The Email has been replied to. *)
31
+
32
+
val forwarded : string
33
+
(** ["$forwarded"] - The Email has been forwarded. *)
34
+
35
+
val phishing : string
36
+
(** ["$phishing"] - The Email is highly likely to be phishing. *)
37
+
38
+
val junk : string
39
+
(** ["$junk"] - The Email is definitely spam. *)
40
+
41
+
val not_junk : string
42
+
(** ["$notjunk"] - The Email is definitely not spam. *)
43
+
44
+
(** {2 draft-ietf-mailmaint Extended Keywords} *)
45
+
46
+
val notify : string
47
+
(** ["$notify"] - A notification should be shown for this message. *)
48
+
49
+
val muted : string
50
+
(** ["$muted"] - The user is not interested in future replies to this thread. *)
51
+
52
+
val followed : string
53
+
(** ["$followed"] - The user is particularly interested in future replies
54
+
to this thread. Mutually exclusive with muted. *)
55
+
56
+
val memo : string
57
+
(** ["$memo"] - The message is a note-to-self regarding another message
58
+
in the same thread. *)
59
+
60
+
val has_memo : string
61
+
(** ["$hasmemo"] - The message has an associated memo with the $memo keyword. *)
62
+
63
+
val has_attachment : string
64
+
(** ["$hasattachment"] - The message has an attachment (server-set). *)
65
+
66
+
val has_no_attachment : string
67
+
(** ["$hasnoattachment"] - The message does not have an attachment (server-set). *)
68
+
69
+
val auto_sent : string
70
+
(** ["$autosent"] - The message was sent automatically as a response
71
+
due to a user rule or setting (e.g., vacation response). *)
72
+
73
+
val unsubscribed : string
74
+
(** ["$unsubscribed"] - The client has unsubscribed from this mailing list. *)
75
+
76
+
val can_unsubscribe : string
77
+
(** ["$canunsubscribe"] - The message has an RFC8058-compliant
78
+
List-Unsubscribe header. *)
79
+
80
+
val imported : string
81
+
(** ["$imported"] - The message was imported from another mailbox. *)
82
+
83
+
val is_trusted : string
84
+
(** ["$istrusted"] - The authenticity of the from name and email address
85
+
have been verified with complete confidence by the server. *)
86
+
87
+
val masked_email : string
88
+
(** ["$maskedemail"] - The message was received via an alias created for
89
+
an individual sender to hide the user's real email address. *)
90
+
91
+
val new_ : string
92
+
(** ["$new"] - The message should be made more prominent to the user
93
+
due to a recent action (e.g., awakening from snooze). *)
94
+
95
+
(** {2 Apple Mail Flag Color Keywords}
96
+
97
+
These 3 keywords form a 3-bit bitmask defining the flag color:
98
+
- 000 = red, 100 = orange, 010 = yellow, 111 = green
99
+
- 001 = blue, 101 = purple, 011 = gray
100
+
101
+
These are only meaningful when the message has the $flagged keyword set. *)
102
+
103
+
val mail_flag_bit0 : string
104
+
(** ["$MailFlagBit0"] - Bit 0 of the flag color bitmask. *)
105
+
106
+
val mail_flag_bit1 : string
107
+
(** ["$MailFlagBit1"] - Bit 1 of the flag color bitmask. *)
108
+
109
+
val mail_flag_bit2 : string
110
+
(** ["$MailFlagBit2"] - Bit 2 of the flag color bitmask. *)
111
+
112
+
(** {2 Flag Color Type}
113
+
114
+
High-level type for working with Apple Mail flag colors. *)
115
+
116
+
type flag_color = [
117
+
| `Red (** Bits: 000 *)
118
+
| `Orange (** Bits: 100 *)
119
+
| `Yellow (** Bits: 010 *)
120
+
| `Green (** Bits: 111 *)
121
+
| `Blue (** Bits: 001 *)
122
+
| `Purple (** Bits: 101 *)
123
+
| `Gray (** Bits: 011 *)
124
+
]
125
+
126
+
val flag_color_to_keywords : flag_color -> string list
127
+
(** [flag_color_to_keywords color] returns the list of $MailFlagBit keywords
128
+
that should be set for the given color. *)
129
+
130
+
val flag_color_of_keywords : string list -> flag_color option
131
+
(** [flag_color_of_keywords keywords] extracts the flag color from a list
132
+
of keywords, if the $MailFlagBit keywords are present. Returns [None]
133
+
if no color bits are set (defaults to red when $flagged is set). *)
134
+
end
135
+
136
+
(** {1 Email Properties}
137
+
138
+
Polymorphic variants for type-safe property selection in Email/get requests.
139
+
These correspond to the properties defined in RFC 8621 Section 4.1. *)
140
+
141
+
(** Metadata properties (RFC 8621 Section 4.1.1).
142
+
These represent data about the message in the mail store. *)
143
+
type metadata_property = [
144
+
| `Id
145
+
| `Blob_id
146
+
| `Thread_id
147
+
| `Mailbox_ids
148
+
| `Keywords
149
+
| `Size
150
+
| `Received_at
151
+
]
152
+
153
+
(** Convenience header properties (RFC 8621 Section 4.1.3).
154
+
These are shortcuts for specific header:*:form properties. *)
155
+
type header_convenience_property = [
156
+
| `Message_id (** = header:Message-ID:asMessageIds *)
157
+
| `In_reply_to (** = header:In-Reply-To:asMessageIds *)
158
+
| `References (** = header:References:asMessageIds *)
159
+
| `Sender (** = header:Sender:asAddresses *)
160
+
| `From (** = header:From:asAddresses *)
161
+
| `To (** = header:To:asAddresses *)
162
+
| `Cc (** = header:Cc:asAddresses *)
163
+
| `Bcc (** = header:Bcc:asAddresses *)
164
+
| `Reply_to (** = header:Reply-To:asAddresses *)
165
+
| `Subject (** = header:Subject:asText *)
166
+
| `Sent_at (** = header:Date:asDate *)
167
+
| `Headers (** All headers in raw form *)
168
+
]
169
+
170
+
(** Body properties (RFC 8621 Section 4.1.4).
171
+
These represent the message body structure and content. *)
172
+
type body_property = [
173
+
| `Body_structure
174
+
| `Body_values
175
+
| `Text_body
176
+
| `Html_body
177
+
| `Attachments
178
+
| `Has_attachment
179
+
| `Preview
180
+
]
181
+
182
+
(** All standard Email properties. *)
183
+
type standard_property = [
184
+
| metadata_property
185
+
| header_convenience_property
186
+
| body_property
187
+
]
188
+
189
+
(** A dynamic header property request.
190
+
Use {!Mail_header.header_property} for type-safe construction. *)
191
+
type header_property = [ `Header of Mail_header.header_property ]
192
+
193
+
(** Any Email property - standard or dynamic header. *)
194
+
type property = [ standard_property | header_property ]
195
+
196
+
val property_to_string : [< property ] -> string
197
+
(** Convert a property to its wire name (e.g., [`From] -> "from"). *)
198
+
199
+
val property_of_string : string -> property option
200
+
(** Parse a property name. Returns [None] for unrecognized properties.
201
+
Handles both standard properties and header:* properties. *)
202
+
203
+
val standard_property_of_string : string -> standard_property option
204
+
(** Parse only standard property names (not header:* properties). *)
205
+
206
+
(** {1 Body Part Properties}
207
+
208
+
Properties that can be requested for EmailBodyPart objects
209
+
via the [bodyProperties] argument. *)
210
+
211
+
type body_part_property = [
212
+
| `Part_id
213
+
| `Blob_id
214
+
| `Size
215
+
| `Part_headers (** Named [headers] in the wire format *)
216
+
| `Name
217
+
| `Type
218
+
| `Charset
219
+
| `Disposition
220
+
| `Cid
221
+
| `Language
222
+
| `Location
223
+
| `Sub_parts
224
+
]
225
+
226
+
val body_part_property_to_string : [< body_part_property ] -> string
227
+
(** Convert a body part property to its wire name. *)
228
+
229
+
val body_part_property_of_string : string -> body_part_property option
230
+
(** Parse a body part property name. *)
231
+
232
+
(** {1 Email Object} *)
233
+
234
+
type t = {
235
+
(* Metadata - server-set, immutable *)
236
+
id : Proto_id.t option;
237
+
blob_id : Proto_id.t option;
238
+
thread_id : Proto_id.t option;
239
+
size : int64 option;
240
+
received_at : Ptime.t option;
241
+
242
+
(* Metadata - mutable *)
243
+
mailbox_ids : (Proto_id.t * bool) list option;
244
+
keywords : (string * bool) list option;
245
+
246
+
(* Parsed headers *)
247
+
message_id : string list option;
248
+
in_reply_to : string list option;
249
+
references : string list option;
250
+
sender : Mail_address.t list option;
251
+
from : Mail_address.t list option;
252
+
to_ : Mail_address.t list option;
253
+
cc : Mail_address.t list option;
254
+
bcc : Mail_address.t list option;
255
+
reply_to : Mail_address.t list option;
256
+
subject : string option;
257
+
sent_at : Ptime.t option;
258
+
259
+
(* Raw headers *)
260
+
headers : Mail_header.t list option;
261
+
262
+
(* Body structure *)
263
+
body_structure : Mail_body.Part.t option;
264
+
body_values : (string * Mail_body.Value.t) list option;
265
+
text_body : Mail_body.Part.t list option;
266
+
html_body : Mail_body.Part.t list option;
267
+
attachments : Mail_body.Part.t list option;
268
+
has_attachment : bool option;
269
+
preview : string option;
270
+
271
+
(* Dynamic header properties - stored as raw JSON for lazy decoding *)
272
+
dynamic_headers : (string * Jsont.json) list;
273
+
(** Raw header values from [header:*] property requests.
274
+
The key is the full property name (e.g., "header:X-Custom:asText").
275
+
Use {!decode_header_value} to parse into typed values. *)
276
+
}
277
+
278
+
(** {2 Accessors}
279
+
280
+
All accessors return [option] types since the response only includes
281
+
properties that were requested. *)
282
+
283
+
val id : t -> Proto_id.t option
284
+
val blob_id : t -> Proto_id.t option
285
+
val thread_id : t -> Proto_id.t option
286
+
val size : t -> int64 option
287
+
val received_at : t -> Ptime.t option
288
+
val mailbox_ids : t -> (Proto_id.t * bool) list option
289
+
val keywords : t -> (string * bool) list option
290
+
val message_id : t -> string list option
291
+
val in_reply_to : t -> string list option
292
+
val references : t -> string list option
293
+
val sender : t -> Mail_address.t list option
294
+
val from : t -> Mail_address.t list option
295
+
val to_ : t -> Mail_address.t list option
296
+
val cc : t -> Mail_address.t list option
297
+
val bcc : t -> Mail_address.t list option
298
+
val reply_to : t -> Mail_address.t list option
299
+
val subject : t -> string option
300
+
val sent_at : t -> Ptime.t option
301
+
val headers : t -> Mail_header.t list option
302
+
val body_structure : t -> Mail_body.Part.t option
303
+
val body_values : t -> (string * Mail_body.Value.t) list option
304
+
val text_body : t -> Mail_body.Part.t list option
305
+
val html_body : t -> Mail_body.Part.t list option
306
+
val attachments : t -> Mail_body.Part.t list option
307
+
val has_attachment : t -> bool option
308
+
val preview : t -> string option
309
+
val dynamic_headers_raw : t -> (string * Jsont.json) list
310
+
(** Get raw dynamic headers. Use {!decode_header_value} to parse them. *)
311
+
312
+
(** {2 Dynamic Header Decoding} *)
313
+
314
+
val decode_header_value : string -> Jsont.json -> Mail_header.header_value option
315
+
(** [decode_header_value prop_name json] decodes a raw JSON value into a typed
316
+
header value based on the property name. The property name determines the form:
317
+
- [header:Name] or [header:Name:all] -> Raw/Text (String_single/String_all)
318
+
- [header:Name:asText] -> Text (String_single)
319
+
- [header:Name:asAddresses] -> Addresses (Addresses_single)
320
+
- [header:Name:asGroupedAddresses] -> Grouped (Grouped_single)
321
+
- [header:Name:asMessageIds] -> MessageIds (Strings_single)
322
+
- [header:Name:asDate] -> Date (Date_single)
323
+
- [header:Name:asURLs] -> URLs (Strings_single)
324
+
Returns [None] if the property name is invalid or decoding fails. *)
325
+
326
+
val get_header : t -> string -> Mail_header.header_value option
327
+
(** [get_header email key] looks up and decodes a dynamic header by its full
328
+
property name. E.g., [get_header email "header:X-Custom:asText"]. *)
329
+
330
+
val get_header_string : t -> string -> string option
331
+
(** [get_header_string email key] looks up a string header value.
332
+
Returns [None] if not found or if the value is not a string type. *)
333
+
334
+
val get_header_addresses : t -> string -> Mail_address.t list option
335
+
(** [get_header_addresses email key] looks up an addresses header value.
336
+
Returns [None] if not found or if the value is not an addresses type. *)
337
+
338
+
val jsont : t Jsont.t
339
+
(** Permissive JSON codec that handles any subset of properties.
340
+
Unknown [header:*] properties are decoded into {!dynamic_headers}. *)
341
+
342
+
(** {1 Email Filter Conditions} *)
343
+
344
+
module Filter_condition : sig
345
+
type t = {
346
+
in_mailbox : Proto_id.t option;
347
+
in_mailbox_other_than : Proto_id.t list option;
348
+
before : Ptime.t option;
349
+
after : Ptime.t option;
350
+
min_size : int64 option;
351
+
max_size : int64 option;
352
+
all_in_thread_have_keyword : string option;
353
+
some_in_thread_have_keyword : string option;
354
+
none_in_thread_have_keyword : string option;
355
+
has_keyword : string option;
356
+
not_keyword : string option;
357
+
has_attachment : bool option;
358
+
text : string option;
359
+
from : string option;
360
+
to_ : string option;
361
+
cc : string option;
362
+
bcc : string option;
363
+
subject : string option;
364
+
body : string option;
365
+
header : (string * string option) option;
366
+
}
367
+
368
+
val jsont : t Jsont.t
369
+
end
370
+
371
+
(** {1 Email/get Arguments} *)
372
+
373
+
(** Extra arguments for Email/get beyond standard /get.
374
+
375
+
Note: The standard [properties] argument from {!Proto_method.get_args}
376
+
should use {!property} variants converted via {!property_to_string}. *)
377
+
type get_args_extra = {
378
+
body_properties : body_part_property list option;
379
+
(** Properties to fetch for each EmailBodyPart.
380
+
If omitted, defaults to all properties. *)
381
+
fetch_text_body_values : bool;
382
+
(** If [true], fetch body values for text/* parts in textBody. *)
383
+
fetch_html_body_values : bool;
384
+
(** If [true], fetch body values for text/* parts in htmlBody. *)
385
+
fetch_all_body_values : bool;
386
+
(** If [true], fetch body values for all text/* parts. *)
387
+
max_body_value_bytes : int64 option;
388
+
(** Maximum size of body values to return. Larger values are truncated. *)
389
+
}
390
+
391
+
val get_args_extra :
392
+
?body_properties:body_part_property list ->
393
+
?fetch_text_body_values:bool ->
394
+
?fetch_html_body_values:bool ->
395
+
?fetch_all_body_values:bool ->
396
+
?max_body_value_bytes:int64 ->
397
+
unit ->
398
+
get_args_extra
399
+
(** Convenience constructor with sensible defaults. *)
400
+
401
+
val get_args_extra_jsont : get_args_extra Jsont.t
+16
lib/mail/mail_filter.ml
+16
lib/mail/mail_filter.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type email_filter = Mail_email.Filter_condition.t Proto_filter.filter
7
+
8
+
let email_filter_jsont = Proto_filter.filter_jsont Mail_email.Filter_condition.jsont
9
+
10
+
type mailbox_filter = Mail_mailbox.Filter_condition.t Proto_filter.filter
11
+
12
+
let mailbox_filter_jsont = Proto_filter.filter_jsont Mail_mailbox.Filter_condition.jsont
13
+
14
+
type submission_filter = Mail_submission.Filter_condition.t Proto_filter.filter
15
+
16
+
let submission_filter_jsont = Proto_filter.filter_jsont Mail_submission.Filter_condition.jsont
+23
lib/mail/mail_filter.mli
+23
lib/mail/mail_filter.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Mail-specific filter types
7
+
8
+
@canonical Jmap.Proto.Mail_filter *)
9
+
10
+
(** Email filter with Email-specific conditions. *)
11
+
type email_filter = Mail_email.Filter_condition.t Proto_filter.filter
12
+
13
+
val email_filter_jsont : email_filter Jsont.t
14
+
15
+
(** Mailbox filter with Mailbox-specific conditions. *)
16
+
type mailbox_filter = Mail_mailbox.Filter_condition.t Proto_filter.filter
17
+
18
+
val mailbox_filter_jsont : mailbox_filter Jsont.t
19
+
20
+
(** EmailSubmission filter with Submission-specific conditions. *)
21
+
type submission_filter = Mail_submission.Filter_condition.t Proto_filter.filter
22
+
23
+
val submission_filter_jsont : submission_filter Jsont.t
+370
lib/mail/mail_header.ml
+370
lib/mail/mail_header.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type t = {
7
+
name : string;
8
+
value : string;
9
+
}
10
+
11
+
let create ~name ~value = { name; value }
12
+
13
+
let name t = t.name
14
+
let value t = t.value
15
+
16
+
let make name value = { name; value }
17
+
18
+
let jsont =
19
+
let kind = "EmailHeader" in
20
+
Jsont.Object.map ~kind make
21
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
22
+
|> Jsont.Object.mem "value" Jsont.string ~enc:value
23
+
|> Jsont.Object.finish
24
+
25
+
(* Header categories *)
26
+
27
+
type address_header = [
28
+
| `From
29
+
| `Sender
30
+
| `Reply_to
31
+
| `To
32
+
| `Cc
33
+
| `Bcc
34
+
| `Resent_from
35
+
| `Resent_sender
36
+
| `Resent_reply_to
37
+
| `Resent_to
38
+
| `Resent_cc
39
+
| `Resent_bcc
40
+
]
41
+
42
+
type message_id_header = [
43
+
| `Message_id
44
+
| `In_reply_to
45
+
| `References
46
+
| `Resent_message_id
47
+
]
48
+
49
+
type date_header = [
50
+
| `Date
51
+
| `Resent_date
52
+
]
53
+
54
+
type url_header = [
55
+
| `List_help
56
+
| `List_unsubscribe
57
+
| `List_subscribe
58
+
| `List_post
59
+
| `List_owner
60
+
| `List_archive
61
+
]
62
+
63
+
type text_header = [
64
+
| `Subject
65
+
| `Comments
66
+
| `Keywords
67
+
| `List_id
68
+
]
69
+
70
+
type standard_header = [
71
+
| address_header
72
+
| message_id_header
73
+
| date_header
74
+
| url_header
75
+
| text_header
76
+
]
77
+
78
+
type custom_header = [ `Custom of string ]
79
+
80
+
type any_header = [ standard_header | custom_header ]
81
+
82
+
let standard_header_to_string : [< standard_header ] -> string = function
83
+
| `From -> "From"
84
+
| `Sender -> "Sender"
85
+
| `Reply_to -> "Reply-To"
86
+
| `To -> "To"
87
+
| `Cc -> "Cc"
88
+
| `Bcc -> "Bcc"
89
+
| `Resent_from -> "Resent-From"
90
+
| `Resent_sender -> "Resent-Sender"
91
+
| `Resent_reply_to -> "Resent-Reply-To"
92
+
| `Resent_to -> "Resent-To"
93
+
| `Resent_cc -> "Resent-Cc"
94
+
| `Resent_bcc -> "Resent-Bcc"
95
+
| `Message_id -> "Message-ID"
96
+
| `In_reply_to -> "In-Reply-To"
97
+
| `References -> "References"
98
+
| `Resent_message_id -> "Resent-Message-ID"
99
+
| `Date -> "Date"
100
+
| `Resent_date -> "Resent-Date"
101
+
| `List_help -> "List-Help"
102
+
| `List_unsubscribe -> "List-Unsubscribe"
103
+
| `List_subscribe -> "List-Subscribe"
104
+
| `List_post -> "List-Post"
105
+
| `List_owner -> "List-Owner"
106
+
| `List_archive -> "List-Archive"
107
+
| `Subject -> "Subject"
108
+
| `Comments -> "Comments"
109
+
| `Keywords -> "Keywords"
110
+
| `List_id -> "List-Id"
111
+
112
+
let standard_header_of_string s : standard_header option =
113
+
match String.lowercase_ascii s with
114
+
| "from" -> Some `From
115
+
| "sender" -> Some `Sender
116
+
| "reply-to" -> Some `Reply_to
117
+
| "to" -> Some `To
118
+
| "cc" -> Some `Cc
119
+
| "bcc" -> Some `Bcc
120
+
| "resent-from" -> Some `Resent_from
121
+
| "resent-sender" -> Some `Resent_sender
122
+
| "resent-reply-to" -> Some `Resent_reply_to
123
+
| "resent-to" -> Some `Resent_to
124
+
| "resent-cc" -> Some `Resent_cc
125
+
| "resent-bcc" -> Some `Resent_bcc
126
+
| "message-id" -> Some `Message_id
127
+
| "in-reply-to" -> Some `In_reply_to
128
+
| "references" -> Some `References
129
+
| "resent-message-id" -> Some `Resent_message_id
130
+
| "date" -> Some `Date
131
+
| "resent-date" -> Some `Resent_date
132
+
| "list-help" -> Some `List_help
133
+
| "list-unsubscribe" -> Some `List_unsubscribe
134
+
| "list-subscribe" -> Some `List_subscribe
135
+
| "list-post" -> Some `List_post
136
+
| "list-owner" -> Some `List_owner
137
+
| "list-archive" -> Some `List_archive
138
+
| "subject" -> Some `Subject
139
+
| "comments" -> Some `Comments
140
+
| "keywords" -> Some `Keywords
141
+
| "list-id" -> Some `List_id
142
+
| _ -> None
143
+
144
+
let any_header_to_string : [< any_header ] -> string = function
145
+
| `Custom s -> s
146
+
| #standard_header as h -> standard_header_to_string h
147
+
148
+
(* Header parsed forms *)
149
+
150
+
type form = [
151
+
| `Raw
152
+
| `Text
153
+
| `Addresses
154
+
| `Grouped_addresses
155
+
| `Message_ids
156
+
| `Date
157
+
| `Urls
158
+
]
159
+
160
+
let form_to_string : [< form ] -> string = function
161
+
| `Raw -> ""
162
+
| `Text -> "asText"
163
+
| `Addresses -> "asAddresses"
164
+
| `Grouped_addresses -> "asGroupedAddresses"
165
+
| `Message_ids -> "asMessageIds"
166
+
| `Date -> "asDate"
167
+
| `Urls -> "asURLs"
168
+
169
+
let form_of_string s : form option =
170
+
match s with
171
+
| "" -> Some `Raw
172
+
| "asText" -> Some `Text
173
+
| "asAddresses" -> Some `Addresses
174
+
| "asGroupedAddresses" -> Some `Grouped_addresses
175
+
| "asMessageIds" -> Some `Message_ids
176
+
| "asDate" -> Some `Date
177
+
| "asURLs" -> Some `Urls
178
+
| _ -> None
179
+
180
+
(* Header property requests *)
181
+
182
+
type header_property =
183
+
| Raw of { name : string; all : bool }
184
+
| Text of { header : [ text_header | custom_header ]; all : bool }
185
+
| Addresses of { header : [ address_header | custom_header ]; all : bool }
186
+
| Grouped_addresses of { header : [ address_header | custom_header ]; all : bool }
187
+
| Message_ids of { header : [ message_id_header | custom_header ]; all : bool }
188
+
| Date of { header : [ date_header | custom_header ]; all : bool }
189
+
| Urls of { header : [ url_header | custom_header ]; all : bool }
190
+
191
+
let header_name_of_property : header_property -> string = function
192
+
| Raw { name; _ } -> name
193
+
| Text { header; _ } -> any_header_to_string (header :> any_header)
194
+
| Addresses { header; _ } -> any_header_to_string (header :> any_header)
195
+
| Grouped_addresses { header; _ } -> any_header_to_string (header :> any_header)
196
+
| Message_ids { header; _ } -> any_header_to_string (header :> any_header)
197
+
| Date { header; _ } -> any_header_to_string (header :> any_header)
198
+
| Urls { header; _ } -> any_header_to_string (header :> any_header)
199
+
200
+
let header_property_all : header_property -> bool = function
201
+
| Raw { all; _ } -> all
202
+
| Text { all; _ } -> all
203
+
| Addresses { all; _ } -> all
204
+
| Grouped_addresses { all; _ } -> all
205
+
| Message_ids { all; _ } -> all
206
+
| Date { all; _ } -> all
207
+
| Urls { all; _ } -> all
208
+
209
+
let header_property_form : header_property -> form = function
210
+
| Raw _ -> `Raw
211
+
| Text _ -> `Text
212
+
| Addresses _ -> `Addresses
213
+
| Grouped_addresses _ -> `Grouped_addresses
214
+
| Message_ids _ -> `Message_ids
215
+
| Date _ -> `Date
216
+
| Urls _ -> `Urls
217
+
218
+
let header_property_to_string prop =
219
+
let name = header_name_of_property prop in
220
+
let form = form_to_string (header_property_form prop) in
221
+
let all_suffix = if header_property_all prop then ":all" else "" in
222
+
let form_suffix = if form = "" then "" else ":" ^ form in
223
+
"header:" ^ name ^ form_suffix ^ all_suffix
224
+
225
+
let header_property_of_string s : header_property option =
226
+
if not (String.length s > 7 && String.sub s 0 7 = "header:") then
227
+
None
228
+
else
229
+
let rest = String.sub s 7 (String.length s - 7) in
230
+
(* Parse the parts: name[:form][:all] *)
231
+
let parts = String.split_on_char ':' rest in
232
+
match parts with
233
+
| [] -> None
234
+
| [name] ->
235
+
Some (Raw { name; all = false })
236
+
| [name; second] ->
237
+
if second = "all" then
238
+
Some (Raw { name; all = true })
239
+
else begin
240
+
match form_of_string second with
241
+
| None -> None
242
+
| Some `Raw -> Some (Raw { name; all = false })
243
+
| Some `Text -> Some (Text { header = `Custom name; all = false })
244
+
| Some `Addresses -> Some (Addresses { header = `Custom name; all = false })
245
+
| Some `Grouped_addresses -> Some (Grouped_addresses { header = `Custom name; all = false })
246
+
| Some `Message_ids -> Some (Message_ids { header = `Custom name; all = false })
247
+
| Some `Date -> Some (Date { header = `Custom name; all = false })
248
+
| Some `Urls -> Some (Urls { header = `Custom name; all = false })
249
+
end
250
+
| [name; form_str; "all"] ->
251
+
begin match form_of_string form_str with
252
+
| None -> None
253
+
| Some `Raw -> Some (Raw { name; all = true })
254
+
| Some `Text -> Some (Text { header = `Custom name; all = true })
255
+
| Some `Addresses -> Some (Addresses { header = `Custom name; all = true })
256
+
| Some `Grouped_addresses -> Some (Grouped_addresses { header = `Custom name; all = true })
257
+
| Some `Message_ids -> Some (Message_ids { header = `Custom name; all = true })
258
+
| Some `Date -> Some (Date { header = `Custom name; all = true })
259
+
| Some `Urls -> Some (Urls { header = `Custom name; all = true })
260
+
end
261
+
| _ -> None
262
+
263
+
(* Convenience constructors *)
264
+
265
+
let raw ?(all=false) name = Raw { name; all }
266
+
267
+
let text ?(all=false) header = Text { header; all }
268
+
269
+
let addresses ?(all=false) header = Addresses { header; all }
270
+
271
+
let grouped_addresses ?(all=false) header = Grouped_addresses { header; all }
272
+
273
+
let message_ids ?(all=false) header = Message_ids { header; all }
274
+
275
+
let date ?(all=false) header = Date { header; all }
276
+
277
+
let urls ?(all=false) header = Urls { header; all }
278
+
279
+
(* Header values in responses *)
280
+
281
+
type header_value =
282
+
| String_single of string option
283
+
| String_all of string list
284
+
| Addresses_single of Mail_address.t list option
285
+
| Addresses_all of Mail_address.t list list
286
+
| Grouped_single of Mail_address.Group.t list option
287
+
| Grouped_all of Mail_address.Group.t list list
288
+
| Date_single of Ptime.t option
289
+
| Date_all of Ptime.t option list
290
+
| Strings_single of string list option
291
+
| Strings_all of string list option list
292
+
293
+
let header_value_jsont ~form ~all : header_value Jsont.t =
294
+
match form, all with
295
+
| (`Raw | `Text), false ->
296
+
Jsont.map
297
+
~dec:(fun s -> String_single s)
298
+
~enc:(function String_single s -> s | _ -> None)
299
+
(Jsont.option Jsont.string)
300
+
| (`Raw | `Text), true ->
301
+
Jsont.map
302
+
~dec:(fun l -> String_all l)
303
+
~enc:(function String_all l -> l | _ -> [])
304
+
(Jsont.list Jsont.string)
305
+
| `Addresses, false ->
306
+
Jsont.map
307
+
~dec:(fun l -> Addresses_single l)
308
+
~enc:(function Addresses_single l -> l | _ -> None)
309
+
(Jsont.option (Jsont.list Mail_address.jsont))
310
+
| `Addresses, true ->
311
+
Jsont.map
312
+
~dec:(fun l -> Addresses_all l)
313
+
~enc:(function Addresses_all l -> l | _ -> [])
314
+
(Jsont.list (Jsont.list Mail_address.jsont))
315
+
| `Grouped_addresses, false ->
316
+
Jsont.map
317
+
~dec:(fun l -> Grouped_single l)
318
+
~enc:(function Grouped_single l -> l | _ -> None)
319
+
(Jsont.option (Jsont.list Mail_address.Group.jsont))
320
+
| `Grouped_addresses, true ->
321
+
Jsont.map
322
+
~dec:(fun l -> Grouped_all l)
323
+
~enc:(function Grouped_all l -> l | _ -> [])
324
+
(Jsont.list (Jsont.list Mail_address.Group.jsont))
325
+
| `Message_ids, false ->
326
+
Jsont.map
327
+
~dec:(fun l -> Strings_single l)
328
+
~enc:(function Strings_single l -> l | _ -> None)
329
+
(Jsont.option (Jsont.list Jsont.string))
330
+
| `Message_ids, true ->
331
+
Jsont.map
332
+
~dec:(fun l -> Strings_all l)
333
+
~enc:(function Strings_all l -> l | _ -> [])
334
+
(Jsont.list (Jsont.option (Jsont.list Jsont.string)))
335
+
| `Date, false ->
336
+
Jsont.map
337
+
~dec:(fun t -> Date_single t)
338
+
~enc:(function Date_single t -> t | _ -> None)
339
+
(Jsont.option Proto_date.Rfc3339.jsont)
340
+
| `Date, true ->
341
+
Jsont.map
342
+
~dec:(fun l -> Date_all l)
343
+
~enc:(function Date_all l -> l | _ -> [])
344
+
(Jsont.list (Jsont.option Proto_date.Rfc3339.jsont))
345
+
| `Urls, false ->
346
+
Jsont.map
347
+
~dec:(fun l -> Strings_single l)
348
+
~enc:(function Strings_single l -> l | _ -> None)
349
+
(Jsont.option (Jsont.list Jsont.string))
350
+
| `Urls, true ->
351
+
Jsont.map
352
+
~dec:(fun l -> Strings_all l)
353
+
~enc:(function Strings_all l -> l | _ -> [])
354
+
(Jsont.list (Jsont.option (Jsont.list Jsont.string)))
355
+
356
+
(* Low-level JSON codecs *)
357
+
358
+
let raw_jsont = Jsont.string
359
+
360
+
let text_jsont = Jsont.string
361
+
362
+
let addresses_jsont = Jsont.list Mail_address.jsont
363
+
364
+
let grouped_addresses_jsont = Jsont.list Mail_address.Group.jsont
365
+
366
+
let message_ids_jsont = Jsont.list Jsont.string
367
+
368
+
let date_jsont = Proto_date.Rfc3339.jsont
369
+
370
+
let urls_jsont = Jsont.list Jsont.string
+283
lib/mail/mail_header.mli
+283
lib/mail/mail_header.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Email header types as defined in RFC 8621 Section 4.1.2
7
+
8
+
@canonical Jmap.Proto.Email_header *)
9
+
10
+
(** {1 Raw Headers} *)
11
+
12
+
(** A raw email header name-value pair. *)
13
+
type t = {
14
+
name : string;
15
+
(** The header field name. *)
16
+
value : string;
17
+
(** The raw header field value. *)
18
+
}
19
+
20
+
val create : name:string -> value:string -> t
21
+
22
+
val name : t -> string
23
+
val value : t -> string
24
+
25
+
val jsont : t Jsont.t
26
+
27
+
(** {1 Header Categories}
28
+
29
+
RFC 8621 Section 4.1.2 restricts which parsed forms can be used with
30
+
which headers. These polymorphic variant types encode those restrictions
31
+
at the type level.
32
+
33
+
Each category corresponds to headers that share the same allowed forms:
34
+
- Address headers: can use [Addresses] and [Grouped_addresses] forms
35
+
- Message-ID headers: can use [Message_ids] form
36
+
- Date headers: can use [Date] form
37
+
- URL headers: can use [Urls] form
38
+
- Text headers: can use [Text] form
39
+
- All headers can use [Raw] form
40
+
- Custom headers (not in RFC 5322/2369) can use any form *)
41
+
42
+
(** Headers that allow the [Addresses] and [Grouped_addresses] forms.
43
+
These are address-list headers per RFC 5322. *)
44
+
type address_header = [
45
+
| `From
46
+
| `Sender
47
+
| `Reply_to
48
+
| `To
49
+
| `Cc
50
+
| `Bcc
51
+
| `Resent_from
52
+
| `Resent_sender
53
+
| `Resent_reply_to
54
+
| `Resent_to
55
+
| `Resent_cc
56
+
| `Resent_bcc
57
+
]
58
+
59
+
(** Headers that allow the [Message_ids] form.
60
+
These contain msg-id values per RFC 5322. *)
61
+
type message_id_header = [
62
+
| `Message_id
63
+
| `In_reply_to
64
+
| `References
65
+
| `Resent_message_id
66
+
]
67
+
68
+
(** Headers that allow the [Date] form.
69
+
These contain date-time values per RFC 5322. *)
70
+
type date_header = [
71
+
| `Date
72
+
| `Resent_date
73
+
]
74
+
75
+
(** Headers that allow the [Urls] form.
76
+
These are list-* headers per RFC 2369. *)
77
+
type url_header = [
78
+
| `List_help
79
+
| `List_unsubscribe
80
+
| `List_subscribe
81
+
| `List_post
82
+
| `List_owner
83
+
| `List_archive
84
+
]
85
+
86
+
(** Headers that allow the [Text] form.
87
+
These contain unstructured or phrase content. *)
88
+
type text_header = [
89
+
| `Subject
90
+
| `Comments
91
+
| `Keywords
92
+
| `List_id
93
+
]
94
+
95
+
(** All standard headers defined in RFC 5322 and RFC 2369. *)
96
+
type standard_header = [
97
+
| address_header
98
+
| message_id_header
99
+
| date_header
100
+
| url_header
101
+
| text_header
102
+
]
103
+
104
+
(** A custom header not defined in RFC 5322 or RFC 2369.
105
+
Custom headers can use any parsed form. *)
106
+
type custom_header = [ `Custom of string ]
107
+
108
+
(** Any header - standard or custom. *)
109
+
type any_header = [ standard_header | custom_header ]
110
+
111
+
(** {2 Header Name Conversion} *)
112
+
113
+
val standard_header_to_string : [< standard_header ] -> string
114
+
(** Convert a standard header variant to its wire name (e.g., [`From] -> "From"). *)
115
+
116
+
val standard_header_of_string : string -> standard_header option
117
+
(** Parse a header name to a standard header variant, case-insensitive.
118
+
Returns [None] for non-standard headers. *)
119
+
120
+
val any_header_to_string : [< any_header ] -> string
121
+
(** Convert any header variant to its wire name. *)
122
+
123
+
(** {1 Header Parsed Forms}
124
+
125
+
RFC 8621 defines several parsed forms for headers.
126
+
These can be requested via the [header:Name:form] properties. *)
127
+
128
+
(** The parsed form to request for a header value. *)
129
+
type form = [
130
+
| `Raw (** Raw octets, available for all headers *)
131
+
| `Text (** Decoded text, for text headers or custom *)
132
+
| `Addresses (** Flat address list, for address headers or custom *)
133
+
| `Grouped_addresses (** Address list with groups, for address headers or custom *)
134
+
| `Message_ids (** List of message-id strings, for message-id headers or custom *)
135
+
| `Date (** Parsed date, for date headers or custom *)
136
+
| `Urls (** List of URLs, for url headers or custom *)
137
+
]
138
+
139
+
val form_to_string : [< form ] -> string
140
+
(** Convert form to wire suffix (e.g., [`Addresses] -> "asAddresses").
141
+
[`Raw] returns the empty string (raw is the default). *)
142
+
143
+
val form_of_string : string -> form option
144
+
(** Parse a form suffix (e.g., "asAddresses" -> [`Addresses]).
145
+
Empty string returns [`Raw]. *)
146
+
147
+
(** {1 Header Property Requests}
148
+
149
+
Type-safe construction of [header:Name:form:all] property strings.
150
+
The GADT ensures that only valid form/header combinations are allowed. *)
151
+
152
+
(** A header property request with type-safe form selection.
153
+
154
+
The type parameter encodes what forms are allowed:
155
+
- Address headers allow [Addresses] and [Grouped_addresses]
156
+
- Message-ID headers allow [Message_ids]
157
+
- Date headers allow [Date]
158
+
- URL headers allow [Urls]
159
+
- Text headers allow [Text]
160
+
- All headers allow [Raw]
161
+
- Custom headers allow any form *)
162
+
type header_property =
163
+
| Raw of { name : string; all : bool }
164
+
(** Raw form, available for any header. *)
165
+
166
+
| Text of { header : [ text_header | custom_header ]; all : bool }
167
+
(** Text form, for text headers or custom. *)
168
+
169
+
| Addresses of { header : [ address_header | custom_header ]; all : bool }
170
+
(** Addresses form, for address headers or custom. *)
171
+
172
+
| Grouped_addresses of { header : [ address_header | custom_header ]; all : bool }
173
+
(** GroupedAddresses form, for address headers or custom. *)
174
+
175
+
| Message_ids of { header : [ message_id_header | custom_header ]; all : bool }
176
+
(** MessageIds form, for message-id headers or custom. *)
177
+
178
+
| Date of { header : [ date_header | custom_header ]; all : bool }
179
+
(** Date form, for date headers or custom. *)
180
+
181
+
| Urls of { header : [ url_header | custom_header ]; all : bool }
182
+
(** URLs form, for URL headers or custom. *)
183
+
184
+
val header_property_to_string : header_property -> string
185
+
(** Convert a header property request to wire format.
186
+
E.g., [Addresses { header = `From; all = true }] -> "header:From:asAddresses:all" *)
187
+
188
+
val header_property_of_string : string -> header_property option
189
+
(** Parse a header property string.
190
+
Returns [None] if the string doesn't match [header:*] format. *)
191
+
192
+
(** {2 Convenience Constructors} *)
193
+
194
+
val raw : ?all:bool -> string -> header_property
195
+
(** [raw ?all name] creates a raw header property request. *)
196
+
197
+
val text : ?all:bool -> [ text_header | custom_header ] -> header_property
198
+
(** [text ?all header] creates a text header property request. *)
199
+
200
+
val addresses : ?all:bool -> [ address_header | custom_header ] -> header_property
201
+
(** [addresses ?all header] creates an addresses header property request. *)
202
+
203
+
val grouped_addresses : ?all:bool -> [ address_header | custom_header ] -> header_property
204
+
(** [grouped_addresses ?all header] creates a grouped addresses header property request. *)
205
+
206
+
val message_ids : ?all:bool -> [ message_id_header | custom_header ] -> header_property
207
+
(** [message_ids ?all header] creates a message-ids header property request. *)
208
+
209
+
val date : ?all:bool -> [ date_header | custom_header ] -> header_property
210
+
(** [date ?all header] creates a date header property request. *)
211
+
212
+
val urls : ?all:bool -> [ url_header | custom_header ] -> header_property
213
+
(** [urls ?all header] creates a URLs header property request. *)
214
+
215
+
(** {1 Header Values in Responses}
216
+
217
+
When fetching dynamic headers, the response value type depends on the
218
+
requested form. This type captures all possible response shapes. *)
219
+
220
+
(** A header value from the response.
221
+
222
+
The variant encodes both the form and whether [:all] was requested:
223
+
- [*_single] variants: value of the last header instance, or [None] if absent
224
+
- [*_all] variants: list of values for all instances, empty if absent *)
225
+
type header_value =
226
+
| String_single of string option
227
+
(** Raw or Text form, single instance. *)
228
+
229
+
| String_all of string list
230
+
(** Raw or Text form, all instances. *)
231
+
232
+
| Addresses_single of Mail_address.t list option
233
+
(** Addresses form, single instance. *)
234
+
235
+
| Addresses_all of Mail_address.t list list
236
+
(** Addresses form, all instances. *)
237
+
238
+
| Grouped_single of Mail_address.Group.t list option
239
+
(** GroupedAddresses form, single instance. *)
240
+
241
+
| Grouped_all of Mail_address.Group.t list list
242
+
(** GroupedAddresses form, all instances. *)
243
+
244
+
| Date_single of Ptime.t option
245
+
(** Date form, single instance. *)
246
+
247
+
| Date_all of Ptime.t option list
248
+
(** Date form, all instances. *)
249
+
250
+
| Strings_single of string list option
251
+
(** MessageIds or URLs form, single instance. *)
252
+
253
+
| Strings_all of string list option list
254
+
(** MessageIds or URLs form, all instances. *)
255
+
256
+
val header_value_jsont : form:form -> all:bool -> header_value Jsont.t
257
+
(** [header_value_jsont ~form ~all] returns a JSON codec for header values
258
+
with the given form and multiplicity. *)
259
+
260
+
(** {1 Low-level JSON Codecs}
261
+
262
+
These codecs are used internally and for custom header processing. *)
263
+
264
+
(** The raw form - header value as-is. *)
265
+
val raw_jsont : string Jsont.t
266
+
267
+
(** The text form - decoded and unfolded value. *)
268
+
val text_jsont : string Jsont.t
269
+
270
+
(** The addresses form - list of email addresses. *)
271
+
val addresses_jsont : Mail_address.t list Jsont.t
272
+
273
+
(** The grouped addresses form - addresses with group info. *)
274
+
val grouped_addresses_jsont : Mail_address.Group.t list Jsont.t
275
+
276
+
(** The message IDs form - list of message-id strings. *)
277
+
val message_ids_jsont : string list Jsont.t
278
+
279
+
(** The date form - parsed RFC 3339 date. *)
280
+
val date_jsont : Ptime.t Jsont.t
281
+
282
+
(** The URLs form - list of URL strings. *)
283
+
val urls_jsont : string list Jsont.t
+77
lib/mail/mail_identity.ml
+77
lib/mail/mail_identity.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Identity properties *)
7
+
8
+
type property = [
9
+
| `Id
10
+
| `Name
11
+
| `Email
12
+
| `Reply_to
13
+
| `Bcc
14
+
| `Text_signature
15
+
| `Html_signature
16
+
| `May_delete
17
+
]
18
+
19
+
let property_to_string : [< property ] -> string = function
20
+
| `Id -> "id"
21
+
| `Name -> "name"
22
+
| `Email -> "email"
23
+
| `Reply_to -> "replyTo"
24
+
| `Bcc -> "bcc"
25
+
| `Text_signature -> "textSignature"
26
+
| `Html_signature -> "htmlSignature"
27
+
| `May_delete -> "mayDelete"
28
+
29
+
let property_of_string s : property option =
30
+
match s with
31
+
| "id" -> Some `Id
32
+
| "name" -> Some `Name
33
+
| "email" -> Some `Email
34
+
| "replyTo" -> Some `Reply_to
35
+
| "bcc" -> Some `Bcc
36
+
| "textSignature" -> Some `Text_signature
37
+
| "htmlSignature" -> Some `Html_signature
38
+
| "mayDelete" -> Some `May_delete
39
+
| _ -> None
40
+
41
+
(* Identity type *)
42
+
43
+
type t = {
44
+
id : Proto_id.t option;
45
+
name : string option;
46
+
email : string option;
47
+
reply_to : Mail_address.t list option;
48
+
bcc : Mail_address.t list option;
49
+
text_signature : string option;
50
+
html_signature : string option;
51
+
may_delete : bool option;
52
+
}
53
+
54
+
let id t = t.id
55
+
let name t = t.name
56
+
let email t = t.email
57
+
let reply_to t = t.reply_to
58
+
let bcc t = t.bcc
59
+
let text_signature t = t.text_signature
60
+
let html_signature t = t.html_signature
61
+
let may_delete t = t.may_delete
62
+
63
+
let make id name email reply_to bcc text_signature html_signature may_delete =
64
+
{ id; name; email; reply_to; bcc; text_signature; html_signature; may_delete }
65
+
66
+
let jsont =
67
+
let kind = "Identity" in
68
+
Jsont.Object.map ~kind make
69
+
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
70
+
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:name
71
+
|> Jsont.Object.opt_mem "email" Jsont.string ~enc:email
72
+
|> Jsont.Object.opt_mem "replyTo" (Jsont.list Mail_address.jsont) ~enc:reply_to
73
+
|> Jsont.Object.opt_mem "bcc" (Jsont.list Mail_address.jsont) ~enc:bcc
74
+
|> Jsont.Object.opt_mem "textSignature" Jsont.string ~enc:text_signature
75
+
|> Jsont.Object.opt_mem "htmlSignature" Jsont.string ~enc:html_signature
76
+
|> Jsont.Object.opt_mem "mayDelete" Jsont.bool ~enc:may_delete
77
+
|> Jsont.Object.finish
+63
lib/mail/mail_identity.mli
+63
lib/mail/mail_identity.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Identity type as defined in RFC 8621 Section 6
7
+
8
+
@canonical Jmap.Proto.Identity *)
9
+
10
+
(** {1 Identity Properties}
11
+
12
+
Polymorphic variants for type-safe property selection in Identity/get requests.
13
+
These correspond to the properties defined in RFC 8621 Section 6. *)
14
+
15
+
(** All Identity properties that can be requested. *)
16
+
type property = [
17
+
| `Id
18
+
| `Name
19
+
| `Email
20
+
| `Reply_to
21
+
| `Bcc
22
+
| `Text_signature
23
+
| `Html_signature
24
+
| `May_delete
25
+
]
26
+
27
+
val property_to_string : [< property ] -> string
28
+
(** Convert a property to its wire name (e.g., [`Text_signature] -> "textSignature"). *)
29
+
30
+
val property_of_string : string -> property option
31
+
(** Parse a property name, case-sensitive. *)
32
+
33
+
(** {1 Identity Object} *)
34
+
35
+
type t = {
36
+
id : Proto_id.t option;
37
+
(** Server-assigned identity id. *)
38
+
name : string option;
39
+
(** Display name for sent emails. *)
40
+
email : string option;
41
+
(** The email address to use. *)
42
+
reply_to : Mail_address.t list option;
43
+
(** Default Reply-To addresses. *)
44
+
bcc : Mail_address.t list option;
45
+
(** Default BCC addresses. *)
46
+
text_signature : string option;
47
+
(** Plain text signature. *)
48
+
html_signature : string option;
49
+
(** HTML signature. *)
50
+
may_delete : bool option;
51
+
(** Whether the user may delete this identity. *)
52
+
}
53
+
54
+
val id : t -> Proto_id.t option
55
+
val name : t -> string option
56
+
val email : t -> string option
57
+
val reply_to : t -> Mail_address.t list option
58
+
val bcc : t -> Mail_address.t list option
59
+
val text_signature : t -> string option
60
+
val html_signature : t -> string option
61
+
val may_delete : t -> bool option
62
+
63
+
val jsont : t Jsont.t
+225
lib/mail/mail_mailbox.ml
+225
lib/mail/mail_mailbox.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Mailbox properties *)
7
+
8
+
type property = [
9
+
| `Id
10
+
| `Name
11
+
| `Parent_id
12
+
| `Role
13
+
| `Sort_order
14
+
| `Total_emails
15
+
| `Unread_emails
16
+
| `Total_threads
17
+
| `Unread_threads
18
+
| `My_rights
19
+
| `Is_subscribed
20
+
]
21
+
22
+
let property_to_string : [< property ] -> string = function
23
+
| `Id -> "id"
24
+
| `Name -> "name"
25
+
| `Parent_id -> "parentId"
26
+
| `Role -> "role"
27
+
| `Sort_order -> "sortOrder"
28
+
| `Total_emails -> "totalEmails"
29
+
| `Unread_emails -> "unreadEmails"
30
+
| `Total_threads -> "totalThreads"
31
+
| `Unread_threads -> "unreadThreads"
32
+
| `My_rights -> "myRights"
33
+
| `Is_subscribed -> "isSubscribed"
34
+
35
+
let property_of_string s : property option =
36
+
match s with
37
+
| "id" -> Some `Id
38
+
| "name" -> Some `Name
39
+
| "parentId" -> Some `Parent_id
40
+
| "role" -> Some `Role
41
+
| "sortOrder" -> Some `Sort_order
42
+
| "totalEmails" -> Some `Total_emails
43
+
| "unreadEmails" -> Some `Unread_emails
44
+
| "totalThreads" -> Some `Total_threads
45
+
| "unreadThreads" -> Some `Unread_threads
46
+
| "myRights" -> Some `My_rights
47
+
| "isSubscribed" -> Some `Is_subscribed
48
+
| _ -> None
49
+
50
+
module Rights = struct
51
+
type t = {
52
+
may_read_items : bool;
53
+
may_add_items : bool;
54
+
may_remove_items : bool;
55
+
may_set_seen : bool;
56
+
may_set_keywords : bool;
57
+
may_create_child : bool;
58
+
may_rename : bool;
59
+
may_delete : bool;
60
+
may_submit : bool;
61
+
}
62
+
63
+
let may_read_items t = t.may_read_items
64
+
let may_add_items t = t.may_add_items
65
+
let may_remove_items t = t.may_remove_items
66
+
let may_set_seen t = t.may_set_seen
67
+
let may_set_keywords t = t.may_set_keywords
68
+
let may_create_child t = t.may_create_child
69
+
let may_rename t = t.may_rename
70
+
let may_delete t = t.may_delete
71
+
let may_submit t = t.may_submit
72
+
73
+
let make may_read_items may_add_items may_remove_items may_set_seen
74
+
may_set_keywords may_create_child may_rename may_delete may_submit =
75
+
{ may_read_items; may_add_items; may_remove_items; may_set_seen;
76
+
may_set_keywords; may_create_child; may_rename; may_delete; may_submit }
77
+
78
+
let jsont =
79
+
let kind = "MailboxRights" in
80
+
Jsont.Object.map ~kind make
81
+
|> Jsont.Object.mem "mayReadItems" Jsont.bool ~enc:may_read_items
82
+
|> Jsont.Object.mem "mayAddItems" Jsont.bool ~enc:may_add_items
83
+
|> Jsont.Object.mem "mayRemoveItems" Jsont.bool ~enc:may_remove_items
84
+
|> Jsont.Object.mem "maySetSeen" Jsont.bool ~enc:may_set_seen
85
+
|> Jsont.Object.mem "maySetKeywords" Jsont.bool ~enc:may_set_keywords
86
+
|> Jsont.Object.mem "mayCreateChild" Jsont.bool ~enc:may_create_child
87
+
|> Jsont.Object.mem "mayRename" Jsont.bool ~enc:may_rename
88
+
|> Jsont.Object.mem "mayDelete" Jsont.bool ~enc:may_delete
89
+
|> Jsont.Object.mem "maySubmit" Jsont.bool ~enc:may_submit
90
+
|> Jsont.Object.finish
91
+
end
92
+
93
+
type role = [
94
+
| `All
95
+
| `Archive
96
+
| `Drafts
97
+
| `Flagged
98
+
| `Important
99
+
| `Inbox
100
+
| `Junk
101
+
| `Sent
102
+
| `Subscribed
103
+
| `Trash
104
+
| `Snoozed
105
+
| `Scheduled
106
+
| `Memos
107
+
| `Other of string
108
+
]
109
+
110
+
let role_to_string = function
111
+
| `All -> "all"
112
+
| `Archive -> "archive"
113
+
| `Drafts -> "drafts"
114
+
| `Flagged -> "flagged"
115
+
| `Important -> "important"
116
+
| `Inbox -> "inbox"
117
+
| `Junk -> "junk"
118
+
| `Sent -> "sent"
119
+
| `Subscribed -> "subscribed"
120
+
| `Trash -> "trash"
121
+
| `Snoozed -> "snoozed"
122
+
| `Scheduled -> "scheduled"
123
+
| `Memos -> "memos"
124
+
| `Other s -> s
125
+
126
+
let role_of_string = function
127
+
| "all" -> `All
128
+
| "archive" -> `Archive
129
+
| "drafts" -> `Drafts
130
+
| "flagged" -> `Flagged
131
+
| "important" -> `Important
132
+
| "inbox" -> `Inbox
133
+
| "junk" -> `Junk
134
+
| "sent" -> `Sent
135
+
| "subscribed" -> `Subscribed
136
+
| "trash" -> `Trash
137
+
| "snoozed" -> `Snoozed
138
+
| "scheduled" -> `Scheduled
139
+
| "memos" -> `Memos
140
+
| s -> `Other s
141
+
142
+
let role_jsont =
143
+
Jsont.map ~kind:"MailboxRole"
144
+
~dec:(fun s -> role_of_string s)
145
+
~enc:role_to_string
146
+
Jsont.string
147
+
148
+
type t = {
149
+
id : Proto_id.t option;
150
+
name : string option;
151
+
parent_id : Proto_id.t option;
152
+
role : role option;
153
+
sort_order : int64 option;
154
+
total_emails : int64 option;
155
+
unread_emails : int64 option;
156
+
total_threads : int64 option;
157
+
unread_threads : int64 option;
158
+
my_rights : Rights.t option;
159
+
is_subscribed : bool option;
160
+
}
161
+
162
+
let id t = t.id
163
+
let name t = t.name
164
+
let parent_id t = t.parent_id
165
+
let role t = t.role
166
+
let sort_order t = t.sort_order
167
+
let total_emails t = t.total_emails
168
+
let unread_emails t = t.unread_emails
169
+
let total_threads t = t.total_threads
170
+
let unread_threads t = t.unread_threads
171
+
let my_rights t = t.my_rights
172
+
let is_subscribed t = t.is_subscribed
173
+
174
+
let make id name parent_id role sort_order total_emails unread_emails
175
+
total_threads unread_threads my_rights is_subscribed =
176
+
{ id; name; parent_id; role; sort_order; total_emails; unread_emails;
177
+
total_threads; unread_threads; my_rights; is_subscribed }
178
+
179
+
let jsont =
180
+
let kind = "Mailbox" in
181
+
Jsont.Object.map ~kind make
182
+
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
183
+
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:name
184
+
(* parentId can be null meaning top-level, or absent if not requested *)
185
+
|> Jsont.Object.opt_mem "parentId" Proto_id.jsont ~enc:parent_id
186
+
(* role can be null meaning no role, or absent if not requested *)
187
+
|> Jsont.Object.opt_mem "role" role_jsont ~enc:role
188
+
|> Jsont.Object.opt_mem "sortOrder" Proto_int53.Unsigned.jsont ~enc:sort_order
189
+
|> Jsont.Object.opt_mem "totalEmails" Proto_int53.Unsigned.jsont ~enc:total_emails
190
+
|> Jsont.Object.opt_mem "unreadEmails" Proto_int53.Unsigned.jsont ~enc:unread_emails
191
+
|> Jsont.Object.opt_mem "totalThreads" Proto_int53.Unsigned.jsont ~enc:total_threads
192
+
|> Jsont.Object.opt_mem "unreadThreads" Proto_int53.Unsigned.jsont ~enc:unread_threads
193
+
|> Jsont.Object.opt_mem "myRights" Rights.jsont ~enc:my_rights
194
+
|> Jsont.Object.opt_mem "isSubscribed" Jsont.bool ~enc:is_subscribed
195
+
|> Jsont.Object.finish
196
+
197
+
module Filter_condition = struct
198
+
type t = {
199
+
parent_id : Proto_id.t option option;
200
+
name : string option;
201
+
role : role option option;
202
+
has_any_role : bool option;
203
+
is_subscribed : bool option;
204
+
}
205
+
206
+
let make parent_id name role has_any_role is_subscribed =
207
+
{ parent_id; name; role; has_any_role; is_subscribed }
208
+
209
+
let jsont =
210
+
let kind = "MailboxFilterCondition" in
211
+
(* parentId and role can be absent, null, or have a value - RFC 8621 Section 2.1 *)
212
+
(* Use opt_mem with Jsont.option to get option option type:
213
+
- None = field absent (don't filter)
214
+
- Some None = field present with null (filter for no parent/role)
215
+
- Some (Some x) = field present with value (filter for specific value) *)
216
+
let nullable_id = Jsont.(option Proto_id.jsont) in
217
+
let nullable_role = Jsont.(option role_jsont) in
218
+
Jsont.Object.map ~kind make
219
+
|> Jsont.Object.opt_mem "parentId" nullable_id ~enc:(fun f -> f.parent_id)
220
+
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:(fun f -> f.name)
221
+
|> Jsont.Object.opt_mem "role" nullable_role ~enc:(fun f -> f.role)
222
+
|> Jsont.Object.opt_mem "hasAnyRole" Jsont.bool ~enc:(fun f -> f.has_any_role)
223
+
|> Jsont.Object.opt_mem "isSubscribed" Jsont.bool ~enc:(fun f -> f.is_subscribed)
224
+
|> Jsont.Object.finish
225
+
end
+150
lib/mail/mail_mailbox.mli
+150
lib/mail/mail_mailbox.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Mailbox type as defined in RFC 8621 Section 2
7
+
8
+
@canonical Jmap.Proto.Mailbox *)
9
+
10
+
(** {1 Mailbox Properties}
11
+
12
+
Polymorphic variants for type-safe property selection in Mailbox/get requests.
13
+
These correspond to the properties defined in RFC 8621 Section 2. *)
14
+
15
+
(** All Mailbox properties that can be requested. *)
16
+
type property = [
17
+
| `Id
18
+
| `Name
19
+
| `Parent_id
20
+
| `Role
21
+
| `Sort_order
22
+
| `Total_emails
23
+
| `Unread_emails
24
+
| `Total_threads
25
+
| `Unread_threads
26
+
| `My_rights
27
+
| `Is_subscribed
28
+
]
29
+
30
+
val property_to_string : [< property ] -> string
31
+
(** Convert a property to its wire name (e.g., [`Parent_id] -> "parentId"). *)
32
+
33
+
val property_of_string : string -> property option
34
+
(** Parse a property name, case-sensitive. *)
35
+
36
+
(** {1 Mailbox Rights} *)
37
+
38
+
(** Rights the user has on a mailbox. *)
39
+
module Rights : sig
40
+
type t = {
41
+
may_read_items : bool;
42
+
may_add_items : bool;
43
+
may_remove_items : bool;
44
+
may_set_seen : bool;
45
+
may_set_keywords : bool;
46
+
may_create_child : bool;
47
+
may_rename : bool;
48
+
may_delete : bool;
49
+
may_submit : bool;
50
+
}
51
+
52
+
val may_read_items : t -> bool
53
+
val may_add_items : t -> bool
54
+
val may_remove_items : t -> bool
55
+
val may_set_seen : t -> bool
56
+
val may_set_keywords : t -> bool
57
+
val may_create_child : t -> bool
58
+
val may_rename : t -> bool
59
+
val may_delete : t -> bool
60
+
val may_submit : t -> bool
61
+
62
+
val jsont : t Jsont.t
63
+
end
64
+
65
+
(** {1 Standard Roles} *)
66
+
67
+
(** Standard mailbox roles per RFC 8621 Section 2 and draft-ietf-mailmaint. *)
68
+
type role = [
69
+
| `All
70
+
| `Archive
71
+
| `Drafts
72
+
| `Flagged
73
+
| `Important
74
+
| `Inbox
75
+
| `Junk
76
+
| `Sent
77
+
| `Subscribed
78
+
| `Trash
79
+
| `Snoozed (** draft-ietf-mailmaint: Messages snoozed until a later time. *)
80
+
| `Scheduled (** draft-ietf-mailmaint: Messages scheduled to send. *)
81
+
| `Memos (** draft-ietf-mailmaint: Messages with the $memo keyword. *)
82
+
| `Other of string
83
+
]
84
+
85
+
val role_to_string : role -> string
86
+
val role_of_string : string -> role
87
+
val role_jsont : role Jsont.t
88
+
89
+
(** {1 Mailbox} *)
90
+
91
+
type t = {
92
+
id : Proto_id.t option;
93
+
(** Server-assigned mailbox id. *)
94
+
name : string option;
95
+
(** User-visible name (UTF-8). *)
96
+
parent_id : Proto_id.t option;
97
+
(** Id of parent mailbox, or [None] for root. Note: [None] can mean
98
+
either "not requested" or "top-level mailbox". *)
99
+
role : role option;
100
+
(** Standard role, if any. Note: [None] can mean either "not requested"
101
+
or "no role assigned". *)
102
+
sort_order : int64 option;
103
+
(** Sort order hint (lower = displayed first). *)
104
+
total_emails : int64 option;
105
+
(** Total number of emails in mailbox. *)
106
+
unread_emails : int64 option;
107
+
(** Number of unread emails. *)
108
+
total_threads : int64 option;
109
+
(** Total number of threads. *)
110
+
unread_threads : int64 option;
111
+
(** Number of threads with unread emails. *)
112
+
my_rights : Rights.t option;
113
+
(** User's rights on this mailbox. *)
114
+
is_subscribed : bool option;
115
+
(** Whether user is subscribed to this mailbox. *)
116
+
}
117
+
118
+
val id : t -> Proto_id.t option
119
+
val name : t -> string option
120
+
val parent_id : t -> Proto_id.t option
121
+
val role : t -> role option
122
+
val sort_order : t -> int64 option
123
+
val total_emails : t -> int64 option
124
+
val unread_emails : t -> int64 option
125
+
val total_threads : t -> int64 option
126
+
val unread_threads : t -> int64 option
127
+
val my_rights : t -> Rights.t option
128
+
val is_subscribed : t -> bool option
129
+
130
+
val jsont : t Jsont.t
131
+
132
+
(** {1 Mailbox Filter Conditions} *)
133
+
134
+
(** Filter conditions for Mailbox/query. *)
135
+
module Filter_condition : sig
136
+
type t = {
137
+
parent_id : Proto_id.t option option;
138
+
(** Filter by parent. [Some None] = top-level only. *)
139
+
name : string option;
140
+
(** Filter by exact name match. *)
141
+
role : role option option;
142
+
(** Filter by role. [Some None] = no role. *)
143
+
has_any_role : bool option;
144
+
(** Filter by whether mailbox has any role. *)
145
+
is_subscribed : bool option;
146
+
(** Filter by subscription status. *)
147
+
}
148
+
149
+
val jsont : t Jsont.t
150
+
end
+28
lib/mail/mail_snippet.ml
+28
lib/mail/mail_snippet.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type t = {
7
+
email_id : Proto_id.t;
8
+
subject : string option;
9
+
preview : string option;
10
+
}
11
+
12
+
let email_id t = t.email_id
13
+
let subject t = t.subject
14
+
let preview t = t.preview
15
+
16
+
let make email_id subject preview = { email_id; subject; preview }
17
+
18
+
let jsont =
19
+
let kind = "SearchSnippet" in
20
+
(* subject and preview can be null per RFC 8621 Section 5 *)
21
+
let nullable_string = Jsont.(option string) in
22
+
Jsont.Object.map ~kind make
23
+
|> Jsont.Object.mem "emailId" Proto_id.jsont ~enc:email_id
24
+
|> Jsont.Object.mem "subject" nullable_string
25
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:subject
26
+
|> Jsont.Object.mem "preview" nullable_string
27
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:preview
28
+
|> Jsont.Object.finish
+23
lib/mail/mail_snippet.mli
+23
lib/mail/mail_snippet.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** SearchSnippet type as defined in RFC 8621 Section 5
7
+
8
+
@canonical Jmap.Proto.Search_snippet *)
9
+
10
+
type t = {
11
+
email_id : Proto_id.t;
12
+
(** The email this snippet is for. *)
13
+
subject : string option;
14
+
(** HTML snippet of matching subject text. *)
15
+
preview : string option;
16
+
(** HTML snippet of matching body text. *)
17
+
}
18
+
19
+
val email_id : t -> Proto_id.t
20
+
val subject : t -> string option
21
+
val preview : t -> string option
22
+
23
+
val jsont : t Jsont.t
+224
lib/mail/mail_submission.ml
+224
lib/mail/mail_submission.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* EmailSubmission properties *)
7
+
8
+
type property = [
9
+
| `Id
10
+
| `Identity_id
11
+
| `Email_id
12
+
| `Thread_id
13
+
| `Envelope
14
+
| `Send_at
15
+
| `Undo_status
16
+
| `Delivery_status
17
+
| `Dsn_blob_ids
18
+
| `Mdn_blob_ids
19
+
]
20
+
21
+
let property_to_string : [< property ] -> string = function
22
+
| `Id -> "id"
23
+
| `Identity_id -> "identityId"
24
+
| `Email_id -> "emailId"
25
+
| `Thread_id -> "threadId"
26
+
| `Envelope -> "envelope"
27
+
| `Send_at -> "sendAt"
28
+
| `Undo_status -> "undoStatus"
29
+
| `Delivery_status -> "deliveryStatus"
30
+
| `Dsn_blob_ids -> "dsnBlobIds"
31
+
| `Mdn_blob_ids -> "mdnBlobIds"
32
+
33
+
let property_of_string s : property option =
34
+
match s with
35
+
| "id" -> Some `Id
36
+
| "identityId" -> Some `Identity_id
37
+
| "emailId" -> Some `Email_id
38
+
| "threadId" -> Some `Thread_id
39
+
| "envelope" -> Some `Envelope
40
+
| "sendAt" -> Some `Send_at
41
+
| "undoStatus" -> Some `Undo_status
42
+
| "deliveryStatus" -> Some `Delivery_status
43
+
| "dsnBlobIds" -> Some `Dsn_blob_ids
44
+
| "mdnBlobIds" -> Some `Mdn_blob_ids
45
+
| _ -> None
46
+
47
+
module Address = struct
48
+
type t = {
49
+
email : string;
50
+
parameters : (string * string) list option;
51
+
}
52
+
53
+
let email t = t.email
54
+
let parameters t = t.parameters
55
+
56
+
let make email parameters = { email; parameters }
57
+
58
+
let jsont =
59
+
let kind = "EmailSubmission Address" in
60
+
Jsont.Object.map ~kind make
61
+
|> Jsont.Object.mem "email" Jsont.string ~enc:email
62
+
|> Jsont.Object.opt_mem "parameters" (Proto_json_map.of_string Jsont.string) ~enc:parameters
63
+
|> Jsont.Object.finish
64
+
end
65
+
66
+
module Envelope = struct
67
+
type t = {
68
+
mail_from : Address.t;
69
+
rcpt_to : Address.t list;
70
+
}
71
+
72
+
let mail_from t = t.mail_from
73
+
let rcpt_to t = t.rcpt_to
74
+
75
+
let make mail_from rcpt_to = { mail_from; rcpt_to }
76
+
77
+
let jsont =
78
+
let kind = "Envelope" in
79
+
Jsont.Object.map ~kind make
80
+
|> Jsont.Object.mem "mailFrom" Address.jsont ~enc:mail_from
81
+
|> Jsont.Object.mem "rcptTo" (Jsont.list Address.jsont) ~enc:rcpt_to
82
+
|> Jsont.Object.finish
83
+
end
84
+
85
+
module Delivery_status = struct
86
+
type delivered = [ `Queued | `Yes | `No | `Unknown ]
87
+
88
+
let delivered_to_string = function
89
+
| `Queued -> "queued"
90
+
| `Yes -> "yes"
91
+
| `No -> "no"
92
+
| `Unknown -> "unknown"
93
+
94
+
let delivered_of_string = function
95
+
| "queued" -> `Queued
96
+
| "yes" -> `Yes
97
+
| "no" -> `No
98
+
| _ -> `Unknown
99
+
100
+
let delivered_jsont =
101
+
Jsont.map ~kind:"DeliveryStatus.delivered"
102
+
~dec:delivered_of_string ~enc:delivered_to_string Jsont.string
103
+
104
+
type displayed = [ `Unknown | `Yes ]
105
+
106
+
let displayed_to_string = function
107
+
| `Unknown -> "unknown"
108
+
| `Yes -> "yes"
109
+
110
+
let displayed_of_string = function
111
+
| "yes" -> `Yes
112
+
| _ -> `Unknown
113
+
114
+
let displayed_jsont =
115
+
Jsont.map ~kind:"DeliveryStatus.displayed"
116
+
~dec:displayed_of_string ~enc:displayed_to_string Jsont.string
117
+
118
+
type t = {
119
+
smtp_reply : string;
120
+
delivered : delivered;
121
+
displayed : displayed;
122
+
}
123
+
124
+
let smtp_reply t = t.smtp_reply
125
+
let delivered t = t.delivered
126
+
let displayed t = t.displayed
127
+
128
+
let make smtp_reply delivered displayed =
129
+
{ smtp_reply; delivered; displayed }
130
+
131
+
let jsont =
132
+
let kind = "DeliveryStatus" in
133
+
Jsont.Object.map ~kind make
134
+
|> Jsont.Object.mem "smtpReply" Jsont.string ~enc:smtp_reply
135
+
|> Jsont.Object.mem "delivered" delivered_jsont ~enc:delivered
136
+
|> Jsont.Object.mem "displayed" displayed_jsont ~enc:displayed
137
+
|> Jsont.Object.finish
138
+
end
139
+
140
+
type undo_status = [ `Pending | `Final | `Canceled ]
141
+
142
+
let undo_status_to_string = function
143
+
| `Pending -> "pending"
144
+
| `Final -> "final"
145
+
| `Canceled -> "canceled"
146
+
147
+
let undo_status_of_string = function
148
+
| "pending" -> `Pending
149
+
| "final" -> `Final
150
+
| "canceled" -> `Canceled
151
+
| s -> Jsont.Error.msgf Jsont.Meta.none "Unknown undo status: %s" s
152
+
153
+
let undo_status_jsont =
154
+
Jsont.map ~kind:"UndoStatus"
155
+
~dec:undo_status_of_string ~enc:undo_status_to_string Jsont.string
156
+
157
+
type t = {
158
+
id : Proto_id.t option;
159
+
identity_id : Proto_id.t option;
160
+
email_id : Proto_id.t option;
161
+
thread_id : Proto_id.t option;
162
+
envelope : Envelope.t option;
163
+
send_at : Ptime.t option;
164
+
undo_status : undo_status option;
165
+
delivery_status : (string * Delivery_status.t) list option;
166
+
dsn_blob_ids : Proto_id.t list option;
167
+
mdn_blob_ids : Proto_id.t list option;
168
+
}
169
+
170
+
let id t = t.id
171
+
let identity_id t = t.identity_id
172
+
let email_id t = t.email_id
173
+
let thread_id t = t.thread_id
174
+
let envelope t = t.envelope
175
+
let send_at t = t.send_at
176
+
let undo_status t = t.undo_status
177
+
let delivery_status t = t.delivery_status
178
+
let dsn_blob_ids t = t.dsn_blob_ids
179
+
let mdn_blob_ids t = t.mdn_blob_ids
180
+
181
+
let make id identity_id email_id thread_id envelope send_at undo_status
182
+
delivery_status dsn_blob_ids mdn_blob_ids =
183
+
{ id; identity_id; email_id; thread_id; envelope; send_at; undo_status;
184
+
delivery_status; dsn_blob_ids; mdn_blob_ids }
185
+
186
+
let jsont =
187
+
let kind = "EmailSubmission" in
188
+
Jsont.Object.map ~kind make
189
+
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
190
+
|> Jsont.Object.opt_mem "identityId" Proto_id.jsont ~enc:identity_id
191
+
|> Jsont.Object.opt_mem "emailId" Proto_id.jsont ~enc:email_id
192
+
|> Jsont.Object.opt_mem "threadId" Proto_id.jsont ~enc:thread_id
193
+
|> Jsont.Object.opt_mem "envelope" Envelope.jsont ~enc:envelope
194
+
|> Jsont.Object.opt_mem "sendAt" Proto_date.Utc.jsont ~enc:send_at
195
+
|> Jsont.Object.opt_mem "undoStatus" undo_status_jsont ~enc:undo_status
196
+
|> Jsont.Object.opt_mem "deliveryStatus" (Proto_json_map.of_string Delivery_status.jsont) ~enc:delivery_status
197
+
|> Jsont.Object.opt_mem "dsnBlobIds" (Jsont.list Proto_id.jsont) ~enc:dsn_blob_ids
198
+
|> Jsont.Object.opt_mem "mdnBlobIds" (Jsont.list Proto_id.jsont) ~enc:mdn_blob_ids
199
+
|> Jsont.Object.finish
200
+
201
+
module Filter_condition = struct
202
+
type t = {
203
+
identity_ids : Proto_id.t list option;
204
+
email_ids : Proto_id.t list option;
205
+
thread_ids : Proto_id.t list option;
206
+
undo_status : undo_status option;
207
+
before : Ptime.t option;
208
+
after : Ptime.t option;
209
+
}
210
+
211
+
let make identity_ids email_ids thread_ids undo_status before after =
212
+
{ identity_ids; email_ids; thread_ids; undo_status; before; after }
213
+
214
+
let jsont =
215
+
let kind = "EmailSubmissionFilterCondition" in
216
+
Jsont.Object.map ~kind make
217
+
|> Jsont.Object.opt_mem "identityIds" (Jsont.list Proto_id.jsont) ~enc:(fun f -> f.identity_ids)
218
+
|> Jsont.Object.opt_mem "emailIds" (Jsont.list Proto_id.jsont) ~enc:(fun f -> f.email_ids)
219
+
|> Jsont.Object.opt_mem "threadIds" (Jsont.list Proto_id.jsont) ~enc:(fun f -> f.thread_ids)
220
+
|> Jsont.Object.opt_mem "undoStatus" undo_status_jsont ~enc:(fun f -> f.undo_status)
221
+
|> Jsont.Object.opt_mem "before" Proto_date.Utc.jsont ~enc:(fun f -> f.before)
222
+
|> Jsont.Object.opt_mem "after" Proto_date.Utc.jsont ~enc:(fun f -> f.after)
223
+
|> Jsont.Object.finish
224
+
end
+162
lib/mail/mail_submission.mli
+162
lib/mail/mail_submission.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** EmailSubmission type as defined in RFC 8621 Section 7
7
+
8
+
@canonical Jmap.Proto.Submission *)
9
+
10
+
(** {1 EmailSubmission Properties}
11
+
12
+
Polymorphic variants for type-safe property selection in EmailSubmission/get requests.
13
+
These correspond to the properties defined in RFC 8621 Section 7. *)
14
+
15
+
(** All EmailSubmission properties that can be requested. *)
16
+
type property = [
17
+
| `Id
18
+
| `Identity_id
19
+
| `Email_id
20
+
| `Thread_id
21
+
| `Envelope
22
+
| `Send_at
23
+
| `Undo_status
24
+
| `Delivery_status
25
+
| `Dsn_blob_ids
26
+
| `Mdn_blob_ids
27
+
]
28
+
29
+
val property_to_string : [< property ] -> string
30
+
(** Convert a property to its wire name (e.g., [`Identity_id] -> "identityId"). *)
31
+
32
+
val property_of_string : string -> property option
33
+
(** Parse a property name, case-sensitive. *)
34
+
35
+
(** {1 Address} *)
36
+
37
+
(** An address with optional SMTP parameters. *)
38
+
module Address : sig
39
+
type t = {
40
+
email : string;
41
+
(** The email address. *)
42
+
parameters : (string * string) list option;
43
+
(** Optional SMTP parameters. *)
44
+
}
45
+
46
+
val email : t -> string
47
+
val parameters : t -> (string * string) list option
48
+
49
+
val jsont : t Jsont.t
50
+
end
51
+
52
+
(** {1 Envelope} *)
53
+
54
+
(** SMTP envelope. *)
55
+
module Envelope : sig
56
+
type t = {
57
+
mail_from : Address.t;
58
+
(** MAIL FROM address. *)
59
+
rcpt_to : Address.t list;
60
+
(** RCPT TO addresses. *)
61
+
}
62
+
63
+
val mail_from : t -> Address.t
64
+
val rcpt_to : t -> Address.t list
65
+
66
+
val jsont : t Jsont.t
67
+
end
68
+
69
+
(** {1 Delivery Status} *)
70
+
71
+
(** Status of delivery to a recipient. *)
72
+
module Delivery_status : sig
73
+
type delivered = [
74
+
| `Queued
75
+
| `Yes
76
+
| `No
77
+
| `Unknown
78
+
]
79
+
80
+
type displayed = [
81
+
| `Unknown
82
+
| `Yes
83
+
]
84
+
85
+
type t = {
86
+
smtp_reply : string;
87
+
(** The SMTP reply string. *)
88
+
delivered : delivered;
89
+
(** Delivery status. *)
90
+
displayed : displayed;
91
+
(** MDN display status. *)
92
+
}
93
+
94
+
val smtp_reply : t -> string
95
+
val delivered : t -> delivered
96
+
val displayed : t -> displayed
97
+
98
+
val jsont : t Jsont.t
99
+
end
100
+
101
+
(** {1 Undo Status} *)
102
+
103
+
type undo_status = [
104
+
| `Pending
105
+
| `Final
106
+
| `Canceled
107
+
]
108
+
109
+
val undo_status_jsont : undo_status Jsont.t
110
+
111
+
(** {1 EmailSubmission} *)
112
+
113
+
type t = {
114
+
id : Proto_id.t option;
115
+
(** Server-assigned submission id. *)
116
+
identity_id : Proto_id.t option;
117
+
(** The identity used to send. *)
118
+
email_id : Proto_id.t option;
119
+
(** The email that was submitted. *)
120
+
thread_id : Proto_id.t option;
121
+
(** The thread of the submitted email. *)
122
+
envelope : Envelope.t option;
123
+
(** The envelope used, if different from email headers. *)
124
+
send_at : Ptime.t option;
125
+
(** When the email was/will be sent. *)
126
+
undo_status : undo_status option;
127
+
(** Whether sending can be undone. *)
128
+
delivery_status : (string * Delivery_status.t) list option;
129
+
(** Delivery status per recipient. *)
130
+
dsn_blob_ids : Proto_id.t list option;
131
+
(** Blob ids of received DSN messages. *)
132
+
mdn_blob_ids : Proto_id.t list option;
133
+
(** Blob ids of received MDN messages. *)
134
+
}
135
+
136
+
val id : t -> Proto_id.t option
137
+
val identity_id : t -> Proto_id.t option
138
+
val email_id : t -> Proto_id.t option
139
+
val thread_id : t -> Proto_id.t option
140
+
val envelope : t -> Envelope.t option
141
+
val send_at : t -> Ptime.t option
142
+
val undo_status : t -> undo_status option
143
+
val delivery_status : t -> (string * Delivery_status.t) list option
144
+
val dsn_blob_ids : t -> Proto_id.t list option
145
+
val mdn_blob_ids : t -> Proto_id.t list option
146
+
147
+
val jsont : t Jsont.t
148
+
149
+
(** {1 Filter Conditions} *)
150
+
151
+
module Filter_condition : sig
152
+
type t = {
153
+
identity_ids : Proto_id.t list option;
154
+
email_ids : Proto_id.t list option;
155
+
thread_ids : Proto_id.t list option;
156
+
undo_status : undo_status option;
157
+
before : Ptime.t option;
158
+
after : Ptime.t option;
159
+
}
160
+
161
+
val jsont : t Jsont.t
162
+
end
+40
lib/mail/mail_thread.ml
+40
lib/mail/mail_thread.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Thread properties *)
7
+
8
+
type property = [
9
+
| `Id
10
+
| `Email_ids
11
+
]
12
+
13
+
let property_to_string : [< property ] -> string = function
14
+
| `Id -> "id"
15
+
| `Email_ids -> "emailIds"
16
+
17
+
let property_of_string s : property option =
18
+
match s with
19
+
| "id" -> Some `Id
20
+
| "emailIds" -> Some `Email_ids
21
+
| _ -> None
22
+
23
+
(* Thread type *)
24
+
25
+
type t = {
26
+
id : Proto_id.t option;
27
+
email_ids : Proto_id.t list option;
28
+
}
29
+
30
+
let id t = t.id
31
+
let email_ids t = t.email_ids
32
+
33
+
let make id email_ids = { id; email_ids }
34
+
35
+
let jsont =
36
+
let kind = "Thread" in
37
+
Jsont.Object.map ~kind make
38
+
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
39
+
|> Jsont.Object.opt_mem "emailIds" (Jsont.list Proto_id.jsont) ~enc:email_ids
40
+
|> Jsont.Object.finish
+39
lib/mail/mail_thread.mli
+39
lib/mail/mail_thread.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Thread type as defined in RFC 8621 Section 3
7
+
8
+
@canonical Jmap.Proto.Thread *)
9
+
10
+
(** {1 Thread Properties}
11
+
12
+
Polymorphic variants for type-safe property selection in Thread/get requests.
13
+
Threads have only two properties per RFC 8621 Section 3. *)
14
+
15
+
(** All Thread properties that can be requested. *)
16
+
type property = [
17
+
| `Id
18
+
| `Email_ids
19
+
]
20
+
21
+
val property_to_string : [< property ] -> string
22
+
(** Convert a property to its wire name (e.g., [`Email_ids] -> "emailIds"). *)
23
+
24
+
val property_of_string : string -> property option
25
+
(** Parse a property name, case-sensitive. *)
26
+
27
+
(** {1 Thread Object} *)
28
+
29
+
type t = {
30
+
id : Proto_id.t option;
31
+
(** Server-assigned thread id. *)
32
+
email_ids : Proto_id.t list option;
33
+
(** Ids of emails in this thread, in date order. *)
34
+
}
35
+
36
+
val id : t -> Proto_id.t option
37
+
val email_ids : t -> Proto_id.t list option
38
+
39
+
val jsont : t Jsont.t
+44
lib/mail/mail_vacation.ml
+44
lib/mail/mail_vacation.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type t = {
7
+
id : Proto_id.t;
8
+
is_enabled : bool;
9
+
from_date : Ptime.t option;
10
+
to_date : Ptime.t option;
11
+
subject : string option;
12
+
text_body : string option;
13
+
html_body : string option;
14
+
}
15
+
16
+
let id t = t.id
17
+
let is_enabled t = t.is_enabled
18
+
let from_date t = t.from_date
19
+
let to_date t = t.to_date
20
+
let subject t = t.subject
21
+
let text_body t = t.text_body
22
+
let html_body t = t.html_body
23
+
24
+
let singleton_id = Proto_id.of_string_exn "singleton"
25
+
26
+
let make id is_enabled from_date to_date subject text_body html_body =
27
+
{ id; is_enabled; from_date; to_date; subject; text_body; html_body }
28
+
29
+
let jsont =
30
+
let kind = "VacationResponse" in
31
+
(* subject, textBody, htmlBody can be null per RFC 8621 Section 8 *)
32
+
let nullable_string = Jsont.(option string) in
33
+
Jsont.Object.map ~kind make
34
+
|> Jsont.Object.mem "id" Proto_id.jsont ~enc:id
35
+
|> Jsont.Object.mem "isEnabled" Jsont.bool ~enc:is_enabled
36
+
|> Jsont.Object.opt_mem "fromDate" Proto_date.Utc.jsont ~enc:from_date
37
+
|> Jsont.Object.opt_mem "toDate" Proto_date.Utc.jsont ~enc:to_date
38
+
|> Jsont.Object.mem "subject" nullable_string
39
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:subject
40
+
|> Jsont.Object.mem "textBody" nullable_string
41
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:text_body
42
+
|> Jsont.Object.mem "htmlBody" nullable_string
43
+
~dec_absent:None ~enc_omit:Option.is_none ~enc:html_body
44
+
|> Jsont.Object.finish
+38
lib/mail/mail_vacation.mli
+38
lib/mail/mail_vacation.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** VacationResponse type as defined in RFC 8621 Section 8
7
+
8
+
@canonical Jmap.Proto.Vacation *)
9
+
10
+
type t = {
11
+
id : Proto_id.t;
12
+
(** Always "singleton" - there is only one vacation response. *)
13
+
is_enabled : bool;
14
+
(** Whether the vacation response is active. *)
15
+
from_date : Ptime.t option;
16
+
(** When to start sending responses. *)
17
+
to_date : Ptime.t option;
18
+
(** When to stop sending responses. *)
19
+
subject : string option;
20
+
(** Subject for the auto-reply. *)
21
+
text_body : string option;
22
+
(** Plain text body. *)
23
+
html_body : string option;
24
+
(** HTML body. *)
25
+
}
26
+
27
+
val id : t -> Proto_id.t
28
+
val is_enabled : t -> bool
29
+
val from_date : t -> Ptime.t option
30
+
val to_date : t -> Ptime.t option
31
+
val subject : t -> string option
32
+
val text_body : t -> string option
33
+
val html_body : t -> string option
34
+
35
+
val jsont : t Jsont.t
36
+
37
+
(** The singleton id for VacationResponse. *)
38
+
val singleton_id : Proto_id.t
+40
lib/proto/jmap_proto.ml
+40
lib/proto/jmap_proto.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP Protocol Types (RFC 8620/8621)
7
+
8
+
This module re-exports all JMAP core and mail protocol types. *)
9
+
10
+
(** {1 Core Protocol Types (RFC 8620)} *)
11
+
12
+
module Id = Proto_id
13
+
module Int53 = Proto_int53
14
+
module Date = Proto_date
15
+
module Json_map = Proto_json_map
16
+
module Unknown = Proto_unknown
17
+
module Error = Proto_error
18
+
module Capability = Proto_capability
19
+
module Filter = Proto_filter
20
+
module Method = Proto_method
21
+
module Invocation = Proto_invocation
22
+
module Request = Proto_request
23
+
module Response = Proto_response
24
+
module Session = Proto_session
25
+
module Push = Proto_push
26
+
module Blob = Proto_blob
27
+
28
+
(** {1 Mail Types (RFC 8621)} *)
29
+
30
+
module Email_address = Mail_address
31
+
module Email_header = Mail_header
32
+
module Email_body = Mail_body
33
+
module Mailbox = Mail_mailbox
34
+
module Thread = Mail_thread
35
+
module Email = Mail_email
36
+
module Search_snippet = Mail_snippet
37
+
module Identity = Mail_identity
38
+
module Submission = Mail_submission
39
+
module Vacation = Mail_vacation
40
+
module Mail_filter = Mail_filter
+105
lib/proto/proto_blob.ml
+105
lib/proto/proto_blob.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type upload_response = {
7
+
account_id : Proto_id.t;
8
+
blob_id : Proto_id.t;
9
+
type_ : string;
10
+
size : int64;
11
+
}
12
+
13
+
let upload_response_account_id t = t.account_id
14
+
let upload_response_blob_id t = t.blob_id
15
+
let upload_response_type t = t.type_
16
+
let upload_response_size t = t.size
17
+
18
+
let upload_response_make account_id blob_id type_ size =
19
+
{ account_id; blob_id; type_; size }
20
+
21
+
let upload_response_jsont =
22
+
let kind = "Upload response" in
23
+
Jsont.Object.map ~kind upload_response_make
24
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:upload_response_account_id
25
+
|> Jsont.Object.mem "blobId" Proto_id.jsont ~enc:upload_response_blob_id
26
+
|> Jsont.Object.mem "type" Jsont.string ~enc:upload_response_type
27
+
|> Jsont.Object.mem "size" Proto_int53.Unsigned.jsont ~enc:upload_response_size
28
+
|> Jsont.Object.finish
29
+
30
+
type download_vars = {
31
+
account_id : Proto_id.t;
32
+
blob_id : Proto_id.t;
33
+
type_ : string;
34
+
name : string;
35
+
}
36
+
37
+
let expand_download_url ~template vars =
38
+
let url_encode s =
39
+
(* Simple URL encoding *)
40
+
let buf = Buffer.create (String.length s * 3) in
41
+
String.iter (fun c ->
42
+
match c with
43
+
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '-' | '_' | '.' | '~' ->
44
+
Buffer.add_char buf c
45
+
| _ ->
46
+
Buffer.add_string buf (Printf.sprintf "%%%02X" (Char.code c))
47
+
) s;
48
+
Buffer.contents buf
49
+
in
50
+
template
51
+
|> String.split_on_char '{'
52
+
|> List.mapi (fun i part ->
53
+
if i = 0 then part
54
+
else
55
+
match String.index_opt part '}' with
56
+
| None -> "{" ^ part
57
+
| Some j ->
58
+
let var = String.sub part 0 j in
59
+
let rest = String.sub part (j + 1) (String.length part - j - 1) in
60
+
let value = match var with
61
+
| "accountId" -> url_encode (Proto_id.to_string vars.account_id)
62
+
| "blobId" -> url_encode (Proto_id.to_string vars.blob_id)
63
+
| "type" -> url_encode vars.type_
64
+
| "name" -> url_encode vars.name
65
+
| _ -> "{" ^ var ^ "}"
66
+
in
67
+
value ^ rest
68
+
)
69
+
|> String.concat ""
70
+
71
+
type copy_args = {
72
+
from_account_id : Proto_id.t;
73
+
account_id : Proto_id.t;
74
+
blob_ids : Proto_id.t list;
75
+
}
76
+
77
+
let copy_args_make from_account_id account_id blob_ids =
78
+
{ from_account_id; account_id; blob_ids }
79
+
80
+
let copy_args_jsont =
81
+
let kind = "Blob/copy args" in
82
+
Jsont.Object.map ~kind copy_args_make
83
+
|> Jsont.Object.mem "fromAccountId" Proto_id.jsont ~enc:(fun a -> a.from_account_id)
84
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
85
+
|> Jsont.Object.mem "blobIds" (Jsont.list Proto_id.jsont) ~enc:(fun a -> a.blob_ids)
86
+
|> Jsont.Object.finish
87
+
88
+
type copy_response = {
89
+
from_account_id : Proto_id.t;
90
+
account_id : Proto_id.t;
91
+
copied : (Proto_id.t * Proto_id.t) list option;
92
+
not_copied : (Proto_id.t * Proto_error.set_error) list option;
93
+
}
94
+
95
+
let copy_response_make from_account_id account_id copied not_copied =
96
+
{ from_account_id; account_id; copied; not_copied }
97
+
98
+
let copy_response_jsont =
99
+
let kind = "Blob/copy response" in
100
+
Jsont.Object.map ~kind copy_response_make
101
+
|> Jsont.Object.mem "fromAccountId" Proto_id.jsont ~enc:(fun r -> r.from_account_id)
102
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id)
103
+
|> Jsont.Object.opt_mem "copied" (Proto_json_map.of_id Proto_id.jsont) ~enc:(fun r -> r.copied)
104
+
|> Jsont.Object.opt_mem "notCopied" (Proto_json_map.of_id Proto_error.set_error_jsont) ~enc:(fun r -> r.not_copied)
105
+
|> Jsont.Object.finish
+67
lib/proto/proto_blob.mli
+67
lib/proto/proto_blob.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP blob upload/download types as defined in RFC 8620 Section 6
7
+
8
+
@canonical Jmap.Proto.Blob *)
9
+
10
+
(** {1 Upload Response} *)
11
+
12
+
(** Response from a blob upload. *)
13
+
type upload_response = {
14
+
account_id : Proto_id.t;
15
+
(** The account the blob was uploaded to. *)
16
+
blob_id : Proto_id.t;
17
+
(** The server-assigned blob id. *)
18
+
type_ : string;
19
+
(** The media type of the uploaded blob. *)
20
+
size : int64;
21
+
(** The size in octets. *)
22
+
}
23
+
24
+
val upload_response_account_id : upload_response -> Proto_id.t
25
+
val upload_response_blob_id : upload_response -> Proto_id.t
26
+
val upload_response_type : upload_response -> string
27
+
val upload_response_size : upload_response -> int64
28
+
29
+
val upload_response_jsont : upload_response Jsont.t
30
+
31
+
(** {1 Download URL Template} *)
32
+
33
+
(** Variables for the download URL template. *)
34
+
type download_vars = {
35
+
account_id : Proto_id.t;
36
+
blob_id : Proto_id.t;
37
+
type_ : string;
38
+
name : string;
39
+
}
40
+
41
+
val expand_download_url : template:string -> download_vars -> string
42
+
(** [expand_download_url ~template vars] expands the download URL template
43
+
with the given variables. Template uses {accountId}, {blobId},
44
+
{type}, and {name} placeholders. *)
45
+
46
+
(** {1 Blob/copy} *)
47
+
48
+
(** Arguments for Blob/copy. *)
49
+
type copy_args = {
50
+
from_account_id : Proto_id.t;
51
+
account_id : Proto_id.t;
52
+
blob_ids : Proto_id.t list;
53
+
}
54
+
55
+
val copy_args_jsont : copy_args Jsont.t
56
+
57
+
(** Response for Blob/copy. *)
58
+
type copy_response = {
59
+
from_account_id : Proto_id.t;
60
+
account_id : Proto_id.t;
61
+
copied : (Proto_id.t * Proto_id.t) list option;
62
+
(** Map of old blob id to new blob id. *)
63
+
not_copied : (Proto_id.t * Proto_error.set_error) list option;
64
+
(** Blobs that could not be copied. *)
65
+
}
66
+
67
+
val copy_response_jsont : copy_response Jsont.t
+171
lib/proto/proto_capability.ml
+171
lib/proto/proto_capability.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let core = "urn:ietf:params:jmap:core"
7
+
let mail = "urn:ietf:params:jmap:mail"
8
+
let submission = "urn:ietf:params:jmap:submission"
9
+
let vacation_response = "urn:ietf:params:jmap:vacationresponse"
10
+
11
+
module Core = struct
12
+
type t = {
13
+
max_size_upload : int64;
14
+
max_concurrent_upload : int;
15
+
max_size_request : int64;
16
+
max_concurrent_requests : int;
17
+
max_calls_in_request : int;
18
+
max_objects_in_get : int;
19
+
max_objects_in_set : int;
20
+
collation_algorithms : string list;
21
+
}
22
+
23
+
let create ~max_size_upload ~max_concurrent_upload ~max_size_request
24
+
~max_concurrent_requests ~max_calls_in_request ~max_objects_in_get
25
+
~max_objects_in_set ~collation_algorithms =
26
+
{ max_size_upload; max_concurrent_upload; max_size_request;
27
+
max_concurrent_requests; max_calls_in_request; max_objects_in_get;
28
+
max_objects_in_set; collation_algorithms }
29
+
30
+
let max_size_upload t = t.max_size_upload
31
+
let max_concurrent_upload t = t.max_concurrent_upload
32
+
let max_size_request t = t.max_size_request
33
+
let max_concurrent_requests t = t.max_concurrent_requests
34
+
let max_calls_in_request t = t.max_calls_in_request
35
+
let max_objects_in_get t = t.max_objects_in_get
36
+
let max_objects_in_set t = t.max_objects_in_set
37
+
let collation_algorithms t = t.collation_algorithms
38
+
39
+
let make max_size_upload max_concurrent_upload max_size_request
40
+
max_concurrent_requests max_calls_in_request max_objects_in_get
41
+
max_objects_in_set collation_algorithms =
42
+
{ max_size_upload; max_concurrent_upload; max_size_request;
43
+
max_concurrent_requests; max_calls_in_request; max_objects_in_get;
44
+
max_objects_in_set; collation_algorithms }
45
+
46
+
let jsont =
47
+
let kind = "Core capability" in
48
+
Jsont.Object.map ~kind make
49
+
|> Jsont.Object.mem "maxSizeUpload" Proto_int53.Unsigned.jsont ~enc:max_size_upload
50
+
|> Jsont.Object.mem "maxConcurrentUpload" Jsont.int ~enc:max_concurrent_upload
51
+
|> Jsont.Object.mem "maxSizeRequest" Proto_int53.Unsigned.jsont ~enc:max_size_request
52
+
|> Jsont.Object.mem "maxConcurrentRequests" Jsont.int ~enc:max_concurrent_requests
53
+
|> Jsont.Object.mem "maxCallsInRequest" Jsont.int ~enc:max_calls_in_request
54
+
|> Jsont.Object.mem "maxObjectsInGet" Jsont.int ~enc:max_objects_in_get
55
+
|> Jsont.Object.mem "maxObjectsInSet" Jsont.int ~enc:max_objects_in_set
56
+
|> Jsont.Object.mem "collationAlgorithms" (Jsont.list Jsont.string) ~enc:collation_algorithms
57
+
|> Jsont.Object.finish
58
+
end
59
+
60
+
module Mail = struct
61
+
type t = {
62
+
max_mailboxes_per_email : int64 option;
63
+
max_mailbox_depth : int64 option;
64
+
max_size_mailbox_name : int64;
65
+
max_size_attachments_per_email : int64;
66
+
email_query_sort_options : string list;
67
+
may_create_top_level_mailbox : bool;
68
+
}
69
+
70
+
let create ?max_mailboxes_per_email ?max_mailbox_depth ~max_size_mailbox_name
71
+
~max_size_attachments_per_email ~email_query_sort_options
72
+
~may_create_top_level_mailbox () =
73
+
{ max_mailboxes_per_email; max_mailbox_depth; max_size_mailbox_name;
74
+
max_size_attachments_per_email; email_query_sort_options;
75
+
may_create_top_level_mailbox }
76
+
77
+
let max_mailboxes_per_email t = t.max_mailboxes_per_email
78
+
let max_mailbox_depth t = t.max_mailbox_depth
79
+
let max_size_mailbox_name t = t.max_size_mailbox_name
80
+
let max_size_attachments_per_email t = t.max_size_attachments_per_email
81
+
let email_query_sort_options t = t.email_query_sort_options
82
+
let may_create_top_level_mailbox t = t.may_create_top_level_mailbox
83
+
84
+
let make max_mailboxes_per_email max_mailbox_depth max_size_mailbox_name
85
+
max_size_attachments_per_email email_query_sort_options
86
+
may_create_top_level_mailbox =
87
+
{ max_mailboxes_per_email; max_mailbox_depth; max_size_mailbox_name;
88
+
max_size_attachments_per_email; email_query_sort_options;
89
+
may_create_top_level_mailbox }
90
+
91
+
let jsont =
92
+
let kind = "Mail capability" in
93
+
Jsont.Object.map ~kind make
94
+
|> Jsont.Object.opt_mem "maxMailboxesPerEmail" Proto_int53.Unsigned.jsont ~enc:max_mailboxes_per_email
95
+
|> Jsont.Object.opt_mem "maxMailboxDepth" Proto_int53.Unsigned.jsont ~enc:max_mailbox_depth
96
+
|> Jsont.Object.mem "maxSizeMailboxName" Proto_int53.Unsigned.jsont ~enc:max_size_mailbox_name
97
+
|> Jsont.Object.mem "maxSizeAttachmentsPerEmail" Proto_int53.Unsigned.jsont ~enc:max_size_attachments_per_email
98
+
|> Jsont.Object.mem "emailQuerySortOptions" (Jsont.list Jsont.string) ~enc:email_query_sort_options
99
+
|> Jsont.Object.mem "mayCreateTopLevelMailbox" Jsont.bool ~enc:may_create_top_level_mailbox
100
+
|> Jsont.Object.finish
101
+
end
102
+
103
+
module Submission = struct
104
+
type t = {
105
+
max_delayed_send : int64;
106
+
submission_extensions : (string * string list) list;
107
+
}
108
+
109
+
let create ~max_delayed_send ~submission_extensions =
110
+
{ max_delayed_send; submission_extensions }
111
+
112
+
let max_delayed_send t = t.max_delayed_send
113
+
let submission_extensions t = t.submission_extensions
114
+
115
+
let make max_delayed_send submission_extensions =
116
+
{ max_delayed_send; submission_extensions }
117
+
118
+
let submission_extensions_jsont =
119
+
Proto_json_map.of_string (Jsont.list Jsont.string)
120
+
121
+
let jsont =
122
+
let kind = "Submission capability" in
123
+
Jsont.Object.map ~kind make
124
+
|> Jsont.Object.mem "maxDelayedSend" Proto_int53.Unsigned.jsont ~enc:max_delayed_send
125
+
|> Jsont.Object.mem "submissionExtensions" submission_extensions_jsont ~enc:submission_extensions
126
+
|> Jsont.Object.finish
127
+
end
128
+
129
+
type capability =
130
+
| Core of Core.t
131
+
| Mail of Mail.t
132
+
| Submission of Submission.t
133
+
| Vacation_response
134
+
| Unknown of Jsont.json
135
+
136
+
let capability_of_json uri json =
137
+
match uri with
138
+
| u when u = core ->
139
+
(match Jsont.Json.decode' Core.jsont json with
140
+
| Ok c -> Core c
141
+
| Error _ -> Unknown json)
142
+
| u when u = mail ->
143
+
(match Jsont.Json.decode' Mail.jsont json with
144
+
| Ok m -> Mail m
145
+
| Error _ -> Unknown json)
146
+
| u when u = submission ->
147
+
(match Jsont.Json.decode' Submission.jsont json with
148
+
| Ok s -> Submission s
149
+
| Error _ -> Unknown json)
150
+
| u when u = vacation_response ->
151
+
Vacation_response
152
+
| _ ->
153
+
Unknown json
154
+
155
+
let capability_to_json (uri, cap) =
156
+
let encode jsont v =
157
+
match Jsont.Json.encode' jsont v with
158
+
| Ok json -> json
159
+
| Error _ -> Jsont.Object ([], Jsont.Meta.none)
160
+
in
161
+
match cap with
162
+
| Core c ->
163
+
(uri, encode Core.jsont c)
164
+
| Mail m ->
165
+
(uri, encode Mail.jsont m)
166
+
| Submission s ->
167
+
(uri, encode Submission.jsont s)
168
+
| Vacation_response ->
169
+
(uri, Jsont.Object ([], Jsont.Meta.none))
170
+
| Unknown json ->
171
+
(uri, json)
+145
lib/proto/proto_capability.mli
+145
lib/proto/proto_capability.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP capability types as defined in RFC 8620 Section 2
7
+
8
+
@canonical Jmap.Proto.Capability *)
9
+
10
+
(** {1 Standard Capability URIs} *)
11
+
12
+
val core : string
13
+
(** [urn:ietf:params:jmap:core] - Core JMAP capability (RFC 8620) *)
14
+
15
+
val mail : string
16
+
(** [urn:ietf:params:jmap:mail] - Mail capability (RFC 8621) *)
17
+
18
+
val submission : string
19
+
(** [urn:ietf:params:jmap:submission] - Email submission capability (RFC 8621) *)
20
+
21
+
val vacation_response : string
22
+
(** [urn:ietf:params:jmap:vacationresponse] - Vacation response capability (RFC 8621) *)
23
+
24
+
(** {1 Core Capability Object} *)
25
+
26
+
(** Core capability limits and configuration per RFC 8620 Section 2. *)
27
+
module Core : sig
28
+
type t = {
29
+
max_size_upload : int64;
30
+
(** Maximum size in octets for a single blob upload. *)
31
+
max_concurrent_upload : int;
32
+
(** Maximum number of concurrent upload requests. *)
33
+
max_size_request : int64;
34
+
(** Maximum size in octets of a single request. *)
35
+
max_concurrent_requests : int;
36
+
(** Maximum number of concurrent requests. *)
37
+
max_calls_in_request : int;
38
+
(** Maximum number of method calls in a single request. *)
39
+
max_objects_in_get : int;
40
+
(** Maximum number of objects in a single /get request. *)
41
+
max_objects_in_set : int;
42
+
(** Maximum number of objects in a single /set request. *)
43
+
collation_algorithms : string list;
44
+
(** Supported collation algorithms for sorting. *)
45
+
}
46
+
47
+
val create :
48
+
max_size_upload:int64 ->
49
+
max_concurrent_upload:int ->
50
+
max_size_request:int64 ->
51
+
max_concurrent_requests:int ->
52
+
max_calls_in_request:int ->
53
+
max_objects_in_get:int ->
54
+
max_objects_in_set:int ->
55
+
collation_algorithms:string list ->
56
+
t
57
+
58
+
val max_size_upload : t -> int64
59
+
val max_concurrent_upload : t -> int
60
+
val max_size_request : t -> int64
61
+
val max_concurrent_requests : t -> int
62
+
val max_calls_in_request : t -> int
63
+
val max_objects_in_get : t -> int
64
+
val max_objects_in_set : t -> int
65
+
val collation_algorithms : t -> string list
66
+
67
+
val jsont : t Jsont.t
68
+
(** JSON codec for core capability. *)
69
+
end
70
+
71
+
(** {1 Mail Capability Object} *)
72
+
73
+
(** Mail capability configuration per RFC 8621. *)
74
+
module Mail : sig
75
+
type t = {
76
+
max_mailboxes_per_email : int64 option;
77
+
(** Maximum number of mailboxes an email can belong to. *)
78
+
max_mailbox_depth : int64 option;
79
+
(** Maximum depth of mailbox hierarchy. *)
80
+
max_size_mailbox_name : int64;
81
+
(** Maximum size of a mailbox name in octets. *)
82
+
max_size_attachments_per_email : int64;
83
+
(** Maximum total size of attachments per email. *)
84
+
email_query_sort_options : string list;
85
+
(** Supported sort options for Email/query. *)
86
+
may_create_top_level_mailbox : bool;
87
+
(** Whether the user may create top-level mailboxes. *)
88
+
}
89
+
90
+
val create :
91
+
?max_mailboxes_per_email:int64 ->
92
+
?max_mailbox_depth:int64 ->
93
+
max_size_mailbox_name:int64 ->
94
+
max_size_attachments_per_email:int64 ->
95
+
email_query_sort_options:string list ->
96
+
may_create_top_level_mailbox:bool ->
97
+
unit ->
98
+
t
99
+
100
+
val max_mailboxes_per_email : t -> int64 option
101
+
val max_mailbox_depth : t -> int64 option
102
+
val max_size_mailbox_name : t -> int64
103
+
val max_size_attachments_per_email : t -> int64
104
+
val email_query_sort_options : t -> string list
105
+
val may_create_top_level_mailbox : t -> bool
106
+
107
+
val jsont : t Jsont.t
108
+
end
109
+
110
+
(** {1 Submission Capability Object} *)
111
+
112
+
module Submission : sig
113
+
type t = {
114
+
max_delayed_send : int64;
115
+
(** Maximum delay in seconds for delayed sending (0 = not supported). *)
116
+
submission_extensions : (string * string list) list;
117
+
(** SMTP extensions supported. *)
118
+
}
119
+
120
+
val create :
121
+
max_delayed_send:int64 ->
122
+
submission_extensions:(string * string list) list ->
123
+
t
124
+
125
+
val max_delayed_send : t -> int64
126
+
val submission_extensions : t -> (string * string list) list
127
+
128
+
val jsont : t Jsont.t
129
+
end
130
+
131
+
(** {1 Generic Capability Handling} *)
132
+
133
+
(** A capability value that can be either a known type or unknown JSON. *)
134
+
type capability =
135
+
| Core of Core.t
136
+
| Mail of Mail.t
137
+
| Submission of Submission.t
138
+
| Vacation_response (* No configuration *)
139
+
| Unknown of Jsont.json
140
+
141
+
val capability_of_json : string -> Jsont.json -> capability
142
+
(** [capability_of_json uri json] parses a capability from its URI and JSON value. *)
143
+
144
+
val capability_to_json : string * capability -> string * Jsont.json
145
+
(** [capability_to_json (uri, cap)] encodes a capability to URI and JSON. *)
+64
lib/proto/proto_date.ml
+64
lib/proto/proto_date.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Date and time types for JMAP.
7
+
8
+
JMAP uses RFC 3339 formatted date-time strings. *)
9
+
10
+
(** RFC 3339 date-time with any timezone offset *)
11
+
module Rfc3339 = struct
12
+
type t = Ptime.t
13
+
14
+
let of_string s =
15
+
match Ptime.of_rfc3339 s with
16
+
| Ok (t, _, _) -> Ok t
17
+
| Error _ -> Error (Printf.sprintf "Invalid RFC 3339 date: %s" s)
18
+
19
+
let to_string t =
20
+
(* Format with 'T' separator and timezone offset *)
21
+
Ptime.to_rfc3339 ~tz_offset_s:0 t
22
+
23
+
let jsont =
24
+
let kind = "Date" in
25
+
let dec s =
26
+
match of_string s with
27
+
| Ok t -> t
28
+
| Error msg -> Jsont.Error.msgf Jsont.Meta.none "%s: %s" kind msg
29
+
in
30
+
let enc = to_string in
31
+
Jsont.map ~kind ~dec ~enc Jsont.string
32
+
end
33
+
34
+
(** UTC date-time (must use 'Z' timezone suffix) *)
35
+
module Utc = struct
36
+
type t = Ptime.t
37
+
38
+
let of_string s =
39
+
(* Must end with 'Z' for UTC *)
40
+
let len = String.length s in
41
+
if len > 0 && s.[len - 1] <> 'Z' then
42
+
Error "UTCDate must use 'Z' timezone suffix"
43
+
else
44
+
match Ptime.of_rfc3339 s with
45
+
| Ok (t, _, _) -> Ok t
46
+
| Error _ -> Error (Printf.sprintf "Invalid RFC 3339 UTC date: %s" s)
47
+
48
+
let to_string t =
49
+
(* Always format with 'Z' suffix *)
50
+
Ptime.to_rfc3339 ~tz_offset_s:0 t
51
+
52
+
let of_ptime t = t
53
+
let to_ptime t = t
54
+
55
+
let jsont =
56
+
let kind = "UTCDate" in
57
+
let dec s =
58
+
match of_string s with
59
+
| Ok t -> t
60
+
| Error msg -> Jsont.Error.msgf Jsont.Meta.none "%s: %s" kind msg
61
+
in
62
+
let enc = to_string in
63
+
Jsont.map ~kind ~dec ~enc Jsont.string
64
+
end
+53
lib/proto/proto_date.mli
+53
lib/proto/proto_date.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Date and time types for JMAP.
7
+
8
+
JMAP uses RFC 3339 formatted date-time strings.
9
+
10
+
See {{:https://datatracker.ietf.org/doc/html/rfc8620#section-1.4} RFC 8620 Section 1.4}.
11
+
12
+
@canonical Jmap.Proto.Date *)
13
+
14
+
(** RFC 3339 date-time.
15
+
16
+
A date-time string with uppercase 'T' separator. May have any timezone. *)
17
+
module Rfc3339 : sig
18
+
type t = Ptime.t
19
+
(** The type of dates. *)
20
+
21
+
val of_string : string -> (t, string) result
22
+
(** [of_string s] parses an RFC 3339 date-time string. *)
23
+
24
+
val to_string : t -> string
25
+
(** [to_string d] formats [d] as an RFC 3339 string. *)
26
+
27
+
val jsont : t Jsont.t
28
+
(** JSON codec for RFC 3339 dates. *)
29
+
end
30
+
31
+
(** UTC date-time.
32
+
33
+
A date-time string that MUST have 'Z' as the timezone (UTC only). *)
34
+
module Utc : sig
35
+
type t = Ptime.t
36
+
(** The type of UTC dates. *)
37
+
38
+
val of_string : string -> (t, string) result
39
+
(** [of_string s] parses an RFC 3339 UTC date-time string.
40
+
Returns error if timezone is not 'Z'. *)
41
+
42
+
val to_string : t -> string
43
+
(** [to_string d] formats [d] as an RFC 3339 UTC string with 'Z'. *)
44
+
45
+
val of_ptime : Ptime.t -> t
46
+
(** [of_ptime p] creates a UTC date from a Ptime value. *)
47
+
48
+
val to_ptime : t -> Ptime.t
49
+
(** [to_ptime d] returns the underlying Ptime value. *)
50
+
51
+
val jsont : t Jsont.t
52
+
(** JSON codec for UTC dates. *)
53
+
end
+202
lib/proto/proto_error.ml
+202
lib/proto/proto_error.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module Request_error = struct
7
+
type urn = [
8
+
| `Unknown_capability
9
+
| `Not_json
10
+
| `Not_request
11
+
| `Limit
12
+
| `Other of string
13
+
]
14
+
15
+
let urn_to_string = function
16
+
| `Unknown_capability -> "urn:ietf:params:jmap:error:unknownCapability"
17
+
| `Not_json -> "urn:ietf:params:jmap:error:notJSON"
18
+
| `Not_request -> "urn:ietf:params:jmap:error:notRequest"
19
+
| `Limit -> "urn:ietf:params:jmap:error:limit"
20
+
| `Other s -> s
21
+
22
+
let urn_of_string = function
23
+
| "urn:ietf:params:jmap:error:unknownCapability" -> `Unknown_capability
24
+
| "urn:ietf:params:jmap:error:notJSON" -> `Not_json
25
+
| "urn:ietf:params:jmap:error:notRequest" -> `Not_request
26
+
| "urn:ietf:params:jmap:error:limit" -> `Limit
27
+
| s -> `Other s
28
+
29
+
let urn_jsont =
30
+
let kind = "Request error URN" in
31
+
Jsont.map ~kind
32
+
~dec:(fun s -> urn_of_string s)
33
+
~enc:urn_to_string
34
+
Jsont.string
35
+
36
+
type t = {
37
+
type_ : urn;
38
+
status : int;
39
+
title : string option;
40
+
detail : string option;
41
+
limit : string option;
42
+
}
43
+
44
+
let make type_ status title detail limit =
45
+
{ type_; status; title; detail; limit }
46
+
47
+
let type_ t = t.type_
48
+
let status t = t.status
49
+
let title t = t.title
50
+
let detail t = t.detail
51
+
let limit t = t.limit
52
+
53
+
let jsont =
54
+
let kind = "Request error" in
55
+
Jsont.Object.map ~kind make
56
+
|> Jsont.Object.mem "type" urn_jsont ~enc:type_
57
+
|> Jsont.Object.mem "status" Jsont.int ~enc:status
58
+
|> Jsont.Object.opt_mem "title" Jsont.string ~enc:title
59
+
|> Jsont.Object.opt_mem "detail" Jsont.string ~enc:detail
60
+
|> Jsont.Object.opt_mem "limit" Jsont.string ~enc:limit
61
+
|> Jsont.Object.finish
62
+
end
63
+
64
+
type method_error_type = [
65
+
| `Server_unavailable
66
+
| `Server_fail
67
+
| `Server_partial_fail
68
+
| `Unknown_method
69
+
| `Invalid_arguments
70
+
| `Invalid_result_reference
71
+
| `Forbidden
72
+
| `Account_not_found
73
+
| `Account_not_supported_by_method
74
+
| `Account_read_only
75
+
| `Other of string
76
+
]
77
+
78
+
let method_error_type_to_string = function
79
+
| `Server_unavailable -> "serverUnavailable"
80
+
| `Server_fail -> "serverFail"
81
+
| `Server_partial_fail -> "serverPartialFail"
82
+
| `Unknown_method -> "unknownMethod"
83
+
| `Invalid_arguments -> "invalidArguments"
84
+
| `Invalid_result_reference -> "invalidResultReference"
85
+
| `Forbidden -> "forbidden"
86
+
| `Account_not_found -> "accountNotFound"
87
+
| `Account_not_supported_by_method -> "accountNotSupportedByMethod"
88
+
| `Account_read_only -> "accountReadOnly"
89
+
| `Other s -> s
90
+
91
+
let method_error_type_of_string = function
92
+
| "serverUnavailable" -> `Server_unavailable
93
+
| "serverFail" -> `Server_fail
94
+
| "serverPartialFail" -> `Server_partial_fail
95
+
| "unknownMethod" -> `Unknown_method
96
+
| "invalidArguments" -> `Invalid_arguments
97
+
| "invalidResultReference" -> `Invalid_result_reference
98
+
| "forbidden" -> `Forbidden
99
+
| "accountNotFound" -> `Account_not_found
100
+
| "accountNotSupportedByMethod" -> `Account_not_supported_by_method
101
+
| "accountReadOnly" -> `Account_read_only
102
+
| s -> `Other s
103
+
104
+
let method_error_type_jsont =
105
+
let kind = "Method error type" in
106
+
Jsont.map ~kind
107
+
~dec:(fun s -> method_error_type_of_string s)
108
+
~enc:method_error_type_to_string
109
+
Jsont.string
110
+
111
+
type method_error = {
112
+
type_ : method_error_type;
113
+
description : string option;
114
+
}
115
+
116
+
let method_error_make type_ description = { type_; description }
117
+
let method_error_type_ t = t.type_
118
+
let method_error_description t = t.description
119
+
120
+
let method_error_jsont =
121
+
let kind = "Method error" in
122
+
Jsont.Object.map ~kind method_error_make
123
+
|> Jsont.Object.mem "type" method_error_type_jsont ~enc:method_error_type_
124
+
|> Jsont.Object.opt_mem "description" Jsont.string ~enc:method_error_description
125
+
|> Jsont.Object.finish
126
+
127
+
type set_error_type = [
128
+
| `Forbidden
129
+
| `Over_quota
130
+
| `Too_large
131
+
| `Rate_limit
132
+
| `Not_found
133
+
| `Invalid_patch
134
+
| `Will_destroy
135
+
| `Invalid_properties
136
+
| `Singleton
137
+
| `Forbidden_mail_from
138
+
| `Forbidden_from
139
+
| `Forbidden_to_send
140
+
| `Other of string
141
+
]
142
+
143
+
let set_error_type_to_string = function
144
+
| `Forbidden -> "forbidden"
145
+
| `Over_quota -> "overQuota"
146
+
| `Too_large -> "tooLarge"
147
+
| `Rate_limit -> "rateLimit"
148
+
| `Not_found -> "notFound"
149
+
| `Invalid_patch -> "invalidPatch"
150
+
| `Will_destroy -> "willDestroy"
151
+
| `Invalid_properties -> "invalidProperties"
152
+
| `Singleton -> "singleton"
153
+
| `Forbidden_mail_from -> "forbiddenMailFrom"
154
+
| `Forbidden_from -> "forbiddenFrom"
155
+
| `Forbidden_to_send -> "forbiddenToSend"
156
+
| `Other s -> s
157
+
158
+
let set_error_type_of_string = function
159
+
| "forbidden" -> `Forbidden
160
+
| "overQuota" -> `Over_quota
161
+
| "tooLarge" -> `Too_large
162
+
| "rateLimit" -> `Rate_limit
163
+
| "notFound" -> `Not_found
164
+
| "invalidPatch" -> `Invalid_patch
165
+
| "willDestroy" -> `Will_destroy
166
+
| "invalidProperties" -> `Invalid_properties
167
+
| "singleton" -> `Singleton
168
+
| "forbiddenMailFrom" -> `Forbidden_mail_from
169
+
| "forbiddenFrom" -> `Forbidden_from
170
+
| "forbiddenToSend" -> `Forbidden_to_send
171
+
| s -> `Other s
172
+
173
+
let set_error_type_jsont =
174
+
let kind = "SetError type" in
175
+
Jsont.map ~kind
176
+
~dec:(fun s -> set_error_type_of_string s)
177
+
~enc:set_error_type_to_string
178
+
Jsont.string
179
+
180
+
type set_error = {
181
+
type_ : set_error_type;
182
+
description : string option;
183
+
properties : string list option;
184
+
}
185
+
186
+
let set_error ?description ?properties type_ =
187
+
{ type_; description; properties }
188
+
189
+
let set_error_make type_ description properties =
190
+
{ type_; description; properties }
191
+
192
+
let set_error_type_ t = t.type_
193
+
let set_error_description t = t.description
194
+
let set_error_properties t = t.properties
195
+
196
+
let set_error_jsont =
197
+
let kind = "SetError" in
198
+
Jsont.Object.map ~kind set_error_make
199
+
|> Jsont.Object.mem "type" set_error_type_jsont ~enc:set_error_type_
200
+
|> Jsont.Object.opt_mem "description" Jsont.string ~enc:set_error_description
201
+
|> Jsont.Object.opt_mem "properties" (Jsont.list Jsont.string) ~enc:set_error_properties
202
+
|> Jsont.Object.finish
+158
lib/proto/proto_error.mli
+158
lib/proto/proto_error.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP error types as defined in RFC 8620 Section 3.6.1-3.6.2
7
+
8
+
@canonical Jmap.Proto.Error *)
9
+
10
+
(** {1 Request-Level Errors}
11
+
12
+
These errors are returned with an HTTP error status code and a JSON
13
+
Problem Details body (RFC 7807). *)
14
+
15
+
(** Request-level error URNs *)
16
+
module Request_error : sig
17
+
type urn = [
18
+
| `Unknown_capability
19
+
(** urn:ietf:params:jmap:error:unknownCapability
20
+
The client included a capability in "using" that the server does not support. *)
21
+
| `Not_json
22
+
(** urn:ietf:params:jmap:error:notJSON
23
+
The content type was not application/json or the request was not valid JSON. *)
24
+
| `Not_request
25
+
(** urn:ietf:params:jmap:error:notRequest
26
+
The request was valid JSON but not a valid JMAP Request object. *)
27
+
| `Limit
28
+
(** urn:ietf:params:jmap:error:limit
29
+
A server-defined limit was reached. *)
30
+
| `Other of string
31
+
(** Other URN not in the standard set. *)
32
+
]
33
+
34
+
val urn_to_string : urn -> string
35
+
(** [urn_to_string urn] returns the URN string. *)
36
+
37
+
val urn_of_string : string -> urn
38
+
(** [urn_of_string s] parses a URN string. *)
39
+
40
+
type t = {
41
+
type_ : urn;
42
+
(** The error type URN. *)
43
+
status : int;
44
+
(** HTTP status code. *)
45
+
title : string option;
46
+
(** Short human-readable summary. *)
47
+
detail : string option;
48
+
(** Longer human-readable explanation. *)
49
+
limit : string option;
50
+
(** For "limit" errors, the name of the limit that was exceeded. *)
51
+
}
52
+
(** A request-level error per RFC 7807 Problem Details. *)
53
+
54
+
val jsont : t Jsont.t
55
+
(** JSON codec for request-level errors. *)
56
+
end
57
+
58
+
(** {1 Method-Level Errors}
59
+
60
+
These are returned as the second element of an Invocation tuple
61
+
when a method call fails. *)
62
+
63
+
(** Standard method error types per RFC 8620 Section 3.6.2 *)
64
+
type method_error_type = [
65
+
| `Server_unavailable
66
+
(** The server is temporarily unavailable. *)
67
+
| `Server_fail
68
+
(** An unexpected error occurred. *)
69
+
| `Server_partial_fail
70
+
(** Some, but not all, changes were successfully made. *)
71
+
| `Unknown_method
72
+
(** The method name is not recognized. *)
73
+
| `Invalid_arguments
74
+
(** One or more arguments are invalid. *)
75
+
| `Invalid_result_reference
76
+
(** A result reference could not be resolved. *)
77
+
| `Forbidden
78
+
(** The method/arguments are valid but forbidden. *)
79
+
| `Account_not_found
80
+
(** The accountId does not correspond to a valid account. *)
81
+
| `Account_not_supported_by_method
82
+
(** The account does not support this method. *)
83
+
| `Account_read_only
84
+
(** The account is read-only. *)
85
+
| `Other of string
86
+
(** Other error type not in the standard set. *)
87
+
]
88
+
89
+
val method_error_type_to_string : method_error_type -> string
90
+
(** [method_error_type_to_string t] returns the type string. *)
91
+
92
+
val method_error_type_of_string : string -> method_error_type
93
+
(** [method_error_type_of_string s] parses a type string. *)
94
+
95
+
(** A method-level error response. *)
96
+
type method_error = {
97
+
type_ : method_error_type;
98
+
(** The error type. *)
99
+
description : string option;
100
+
(** Human-readable description of the error. *)
101
+
}
102
+
103
+
val method_error_jsont : method_error Jsont.t
104
+
(** JSON codec for method errors. *)
105
+
106
+
(** {1 SetError}
107
+
108
+
Errors returned in notCreated/notUpdated/notDestroyed responses. *)
109
+
110
+
(** Standard SetError types per RFC 8620 Section 5.3 and RFC 8621 Section 7 *)
111
+
type set_error_type = [
112
+
| `Forbidden
113
+
(** The operation is not permitted. *)
114
+
| `Over_quota
115
+
(** The maximum server quota has been reached. *)
116
+
| `Too_large
117
+
(** The object is too large. *)
118
+
| `Rate_limit
119
+
(** Too many objects of this type have been created recently. *)
120
+
| `Not_found
121
+
(** The id does not exist (for update/destroy). *)
122
+
| `Invalid_patch
123
+
(** The PatchObject is invalid. *)
124
+
| `Will_destroy
125
+
(** The object will be destroyed by another operation in the request. *)
126
+
| `Invalid_properties
127
+
(** Some properties were invalid. *)
128
+
| `Singleton
129
+
(** Only one object of this type can exist (for create). *)
130
+
| `Forbidden_mail_from
131
+
(** RFC 8621: The server does not permit the user to send from the address. *)
132
+
| `Forbidden_from
133
+
(** RFC 8621: The server does not permit the user to send a message with
134
+
the From header of the message to be sent. *)
135
+
| `Forbidden_to_send
136
+
(** RFC 8621: The user does not have permission to send at all. *)
137
+
| `Other of string
138
+
(** Other error type. *)
139
+
]
140
+
141
+
val set_error_type_to_string : set_error_type -> string
142
+
val set_error_type_of_string : string -> set_error_type
143
+
144
+
(** A SetError object. *)
145
+
type set_error = {
146
+
type_ : set_error_type;
147
+
(** The error type. *)
148
+
description : string option;
149
+
(** Human-readable description. *)
150
+
properties : string list option;
151
+
(** For invalidProperties errors, the list of invalid property names. *)
152
+
}
153
+
154
+
val set_error : ?description:string -> ?properties:string list -> set_error_type -> set_error
155
+
(** [set_error ?description ?properties type_] creates a SetError. *)
156
+
157
+
val set_error_jsont : set_error Jsont.t
158
+
(** JSON codec for SetError. *)
+123
lib/proto/proto_filter.ml
+123
lib/proto/proto_filter.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type operator = [ `And | `Or | `Not ]
7
+
8
+
let operator_to_string = function
9
+
| `And -> "AND"
10
+
| `Or -> "OR"
11
+
| `Not -> "NOT"
12
+
13
+
let operator_of_string = function
14
+
| "AND" -> `And
15
+
| "OR" -> `Or
16
+
| "NOT" -> `Not
17
+
| s -> Jsont.Error.msgf Jsont.Meta.none "Unknown filter operator: %s" s
18
+
19
+
let operator_jsont =
20
+
let kind = "Filter operator" in
21
+
Jsont.map ~kind
22
+
~dec:(fun s -> operator_of_string s)
23
+
~enc:operator_to_string
24
+
Jsont.string
25
+
26
+
type 'condition filter_operator = {
27
+
operator : operator;
28
+
conditions : 'condition filter list;
29
+
}
30
+
31
+
and 'condition filter =
32
+
| Operator of 'condition filter_operator
33
+
| Condition of 'condition
34
+
35
+
let filter_jsont (type c) (condition_jsont : c Jsont.t) : c filter Jsont.t =
36
+
let kind = "Filter" in
37
+
(* Create a recursive codec using Jsont.rec' *)
38
+
let rec make_filter_jsont () =
39
+
let lazy_self = lazy (make_filter_jsont ()) in
40
+
(* Filter operator codec *)
41
+
let filter_operator_jsont =
42
+
let make operator conditions = { operator; conditions } in
43
+
Jsont.Object.map ~kind:"FilterOperator" make
44
+
|> Jsont.Object.mem "operator" operator_jsont ~enc:(fun o -> o.operator)
45
+
|> Jsont.Object.mem "conditions"
46
+
(Jsont.list (Jsont.rec' lazy_self))
47
+
~enc:(fun o -> o.conditions)
48
+
|> Jsont.Object.finish
49
+
in
50
+
(* Decode function: check for "operator" field to determine type *)
51
+
let dec json =
52
+
match json with
53
+
| Jsont.Object (members, _) ->
54
+
(* members has type (name * json) list where name = string * Meta.t *)
55
+
if List.exists (fun ((k, _), _) -> k = "operator") members then begin
56
+
(* It's an operator *)
57
+
match Jsont.Json.decode' filter_operator_jsont json with
58
+
| Ok op -> Operator op
59
+
| Error e -> raise (Jsont.Error e)
60
+
end else begin
61
+
(* It's a condition *)
62
+
match Jsont.Json.decode' condition_jsont json with
63
+
| Ok c -> Condition c
64
+
| Error e -> raise (Jsont.Error e)
65
+
end
66
+
| Jsont.Null _ | Jsont.Bool _ | Jsont.Number _ | Jsont.String _ | Jsont.Array _ ->
67
+
Jsont.Error.msg Jsont.Meta.none "Filter must be an object"
68
+
in
69
+
(* Encode function *)
70
+
let enc = function
71
+
| Operator op ->
72
+
(match Jsont.Json.encode' filter_operator_jsont op with
73
+
| Ok j -> j
74
+
| Error e -> raise (Jsont.Error e))
75
+
| Condition c ->
76
+
(match Jsont.Json.encode' condition_jsont c with
77
+
| Ok j -> j
78
+
| Error e -> raise (Jsont.Error e))
79
+
in
80
+
Jsont.map ~kind ~dec ~enc Jsont.json
81
+
in
82
+
make_filter_jsont ()
83
+
84
+
type comparator = {
85
+
property : string;
86
+
is_ascending : bool;
87
+
collation : string option;
88
+
}
89
+
90
+
let comparator ?(is_ascending = true) ?collation property =
91
+
{ property; is_ascending; collation }
92
+
93
+
let comparator_property c = c.property
94
+
let comparator_is_ascending c = c.is_ascending
95
+
let comparator_collation c = c.collation
96
+
97
+
let comparator_make property is_ascending collation =
98
+
{ property; is_ascending; collation }
99
+
100
+
let comparator_jsont =
101
+
let kind = "Comparator" in
102
+
Jsont.Object.map ~kind comparator_make
103
+
|> Jsont.Object.mem "property" Jsont.string ~enc:comparator_property
104
+
|> Jsont.Object.mem "isAscending" Jsont.bool ~dec_absent:true ~enc:comparator_is_ascending
105
+
~enc_omit:(fun b -> b = true)
106
+
|> Jsont.Object.opt_mem "collation" Jsont.string ~enc:comparator_collation
107
+
|> Jsont.Object.finish
108
+
109
+
type added_item = {
110
+
id : Proto_id.t;
111
+
index : int64;
112
+
}
113
+
114
+
let added_item_make id index = { id; index }
115
+
let added_item_id a = a.id
116
+
let added_item_index a = a.index
117
+
118
+
let added_item_jsont =
119
+
let kind = "AddedItem" in
120
+
Jsont.Object.map ~kind added_item_make
121
+
|> Jsont.Object.mem "id" Proto_id.jsont ~enc:added_item_id
122
+
|> Jsont.Object.mem "index" Proto_int53.Unsigned.jsont ~enc:added_item_index
123
+
|> Jsont.Object.finish
+76
lib/proto/proto_filter.mli
+76
lib/proto/proto_filter.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP filter and sort types as defined in RFC 8620 Section 5.5
7
+
8
+
@canonical Jmap.Proto.Filter *)
9
+
10
+
(** {1 Filter Operators} *)
11
+
12
+
(** Filter operator types. *)
13
+
type operator = [
14
+
| `And (** All conditions must match *)
15
+
| `Or (** At least one condition must match *)
16
+
| `Not (** Inverts a single condition *)
17
+
]
18
+
19
+
val operator_jsont : operator Jsont.t
20
+
(** JSON codec for filter operators. *)
21
+
22
+
(** A filter operator that combines conditions.
23
+
24
+
When decoding, the filter determines whether a JSON object is an
25
+
operator (has "operator" field) or a condition. *)
26
+
type 'condition filter_operator = {
27
+
operator : operator;
28
+
conditions : 'condition filter list;
29
+
}
30
+
31
+
(** A filter is either an operator combining filters, or a leaf condition. *)
32
+
and 'condition filter =
33
+
| Operator of 'condition filter_operator
34
+
| Condition of 'condition
35
+
36
+
val filter_jsont : 'c Jsont.t -> 'c filter Jsont.t
37
+
(** [filter_jsont condition_jsont] creates a codec for filters with the
38
+
given condition type. The codec automatically distinguishes operators
39
+
from conditions by the presence of the "operator" field. *)
40
+
41
+
(** {1 Comparators} *)
42
+
43
+
(** A comparator for sorting query results. *)
44
+
type comparator = {
45
+
property : string;
46
+
(** The property to sort by. *)
47
+
is_ascending : bool;
48
+
(** [true] for ascending order (default), [false] for descending. *)
49
+
collation : string option;
50
+
(** Optional collation algorithm for string comparison. *)
51
+
}
52
+
53
+
val comparator :
54
+
?is_ascending:bool ->
55
+
?collation:string ->
56
+
string ->
57
+
comparator
58
+
(** [comparator ?is_ascending ?collation property] creates a comparator.
59
+
[is_ascending] defaults to [true]. *)
60
+
61
+
val comparator_property : comparator -> string
62
+
val comparator_is_ascending : comparator -> bool
63
+
val comparator_collation : comparator -> string option
64
+
65
+
val comparator_jsont : comparator Jsont.t
66
+
(** JSON codec for comparators. *)
67
+
68
+
(** {1 Position Information} *)
69
+
70
+
(** Added entry position in query change results. *)
71
+
type added_item = {
72
+
id : Proto_id.t;
73
+
index : int64;
74
+
}
75
+
76
+
val added_item_jsont : added_item Jsont.t
+51
lib/proto/proto_id.ml
+51
lib/proto/proto_id.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP identifier type as defined in RFC 8620 Section 1.2.
7
+
8
+
An Id is a string of 1-255 octets from the URL-safe base64 alphabet. *)
9
+
10
+
type t = string
11
+
12
+
(* Valid characters: A-Za-z0-9_- (URL-safe base64 alphabet) *)
13
+
let is_valid_char c =
14
+
(c >= 'A' && c <= 'Z') ||
15
+
(c >= 'a' && c <= 'z') ||
16
+
(c >= '0' && c <= '9') ||
17
+
c = '_' || c = '-'
18
+
19
+
let validate s =
20
+
let len = String.length s in
21
+
if len = 0 then Error "Id cannot be empty"
22
+
else if len > 255 then Error "Id cannot exceed 255 characters"
23
+
else
24
+
let rec check i =
25
+
if i >= len then Ok s
26
+
else if is_valid_char s.[i] then check (i + 1)
27
+
else Error (Printf.sprintf "Invalid character '%c' in Id at position %d" s.[i] i)
28
+
in
29
+
check 0
30
+
31
+
let of_string = validate
32
+
33
+
let of_string_exn s =
34
+
match validate s with
35
+
| Ok id -> id
36
+
| Error msg -> invalid_arg msg
37
+
38
+
let to_string t = t
39
+
let equal = String.equal
40
+
let compare = String.compare
41
+
let pp ppf t = Format.pp_print_string ppf t
42
+
43
+
let jsont =
44
+
let kind = "Id" in
45
+
let dec s =
46
+
match validate s with
47
+
| Ok id -> id
48
+
| Error msg -> Jsont.Error.msgf Jsont.Meta.none "%s: %s" kind msg
49
+
in
50
+
let enc t = t in
51
+
Jsont.map ~kind ~dec ~enc Jsont.string
+40
lib/proto/proto_id.mli
+40
lib/proto/proto_id.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP identifier type.
7
+
8
+
An Id is a string of 1-255 octets from the URL-safe base64 alphabet
9
+
(A-Za-z0-9_-), plus the ASCII alphanumeric characters.
10
+
11
+
See {{:https://datatracker.ietf.org/doc/html/rfc8620#section-1.2} RFC 8620 Section 1.2}.
12
+
13
+
@canonical Jmap.Proto.Id *)
14
+
15
+
type t
16
+
(** The type of JMAP identifiers. *)
17
+
18
+
val of_string : string -> (t, string) result
19
+
(** [of_string s] creates an Id from string [s].
20
+
Returns [Error msg] if [s] is empty, longer than 255 characters,
21
+
or contains invalid characters. *)
22
+
23
+
val of_string_exn : string -> t
24
+
(** [of_string_exn s] creates an Id from string [s].
25
+
@raise Invalid_argument if the string is invalid. *)
26
+
27
+
val to_string : t -> string
28
+
(** [to_string id] returns the string representation of [id]. *)
29
+
30
+
val equal : t -> t -> bool
31
+
(** [equal a b] tests equality of identifiers. *)
32
+
33
+
val compare : t -> t -> int
34
+
(** [compare a b] compares two identifiers. *)
35
+
36
+
val pp : Format.formatter -> t -> unit
37
+
(** [pp ppf id] pretty-prints [id] to [ppf]. *)
38
+
39
+
val jsont : t Jsont.t
40
+
(** JSON codec for JMAP identifiers. *)
+67
lib/proto/proto_int53.ml
+67
lib/proto/proto_int53.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JavaScript-safe integer types for JSON.
7
+
8
+
These types represent integers that can be safely represented in JavaScript's
9
+
IEEE 754 double-precision floating point format without loss of precision. *)
10
+
11
+
(** 53-bit signed integer with range -2^53+1 to 2^53-1 *)
12
+
module Signed = struct
13
+
type t = int64
14
+
15
+
(* 2^53 - 1 *)
16
+
let max_value = 9007199254740991L
17
+
(* -(2^53 - 1) *)
18
+
let min_value = -9007199254740991L
19
+
20
+
let of_int n = Int64.of_int n
21
+
22
+
let to_int n =
23
+
if n >= Int64.of_int min_int && n <= Int64.of_int max_int then
24
+
Some (Int64.to_int n)
25
+
else
26
+
None
27
+
28
+
let of_int64 n =
29
+
if n >= min_value && n <= max_value then Ok n
30
+
else Error (Printf.sprintf "Int53 out of range: %Ld" n)
31
+
32
+
let jsont =
33
+
let kind = "Int53" in
34
+
let dec f =
35
+
let n = Int64.of_float f in
36
+
if n >= min_value && n <= max_value then n
37
+
else Jsont.Error.msgf Jsont.Meta.none "%s: value %Ld out of safe integer range" kind n
38
+
in
39
+
let enc n = Int64.to_float n in
40
+
Jsont.map ~kind ~dec ~enc Jsont.number
41
+
end
42
+
43
+
(** 53-bit unsigned integer with range 0 to 2^53-1 *)
44
+
module Unsigned = struct
45
+
type t = int64
46
+
47
+
let min_value = 0L
48
+
let max_value = 9007199254740991L
49
+
50
+
let of_int n =
51
+
if n >= 0 then Ok (Int64.of_int n)
52
+
else Error "UnsignedInt53 cannot be negative"
53
+
54
+
let of_int64 n =
55
+
if n >= min_value && n <= max_value then Ok n
56
+
else Error (Printf.sprintf "UnsignedInt53 out of range: %Ld" n)
57
+
58
+
let jsont =
59
+
let kind = "UnsignedInt53" in
60
+
let dec f =
61
+
let n = Int64.of_float f in
62
+
if n >= min_value && n <= max_value then n
63
+
else Jsont.Error.msgf Jsont.Meta.none "%s: value %Ld out of range [0, 2^53-1]" kind n
64
+
in
65
+
let enc n = Int64.to_float n in
66
+
Jsont.map ~kind ~dec ~enc Jsont.number
67
+
end
+64
lib/proto/proto_int53.mli
+64
lib/proto/proto_int53.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JavaScript-safe integer types for JSON.
7
+
8
+
These types represent integers that can be safely represented in JavaScript's
9
+
IEEE 754 double-precision floating point format without loss of precision.
10
+
The safe range is -2^53+1 to 2^53-1.
11
+
12
+
See {{:https://datatracker.ietf.org/doc/html/rfc8620#section-1.3} RFC 8620 Section 1.3}.
13
+
14
+
@canonical Jmap.Proto.Int53 *)
15
+
16
+
(** 53-bit signed integer.
17
+
18
+
The range is -2^53+1 to 2^53-1, which is the safe integer range
19
+
for JavaScript/JSON numbers. *)
20
+
module Signed : sig
21
+
type t = int64
22
+
(** The type of 53-bit signed integers. *)
23
+
24
+
val min_value : t
25
+
(** Minimum value: -9007199254740991 (-2^53+1) *)
26
+
27
+
val max_value : t
28
+
(** Maximum value: 9007199254740991 (2^53-1) *)
29
+
30
+
val of_int : int -> t
31
+
(** [of_int n] converts an OCaml int to Int53. *)
32
+
33
+
val to_int : t -> int option
34
+
(** [to_int n] converts to OCaml int if it fits. *)
35
+
36
+
val of_int64 : int64 -> (t, string) result
37
+
(** [of_int64 n] validates that [n] is in the safe range. *)
38
+
39
+
val jsont : t Jsont.t
40
+
(** JSON codec for 53-bit integers. Encoded as JSON number. *)
41
+
end
42
+
43
+
(** 53-bit unsigned integer.
44
+
45
+
The range is 0 to 2^53-1. *)
46
+
module Unsigned : sig
47
+
type t = int64
48
+
(** The type of 53-bit unsigned integers. *)
49
+
50
+
val min_value : t
51
+
(** Minimum value: 0 *)
52
+
53
+
val max_value : t
54
+
(** Maximum value: 9007199254740991 (2^53-1) *)
55
+
56
+
val of_int : int -> (t, string) result
57
+
(** [of_int n] converts an OCaml int to UnsignedInt53. *)
58
+
59
+
val of_int64 : int64 -> (t, string) result
60
+
(** [of_int64 n] validates that [n] is in the valid range. *)
61
+
62
+
val jsont : t Jsont.t
63
+
(** JSON codec for 53-bit unsigned integers. *)
64
+
end
+113
lib/proto/proto_invocation.ml
+113
lib/proto/proto_invocation.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type result_reference = {
7
+
result_of : string;
8
+
name : string;
9
+
path : Json_pointer.Jmap.t;
10
+
}
11
+
12
+
let result_reference ~result_of ~name ~path =
13
+
{ result_of; name; path }
14
+
15
+
let result_reference_of_strings ~result_of ~name ~path =
16
+
{ result_of; name; path = Json_pointer.Jmap.of_string path }
17
+
18
+
let result_reference_make result_of name path =
19
+
{ result_of; name; path }
20
+
21
+
let result_reference_jsont =
22
+
let kind = "ResultReference" in
23
+
Jsont.Object.map ~kind result_reference_make
24
+
|> Jsont.Object.mem "resultOf" Jsont.string ~enc:(fun r -> r.result_of)
25
+
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun r -> r.name)
26
+
|> Jsont.Object.mem "path" Json_pointer.Jmap.jsont ~enc:(fun r -> r.path)
27
+
|> Jsont.Object.finish
28
+
29
+
(* Result reference resolution *)
30
+
31
+
let find_response ref ~responses =
32
+
List.find_map (fun (call_id, name, json) ->
33
+
if call_id = ref.result_of && name = ref.name
34
+
then Some json
35
+
else None
36
+
) responses
37
+
38
+
let resolve ref ~responses codec =
39
+
match find_response ref ~responses with
40
+
| None ->
41
+
Jsont.Error.msgf Jsont.Meta.none
42
+
"Result reference: no response found for resultOf=%s name=%s"
43
+
ref.result_of ref.name
44
+
| Some json ->
45
+
let extraction_codec = Json_pointer.Jmap.path ref.path codec in
46
+
match Jsont.Json.decode' extraction_codec json with
47
+
| Ok v -> v
48
+
| Error e -> raise (Jsont.Error e)
49
+
50
+
let resolve_ids ref ~responses =
51
+
resolve ref ~responses (Jsont.list Jsont.string)
52
+
53
+
type t = {
54
+
name : string;
55
+
arguments : Jsont.json;
56
+
method_call_id : string;
57
+
}
58
+
59
+
let create ~name ~arguments ~method_call_id =
60
+
{ name; arguments; method_call_id }
61
+
62
+
let name t = t.name
63
+
let arguments t = t.arguments
64
+
let method_call_id t = t.method_call_id
65
+
66
+
(* Helper to encode a typed value back to Jsont.json *)
67
+
let encode_json_value jsont value =
68
+
match Jsont.Json.encode' jsont value with
69
+
| Ok json -> json
70
+
| Error _ -> Jsont.Object ([], Jsont.Meta.none)
71
+
72
+
let jsont =
73
+
let kind = "Invocation" in
74
+
(* Invocation is [name, args, callId] - a 3-element heterogeneous array *)
75
+
(* We need to handle this as a json array since elements have different types *)
76
+
let dec json =
77
+
match json with
78
+
| Jsont.Array ([name_json; arguments; call_id_json], _) ->
79
+
let name = match name_json with
80
+
| Jsont.String (s, _) -> s
81
+
| _ -> Jsont.Error.msg Jsont.Meta.none "Invocation[0] must be a string"
82
+
in
83
+
let method_call_id = match call_id_json with
84
+
| Jsont.String (s, _) -> s
85
+
| _ -> Jsont.Error.msg Jsont.Meta.none "Invocation[2] must be a string"
86
+
in
87
+
{ name; arguments; method_call_id }
88
+
| Jsont.Array _ ->
89
+
Jsont.Error.msg Jsont.Meta.none "Invocation must be a 3-element array"
90
+
| _ ->
91
+
Jsont.Error.msg Jsont.Meta.none "Invocation must be an array"
92
+
in
93
+
let enc t =
94
+
Jsont.Array ([
95
+
Jsont.String (t.name, Jsont.Meta.none);
96
+
t.arguments;
97
+
Jsont.String (t.method_call_id, Jsont.Meta.none);
98
+
], Jsont.Meta.none)
99
+
in
100
+
Jsont.map ~kind ~dec ~enc Jsont.json
101
+
102
+
let make_get ~method_call_id ~method_name args =
103
+
let arguments = encode_json_value Proto_method.get_args_jsont args in
104
+
{ name = method_name; arguments; method_call_id }
105
+
106
+
let make_changes ~method_call_id ~method_name args =
107
+
let arguments = encode_json_value Proto_method.changes_args_jsont args in
108
+
{ name = method_name; arguments; method_call_id }
109
+
110
+
let make_query (type f) ~method_call_id ~method_name
111
+
~(filter_cond_jsont : f Jsont.t) (args : f Proto_method.query_args) =
112
+
let arguments = encode_json_value (Proto_method.query_args_jsont filter_cond_jsont) args in
113
+
{ name = method_name; arguments; method_call_id }
+125
lib/proto/proto_invocation.mli
+125
lib/proto/proto_invocation.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP method invocation as defined in RFC 8620 Section 3.2
7
+
8
+
@canonical Jmap.Proto.Invocation *)
9
+
10
+
(** {1 Result References} *)
11
+
12
+
(** A reference to a result from a previous method call.
13
+
14
+
Used for back-referencing values within a single request.
15
+
The path is a JMAP extended JSON Pointer (RFC 8620 Section 3.7)
16
+
which may contain [*] wildcards for array mapping. *)
17
+
type result_reference = {
18
+
result_of : string;
19
+
(** The method call id to reference. *)
20
+
name : string;
21
+
(** The method name that was called. *)
22
+
path : Json_pointer.Jmap.t;
23
+
(** A JMAP extended JSON Pointer to the value within the result.
24
+
May contain [*] wildcards for mapping through arrays. *)
25
+
}
26
+
27
+
val result_reference :
28
+
result_of:string ->
29
+
name:string ->
30
+
path:Json_pointer.Jmap.t ->
31
+
result_reference
32
+
33
+
val result_reference_of_strings :
34
+
result_of:string ->
35
+
name:string ->
36
+
path:string ->
37
+
result_reference
38
+
(** [result_reference_of_strings] creates a result reference, parsing
39
+
the path string into a JMAP pointer.
40
+
@raise Jsont.Error if the path is not a valid JMAP pointer. *)
41
+
42
+
val result_reference_jsont : result_reference Jsont.t
43
+
44
+
(** {2 Typed Extraction}
45
+
46
+
These functions extract typed values from method responses using
47
+
the result reference's path. *)
48
+
49
+
val resolve_ids :
50
+
result_reference ->
51
+
responses:(string * string * Jsont.json) list ->
52
+
string list
53
+
(** [resolve_ids ref ~responses] resolves the result reference against
54
+
the list of previous responses and extracts a list of string IDs.
55
+
56
+
[responses] is a list of [(method_call_id, method_name, result_json)]
57
+
tuples from previously executed method calls.
58
+
59
+
This is the most common pattern in JMAP where result references are
60
+
used to pass IDs between method calls.
61
+
62
+
@raise Jsont.Error if resolution fails or the result is not a string list. *)
63
+
64
+
val resolve :
65
+
result_reference ->
66
+
responses:(string * string * Jsont.json) list ->
67
+
'a Jsont.t ->
68
+
'a
69
+
(** [resolve ref ~responses codec] resolves the result reference and
70
+
decodes the extracted value with [codec].
71
+
72
+
@raise Jsont.Error if resolution fails or decoding fails. *)
73
+
74
+
(** {1 Invocations} *)
75
+
76
+
(** A method invocation.
77
+
78
+
In JSON, this is represented as a 3-element array:
79
+
["methodName", {args}, "methodCallId"] *)
80
+
type t = {
81
+
name : string;
82
+
(** The method name, e.g., "Email/get". *)
83
+
arguments : Jsont.json;
84
+
(** The method arguments as a JSON object. *)
85
+
method_call_id : string;
86
+
(** Client-specified identifier for this call. *)
87
+
}
88
+
89
+
val create :
90
+
name:string ->
91
+
arguments:Jsont.json ->
92
+
method_call_id:string ->
93
+
t
94
+
(** [create ~name ~arguments ~method_call_id] creates an invocation. *)
95
+
96
+
val name : t -> string
97
+
val arguments : t -> Jsont.json
98
+
val method_call_id : t -> string
99
+
100
+
val jsont : t Jsont.t
101
+
(** JSON codec for invocations (as 3-element array). *)
102
+
103
+
(** {1 Typed Invocation Helpers} *)
104
+
105
+
val make_get :
106
+
method_call_id:string ->
107
+
method_name:string ->
108
+
Proto_method.get_args ->
109
+
t
110
+
(** [make_get ~method_call_id ~method_name args] creates a /get invocation. *)
111
+
112
+
val make_changes :
113
+
method_call_id:string ->
114
+
method_name:string ->
115
+
Proto_method.changes_args ->
116
+
t
117
+
(** [make_changes ~method_call_id ~method_name args] creates a /changes invocation. *)
118
+
119
+
val make_query :
120
+
method_call_id:string ->
121
+
method_name:string ->
122
+
filter_cond_jsont:'f Jsont.t ->
123
+
'f Proto_method.query_args ->
124
+
t
125
+
(** [make_query ~method_call_id ~method_name ~filter_cond_jsont args] creates a /query invocation. *)
+40
lib/proto/proto_json_map.ml
+40
lib/proto/proto_json_map.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JSON object-as-map codec utilities.
7
+
8
+
JMAP frequently uses JSON objects as maps with string or Id keys.
9
+
These codecs convert between JSON objects and OCaml association lists. *)
10
+
11
+
module String_map = Map.Make(String)
12
+
13
+
let of_string value_jsont =
14
+
let kind = "String map" in
15
+
Jsont.Object.map ~kind Fun.id
16
+
|> Jsont.Object.keep_unknown (Jsont.Object.Mems.string_map value_jsont) ~enc:Fun.id
17
+
|> Jsont.Object.finish
18
+
|> Jsont.map
19
+
~dec:(fun m -> List.of_seq (String_map.to_seq m))
20
+
~enc:(fun l -> String_map.of_list l)
21
+
22
+
let of_id value_jsont =
23
+
let kind = "Id map" in
24
+
(* Use string map internally, then convert keys to Ids *)
25
+
let string_codec = of_string value_jsont in
26
+
let dec pairs =
27
+
List.map (fun (k, v) ->
28
+
match Proto_id.of_string k with
29
+
| Ok id -> (id, v)
30
+
| Error msg -> Jsont.Error.msgf Jsont.Meta.none "%s: invalid key %s - %s" kind k msg
31
+
) pairs
32
+
in
33
+
let enc pairs =
34
+
List.map (fun (id, v) -> (Proto_id.to_string id, v)) pairs
35
+
in
36
+
Jsont.map ~kind ~dec ~enc string_codec
37
+
38
+
let id_to_bool = of_id Jsont.bool
39
+
40
+
let string_to_bool = of_string Jsont.bool
+25
lib/proto/proto_json_map.mli
+25
lib/proto/proto_json_map.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JSON object-as-map codec utilities.
7
+
8
+
JMAP frequently uses JSON objects as maps with string or Id keys.
9
+
These codecs convert between JSON objects and OCaml association lists.
10
+
11
+
@canonical Jmap.Proto.Json_map *)
12
+
13
+
val of_string : 'a Jsont.t -> (string * 'a) list Jsont.t
14
+
(** [of_string value_jsont] creates a codec for JSON objects
15
+
used as string-keyed maps. Returns an association list. *)
16
+
17
+
val of_id : 'a Jsont.t -> (Proto_id.t * 'a) list Jsont.t
18
+
(** [of_id value_jsont] creates a codec for JSON objects
19
+
keyed by JMAP identifiers. *)
20
+
21
+
val id_to_bool : (Proto_id.t * bool) list Jsont.t
22
+
(** Codec for Id[Boolean] maps, common in JMAP (e.g., mailboxIds, keywords). *)
23
+
24
+
val string_to_bool : (string * bool) list Jsont.t
25
+
(** Codec for String[Boolean] maps. *)
+327
lib/proto/proto_method.ml
+327
lib/proto/proto_method.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Foo/get *)
7
+
8
+
type get_args = {
9
+
account_id : Proto_id.t;
10
+
ids : Proto_id.t list option;
11
+
properties : string list option;
12
+
}
13
+
14
+
let get_args ~account_id ?ids ?properties () =
15
+
{ account_id; ids; properties }
16
+
17
+
let get_args_make account_id ids properties =
18
+
{ account_id; ids; properties }
19
+
20
+
let get_args_jsont =
21
+
let kind = "GetArgs" in
22
+
Jsont.Object.map ~kind get_args_make
23
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
24
+
|> Jsont.Object.opt_mem "ids" (Jsont.list Proto_id.jsont) ~enc:(fun a -> a.ids)
25
+
|> Jsont.Object.opt_mem "properties" (Jsont.list Jsont.string) ~enc:(fun a -> a.properties)
26
+
|> Jsont.Object.finish
27
+
28
+
type 'a get_response = {
29
+
account_id : Proto_id.t;
30
+
state : string;
31
+
list : 'a list;
32
+
not_found : Proto_id.t list;
33
+
}
34
+
35
+
let get_response_jsont (type a) (obj_jsont : a Jsont.t) : a get_response Jsont.t =
36
+
let kind = "GetResponse" in
37
+
let make account_id state list not_found =
38
+
{ account_id; state; list; not_found }
39
+
in
40
+
Jsont.Object.map ~kind make
41
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id)
42
+
|> Jsont.Object.mem "state" Jsont.string ~enc:(fun r -> r.state)
43
+
|> Jsont.Object.mem "list" (Jsont.list obj_jsont) ~enc:(fun r -> r.list)
44
+
|> Jsont.Object.mem "notFound" (Jsont.list Proto_id.jsont) ~enc:(fun r -> r.not_found)
45
+
|> Jsont.Object.finish
46
+
47
+
(* Foo/changes *)
48
+
49
+
type changes_args = {
50
+
account_id : Proto_id.t;
51
+
since_state : string;
52
+
max_changes : int64 option;
53
+
}
54
+
55
+
let changes_args ~account_id ~since_state ?max_changes () =
56
+
{ account_id; since_state; max_changes }
57
+
58
+
let changes_args_make account_id since_state max_changes =
59
+
{ account_id; since_state; max_changes }
60
+
61
+
let changes_args_jsont =
62
+
let kind = "ChangesArgs" in
63
+
Jsont.Object.map ~kind changes_args_make
64
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
65
+
|> Jsont.Object.mem "sinceState" Jsont.string ~enc:(fun a -> a.since_state)
66
+
|> Jsont.Object.opt_mem "maxChanges" Proto_int53.Unsigned.jsont ~enc:(fun a -> a.max_changes)
67
+
|> Jsont.Object.finish
68
+
69
+
type changes_response = {
70
+
account_id : Proto_id.t;
71
+
old_state : string;
72
+
new_state : string;
73
+
has_more_changes : bool;
74
+
created : Proto_id.t list;
75
+
updated : Proto_id.t list;
76
+
destroyed : Proto_id.t list;
77
+
}
78
+
79
+
let changes_response_make account_id old_state new_state has_more_changes
80
+
created updated destroyed =
81
+
{ account_id; old_state; new_state; has_more_changes; created; updated; destroyed }
82
+
83
+
let changes_response_jsont =
84
+
let kind = "ChangesResponse" in
85
+
Jsont.Object.map ~kind changes_response_make
86
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id)
87
+
|> Jsont.Object.mem "oldState" Jsont.string ~enc:(fun r -> r.old_state)
88
+
|> Jsont.Object.mem "newState" Jsont.string ~enc:(fun r -> r.new_state)
89
+
|> Jsont.Object.mem "hasMoreChanges" Jsont.bool ~enc:(fun r -> r.has_more_changes)
90
+
|> Jsont.Object.mem "created" (Jsont.list Proto_id.jsont) ~enc:(fun r -> r.created)
91
+
|> Jsont.Object.mem "updated" (Jsont.list Proto_id.jsont) ~enc:(fun r -> r.updated)
92
+
|> Jsont.Object.mem "destroyed" (Jsont.list Proto_id.jsont) ~enc:(fun r -> r.destroyed)
93
+
|> Jsont.Object.finish
94
+
95
+
(* Foo/set *)
96
+
97
+
type 'a set_args = {
98
+
account_id : Proto_id.t;
99
+
if_in_state : string option;
100
+
create : (Proto_id.t * 'a) list option;
101
+
update : (Proto_id.t * Jsont.json) list option;
102
+
destroy : Proto_id.t list option;
103
+
}
104
+
105
+
let set_args ~account_id ?if_in_state ?create ?update ?destroy () =
106
+
{ account_id; if_in_state; create; update; destroy }
107
+
108
+
let set_args_jsont (type a) (obj_jsont : a Jsont.t) : a set_args Jsont.t =
109
+
let kind = "SetArgs" in
110
+
let make account_id if_in_state create update destroy =
111
+
{ account_id; if_in_state; create; update; destroy }
112
+
in
113
+
Jsont.Object.map ~kind make
114
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
115
+
|> Jsont.Object.opt_mem "ifInState" Jsont.string ~enc:(fun a -> a.if_in_state)
116
+
|> Jsont.Object.opt_mem "create" (Proto_json_map.of_id obj_jsont) ~enc:(fun a -> a.create)
117
+
|> Jsont.Object.opt_mem "update" (Proto_json_map.of_id Jsont.json) ~enc:(fun a -> a.update)
118
+
|> Jsont.Object.opt_mem "destroy" (Jsont.list Proto_id.jsont) ~enc:(fun a -> a.destroy)
119
+
|> Jsont.Object.finish
120
+
121
+
type 'a set_response = {
122
+
account_id : Proto_id.t;
123
+
old_state : string option;
124
+
new_state : string;
125
+
created : (Proto_id.t * 'a) list option;
126
+
updated : (Proto_id.t * 'a option) list option;
127
+
destroyed : Proto_id.t list option;
128
+
not_created : (Proto_id.t * Proto_error.set_error) list option;
129
+
not_updated : (Proto_id.t * Proto_error.set_error) list option;
130
+
not_destroyed : (Proto_id.t * Proto_error.set_error) list option;
131
+
}
132
+
133
+
let set_response_jsont (type a) (obj_jsont : a Jsont.t) : a set_response Jsont.t =
134
+
let kind = "SetResponse" in
135
+
(* All map/list fields in SetResponse can be null per RFC 8620 Section 5.3 *)
136
+
(* opt_mem handles missing keys, Jsont.option handles explicit null values *)
137
+
(* Option.join flattens option option -> option *)
138
+
let join = Option.join in
139
+
let make account_id old_state new_state created updated destroyed
140
+
not_created not_updated not_destroyed =
141
+
{ account_id; old_state; new_state;
142
+
created = join created;
143
+
updated = join updated;
144
+
destroyed = join destroyed;
145
+
not_created = join not_created;
146
+
not_updated = join not_updated;
147
+
not_destroyed = join not_destroyed }
148
+
in
149
+
(* For updated values, the server may return null or an object - RFC 8620 Section 5.3 *)
150
+
(* "Id[Foo|null]" means map values can be null, use Jsont.option to handle this *)
151
+
let nullable_obj = Jsont.(option obj_jsont) in
152
+
let opt enc = Option.map Option.some enc in
153
+
Jsont.Object.map ~kind make
154
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id)
155
+
|> Jsont.Object.opt_mem "oldState" Jsont.string ~enc:(fun r -> r.old_state)
156
+
|> Jsont.Object.mem "newState" Jsont.string ~enc:(fun r -> r.new_state)
157
+
|> Jsont.Object.opt_mem "created" Jsont.(option (Proto_json_map.of_id obj_jsont)) ~enc:(fun r -> opt r.created)
158
+
|> Jsont.Object.opt_mem "updated" Jsont.(option (Proto_json_map.of_id nullable_obj)) ~enc:(fun r -> opt r.updated)
159
+
|> Jsont.Object.opt_mem "destroyed" Jsont.(option (list Proto_id.jsont)) ~enc:(fun r -> opt r.destroyed)
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
+
|> 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
+
|> Jsont.Object.opt_mem "notDestroyed" Jsont.(option (Proto_json_map.of_id Proto_error.set_error_jsont)) ~enc:(fun r -> opt r.not_destroyed)
163
+
|> Jsont.Object.finish
164
+
165
+
(* Foo/copy *)
166
+
167
+
type 'a copy_args = {
168
+
from_account_id : Proto_id.t;
169
+
if_from_in_state : string option;
170
+
account_id : Proto_id.t;
171
+
if_in_state : string option;
172
+
create : (Proto_id.t * 'a) list;
173
+
on_success_destroy_original : bool;
174
+
destroy_from_if_in_state : string option;
175
+
}
176
+
177
+
let copy_args_jsont (type a) (obj_jsont : a Jsont.t) : a copy_args Jsont.t =
178
+
let kind = "CopyArgs" in
179
+
let make from_account_id if_from_in_state account_id if_in_state create
180
+
on_success_destroy_original destroy_from_if_in_state =
181
+
{ from_account_id; if_from_in_state; account_id; if_in_state; create;
182
+
on_success_destroy_original; destroy_from_if_in_state }
183
+
in
184
+
Jsont.Object.map ~kind make
185
+
|> Jsont.Object.mem "fromAccountId" Proto_id.jsont ~enc:(fun a -> a.from_account_id)
186
+
|> Jsont.Object.opt_mem "ifFromInState" Jsont.string ~enc:(fun a -> a.if_from_in_state)
187
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
188
+
|> Jsont.Object.opt_mem "ifInState" Jsont.string ~enc:(fun a -> a.if_in_state)
189
+
|> Jsont.Object.mem "create" (Proto_json_map.of_id obj_jsont) ~enc:(fun a -> a.create)
190
+
|> Jsont.Object.mem "onSuccessDestroyOriginal" Jsont.bool ~dec_absent:false
191
+
~enc:(fun a -> a.on_success_destroy_original)
192
+
~enc_omit:(fun b -> not b)
193
+
|> Jsont.Object.opt_mem "destroyFromIfInState" Jsont.string ~enc:(fun a -> a.destroy_from_if_in_state)
194
+
|> Jsont.Object.finish
195
+
196
+
type 'a copy_response = {
197
+
from_account_id : Proto_id.t;
198
+
account_id : Proto_id.t;
199
+
old_state : string option;
200
+
new_state : string;
201
+
created : (Proto_id.t * 'a) list option;
202
+
not_created : (Proto_id.t * Proto_error.set_error) list option;
203
+
}
204
+
205
+
let copy_response_jsont (type a) (obj_jsont : a Jsont.t) : a copy_response Jsont.t =
206
+
let kind = "CopyResponse" in
207
+
let make from_account_id account_id old_state new_state created not_created =
208
+
{ from_account_id; account_id; old_state; new_state; created; not_created }
209
+
in
210
+
Jsont.Object.map ~kind make
211
+
|> Jsont.Object.mem "fromAccountId" Proto_id.jsont ~enc:(fun r -> r.from_account_id)
212
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id)
213
+
|> Jsont.Object.opt_mem "oldState" Jsont.string ~enc:(fun r -> r.old_state)
214
+
|> Jsont.Object.mem "newState" Jsont.string ~enc:(fun r -> r.new_state)
215
+
|> Jsont.Object.opt_mem "created" (Proto_json_map.of_id obj_jsont) ~enc:(fun r -> r.created)
216
+
|> Jsont.Object.opt_mem "notCreated" (Proto_json_map.of_id Proto_error.set_error_jsont) ~enc:(fun r -> r.not_created)
217
+
|> Jsont.Object.finish
218
+
219
+
(* Foo/query *)
220
+
221
+
type 'filter query_args = {
222
+
account_id : Proto_id.t;
223
+
filter : 'filter Proto_filter.filter option;
224
+
sort : Proto_filter.comparator list option;
225
+
position : int64;
226
+
anchor : Proto_id.t option;
227
+
anchor_offset : int64;
228
+
limit : int64 option;
229
+
calculate_total : bool;
230
+
}
231
+
232
+
let query_args ~account_id ?filter ?sort ?(position = 0L) ?anchor
233
+
?(anchor_offset = 0L) ?limit ?(calculate_total = false) () =
234
+
{ account_id; filter; sort; position; anchor; anchor_offset; limit; calculate_total }
235
+
236
+
let query_args_jsont (type f) (filter_cond_jsont : f Jsont.t) : f query_args Jsont.t =
237
+
let kind = "QueryArgs" in
238
+
let make account_id filter sort position anchor anchor_offset limit calculate_total =
239
+
{ account_id; filter; sort; position; anchor; anchor_offset; limit; calculate_total }
240
+
in
241
+
Jsont.Object.map ~kind make
242
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
243
+
|> Jsont.Object.opt_mem "filter" (Proto_filter.filter_jsont filter_cond_jsont) ~enc:(fun a -> a.filter)
244
+
|> Jsont.Object.opt_mem "sort" (Jsont.list Proto_filter.comparator_jsont) ~enc:(fun a -> a.sort)
245
+
|> Jsont.Object.mem "position" Proto_int53.Signed.jsont ~dec_absent:0L ~enc:(fun a -> a.position)
246
+
~enc_omit:(fun p -> p = 0L)
247
+
|> Jsont.Object.opt_mem "anchor" Proto_id.jsont ~enc:(fun a -> a.anchor)
248
+
|> Jsont.Object.mem "anchorOffset" Proto_int53.Signed.jsont ~dec_absent:0L ~enc:(fun a -> a.anchor_offset)
249
+
~enc_omit:(fun o -> o = 0L)
250
+
|> Jsont.Object.opt_mem "limit" Proto_int53.Unsigned.jsont ~enc:(fun a -> a.limit)
251
+
|> Jsont.Object.mem "calculateTotal" Jsont.bool ~dec_absent:false ~enc:(fun a -> a.calculate_total)
252
+
~enc_omit:(fun b -> not b)
253
+
|> Jsont.Object.finish
254
+
255
+
type query_response = {
256
+
account_id : Proto_id.t;
257
+
query_state : string;
258
+
can_calculate_changes : bool;
259
+
position : int64;
260
+
ids : Proto_id.t list;
261
+
total : int64 option;
262
+
}
263
+
264
+
let query_response_make account_id query_state can_calculate_changes position ids total =
265
+
{ account_id; query_state; can_calculate_changes; position; ids; total }
266
+
267
+
let query_response_jsont =
268
+
let kind = "QueryResponse" in
269
+
Jsont.Object.map ~kind query_response_make
270
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id)
271
+
|> Jsont.Object.mem "queryState" Jsont.string ~enc:(fun r -> r.query_state)
272
+
|> Jsont.Object.mem "canCalculateChanges" Jsont.bool ~enc:(fun r -> r.can_calculate_changes)
273
+
|> Jsont.Object.mem "position" Proto_int53.Unsigned.jsont ~enc:(fun r -> r.position)
274
+
|> Jsont.Object.mem "ids" (Jsont.list Proto_id.jsont) ~enc:(fun r -> r.ids)
275
+
|> Jsont.Object.opt_mem "total" Proto_int53.Unsigned.jsont ~enc:(fun r -> r.total)
276
+
|> Jsont.Object.finish
277
+
278
+
(* Foo/queryChanges *)
279
+
280
+
type 'filter query_changes_args = {
281
+
account_id : Proto_id.t;
282
+
filter : 'filter Proto_filter.filter option;
283
+
sort : Proto_filter.comparator list option;
284
+
since_query_state : string;
285
+
max_changes : int64 option;
286
+
up_to_id : Proto_id.t option;
287
+
calculate_total : bool;
288
+
}
289
+
290
+
let query_changes_args_jsont (type f) (filter_cond_jsont : f Jsont.t) : f query_changes_args Jsont.t =
291
+
let kind = "QueryChangesArgs" in
292
+
let make account_id filter sort since_query_state max_changes up_to_id calculate_total =
293
+
{ account_id; filter; sort; since_query_state; max_changes; up_to_id; calculate_total }
294
+
in
295
+
Jsont.Object.map ~kind make
296
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
297
+
|> Jsont.Object.opt_mem "filter" (Proto_filter.filter_jsont filter_cond_jsont) ~enc:(fun a -> a.filter)
298
+
|> Jsont.Object.opt_mem "sort" (Jsont.list Proto_filter.comparator_jsont) ~enc:(fun a -> a.sort)
299
+
|> Jsont.Object.mem "sinceQueryState" Jsont.string ~enc:(fun a -> a.since_query_state)
300
+
|> Jsont.Object.opt_mem "maxChanges" Proto_int53.Unsigned.jsont ~enc:(fun a -> a.max_changes)
301
+
|> Jsont.Object.opt_mem "upToId" Proto_id.jsont ~enc:(fun a -> a.up_to_id)
302
+
|> Jsont.Object.mem "calculateTotal" Jsont.bool ~dec_absent:false ~enc:(fun a -> a.calculate_total)
303
+
~enc_omit:(fun b -> not b)
304
+
|> Jsont.Object.finish
305
+
306
+
type query_changes_response = {
307
+
account_id : Proto_id.t;
308
+
old_query_state : string;
309
+
new_query_state : string;
310
+
total : int64 option;
311
+
removed : Proto_id.t list;
312
+
added : Proto_filter.added_item list;
313
+
}
314
+
315
+
let query_changes_response_make account_id old_query_state new_query_state total removed added =
316
+
{ account_id; old_query_state; new_query_state; total; removed; added }
317
+
318
+
let query_changes_response_jsont =
319
+
let kind = "QueryChangesResponse" in
320
+
Jsont.Object.map ~kind query_changes_response_make
321
+
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id)
322
+
|> Jsont.Object.mem "oldQueryState" Jsont.string ~enc:(fun r -> r.old_query_state)
323
+
|> Jsont.Object.mem "newQueryState" Jsont.string ~enc:(fun r -> r.new_query_state)
324
+
|> Jsont.Object.opt_mem "total" Proto_int53.Unsigned.jsont ~enc:(fun r -> r.total)
325
+
|> Jsont.Object.mem "removed" (Jsont.list Proto_id.jsont) ~enc:(fun r -> r.removed)
326
+
|> Jsont.Object.mem "added" (Jsont.list Proto_filter.added_item_jsont) ~enc:(fun r -> r.added)
327
+
|> Jsont.Object.finish
+217
lib/proto/proto_method.mli
+217
lib/proto/proto_method.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP standard method types as defined in RFC 8620 Section 5
7
+
8
+
@canonical Jmap.Proto.Method *)
9
+
10
+
(** {1 Foo/get} *)
11
+
12
+
(** Arguments for /get methods. *)
13
+
type get_args = {
14
+
account_id : Proto_id.t;
15
+
(** The account to fetch from. *)
16
+
ids : Proto_id.t list option;
17
+
(** The ids to fetch. [None] means fetch all. *)
18
+
properties : string list option;
19
+
(** Properties to include. [None] means all. *)
20
+
}
21
+
22
+
val get_args :
23
+
account_id:Proto_id.t ->
24
+
?ids:Proto_id.t list ->
25
+
?properties:string list ->
26
+
unit ->
27
+
get_args
28
+
29
+
val get_args_jsont : get_args Jsont.t
30
+
31
+
(** Response for /get methods. *)
32
+
type 'a get_response = {
33
+
account_id : Proto_id.t;
34
+
(** The account fetched from. *)
35
+
state : string;
36
+
(** Current state string. *)
37
+
list : 'a list;
38
+
(** The objects fetched. *)
39
+
not_found : Proto_id.t list;
40
+
(** Ids that were not found. *)
41
+
}
42
+
43
+
val get_response_jsont : 'a Jsont.t -> 'a get_response Jsont.t
44
+
45
+
(** {1 Foo/changes} *)
46
+
47
+
(** Arguments for /changes methods. *)
48
+
type changes_args = {
49
+
account_id : Proto_id.t;
50
+
since_state : string;
51
+
max_changes : int64 option;
52
+
}
53
+
54
+
val changes_args :
55
+
account_id:Proto_id.t ->
56
+
since_state:string ->
57
+
?max_changes:int64 ->
58
+
unit ->
59
+
changes_args
60
+
61
+
val changes_args_jsont : changes_args Jsont.t
62
+
63
+
(** Response for /changes methods. *)
64
+
type changes_response = {
65
+
account_id : Proto_id.t;
66
+
old_state : string;
67
+
new_state : string;
68
+
has_more_changes : bool;
69
+
created : Proto_id.t list;
70
+
updated : Proto_id.t list;
71
+
destroyed : Proto_id.t list;
72
+
}
73
+
74
+
val changes_response_jsont : changes_response Jsont.t
75
+
76
+
(** {1 Foo/set} *)
77
+
78
+
(** Arguments for /set methods.
79
+
80
+
The ['a] type parameter is the object type being created/updated. *)
81
+
type 'a set_args = {
82
+
account_id : Proto_id.t;
83
+
if_in_state : string option;
84
+
(** If set, only apply if current state matches. *)
85
+
create : (Proto_id.t * 'a) list option;
86
+
(** Objects to create, keyed by temporary id. *)
87
+
update : (Proto_id.t * Jsont.json) list option;
88
+
(** Objects to update. Value is a PatchObject. *)
89
+
destroy : Proto_id.t list option;
90
+
(** Ids to destroy. *)
91
+
}
92
+
93
+
val set_args :
94
+
account_id:Proto_id.t ->
95
+
?if_in_state:string ->
96
+
?create:(Proto_id.t * 'a) list ->
97
+
?update:(Proto_id.t * Jsont.json) list ->
98
+
?destroy:Proto_id.t list ->
99
+
unit ->
100
+
'a set_args
101
+
102
+
val set_args_jsont : 'a Jsont.t -> 'a set_args Jsont.t
103
+
104
+
(** Response for /set methods. *)
105
+
type 'a set_response = {
106
+
account_id : Proto_id.t;
107
+
old_state : string option;
108
+
new_state : string;
109
+
created : (Proto_id.t * 'a) list option;
110
+
(** Successfully created objects, keyed by temporary id. *)
111
+
updated : (Proto_id.t * 'a option) list option;
112
+
(** Successfully updated objects. Value may include server-set properties. *)
113
+
destroyed : Proto_id.t list option;
114
+
(** Successfully destroyed ids. *)
115
+
not_created : (Proto_id.t * Proto_error.set_error) list option;
116
+
(** Failed creates. *)
117
+
not_updated : (Proto_id.t * Proto_error.set_error) list option;
118
+
(** Failed updates. *)
119
+
not_destroyed : (Proto_id.t * Proto_error.set_error) list option;
120
+
(** Failed destroys. *)
121
+
}
122
+
123
+
val set_response_jsont : 'a Jsont.t -> 'a set_response Jsont.t
124
+
125
+
(** {1 Foo/copy} *)
126
+
127
+
(** Arguments for /copy methods. *)
128
+
type 'a copy_args = {
129
+
from_account_id : Proto_id.t;
130
+
if_from_in_state : string option;
131
+
account_id : Proto_id.t;
132
+
if_in_state : string option;
133
+
create : (Proto_id.t * 'a) list;
134
+
on_success_destroy_original : bool;
135
+
destroy_from_if_in_state : string option;
136
+
}
137
+
138
+
val copy_args_jsont : 'a Jsont.t -> 'a copy_args Jsont.t
139
+
140
+
(** Response for /copy methods. *)
141
+
type 'a copy_response = {
142
+
from_account_id : Proto_id.t;
143
+
account_id : Proto_id.t;
144
+
old_state : string option;
145
+
new_state : string;
146
+
created : (Proto_id.t * 'a) list option;
147
+
not_created : (Proto_id.t * Proto_error.set_error) list option;
148
+
}
149
+
150
+
val copy_response_jsont : 'a Jsont.t -> 'a copy_response Jsont.t
151
+
152
+
(** {1 Foo/query} *)
153
+
154
+
(** Arguments for /query methods. *)
155
+
type 'filter query_args = {
156
+
account_id : Proto_id.t;
157
+
filter : 'filter Proto_filter.filter option;
158
+
sort : Proto_filter.comparator list option;
159
+
position : int64;
160
+
anchor : Proto_id.t option;
161
+
anchor_offset : int64;
162
+
limit : int64 option;
163
+
calculate_total : bool;
164
+
}
165
+
166
+
val query_args :
167
+
account_id:Proto_id.t ->
168
+
?filter:'filter Proto_filter.filter ->
169
+
?sort:Proto_filter.comparator list ->
170
+
?position:int64 ->
171
+
?anchor:Proto_id.t ->
172
+
?anchor_offset:int64 ->
173
+
?limit:int64 ->
174
+
?calculate_total:bool ->
175
+
unit ->
176
+
'filter query_args
177
+
178
+
val query_args_jsont : 'filter Jsont.t -> 'filter query_args Jsont.t
179
+
180
+
(** Response for /query methods. *)
181
+
type query_response = {
182
+
account_id : Proto_id.t;
183
+
query_state : string;
184
+
can_calculate_changes : bool;
185
+
position : int64;
186
+
ids : Proto_id.t list;
187
+
total : int64 option;
188
+
}
189
+
190
+
val query_response_jsont : query_response Jsont.t
191
+
192
+
(** {1 Foo/queryChanges} *)
193
+
194
+
(** Arguments for /queryChanges methods. *)
195
+
type 'filter query_changes_args = {
196
+
account_id : Proto_id.t;
197
+
filter : 'filter Proto_filter.filter option;
198
+
sort : Proto_filter.comparator list option;
199
+
since_query_state : string;
200
+
max_changes : int64 option;
201
+
up_to_id : Proto_id.t option;
202
+
calculate_total : bool;
203
+
}
204
+
205
+
val query_changes_args_jsont : 'filter Jsont.t -> 'filter query_changes_args Jsont.t
206
+
207
+
(** Response for /queryChanges methods. *)
208
+
type query_changes_response = {
209
+
account_id : Proto_id.t;
210
+
old_query_state : string;
211
+
new_query_state : string;
212
+
total : int64 option;
213
+
removed : Proto_id.t list;
214
+
added : Proto_filter.added_item list;
215
+
}
216
+
217
+
val query_changes_response_jsont : query_changes_response Jsont.t
+132
lib/proto/proto_push.ml
+132
lib/proto/proto_push.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module State_change = struct
7
+
type type_state = {
8
+
type_name : string;
9
+
state : string;
10
+
}
11
+
12
+
type t = {
13
+
type_ : string;
14
+
changed : (Proto_id.t * type_state list) list;
15
+
}
16
+
17
+
(* The changed object is account_id -> { typeName: state } *)
18
+
let changed_jsont =
19
+
let kind = "Changed" in
20
+
(* Inner is type -> state string map *)
21
+
let type_states_jsont = Proto_json_map.of_string Jsont.string in
22
+
(* Convert list of (string * string) to type_state list *)
23
+
let decode_type_states pairs =
24
+
List.map (fun (type_name, state) -> { type_name; state }) pairs
25
+
in
26
+
let encode_type_states states =
27
+
List.map (fun ts -> (ts.type_name, ts.state)) states
28
+
in
29
+
Proto_json_map.of_id
30
+
(Jsont.map ~kind ~dec:decode_type_states ~enc:encode_type_states type_states_jsont)
31
+
32
+
let make type_ changed = { type_; changed }
33
+
34
+
let jsont =
35
+
let kind = "StateChange" in
36
+
Jsont.Object.map ~kind make
37
+
|> Jsont.Object.mem "@type" Jsont.string ~enc:(fun t -> t.type_)
38
+
|> Jsont.Object.mem "changed" changed_jsont ~enc:(fun t -> t.changed)
39
+
|> Jsont.Object.finish
40
+
end
41
+
42
+
type push_keys = {
43
+
p256dh : string;
44
+
auth : string;
45
+
}
46
+
47
+
let push_keys_make p256dh auth = { p256dh; auth }
48
+
49
+
let push_keys_jsont =
50
+
let kind = "PushKeys" in
51
+
Jsont.Object.map ~kind push_keys_make
52
+
|> Jsont.Object.mem "p256dh" Jsont.string ~enc:(fun k -> k.p256dh)
53
+
|> Jsont.Object.mem "auth" Jsont.string ~enc:(fun k -> k.auth)
54
+
|> Jsont.Object.finish
55
+
56
+
type t = {
57
+
id : Proto_id.t;
58
+
device_client_id : string;
59
+
url : string;
60
+
keys : push_keys option;
61
+
verification_code : string option;
62
+
expires : Ptime.t option;
63
+
types : string list option;
64
+
}
65
+
66
+
let id t = t.id
67
+
let device_client_id t = t.device_client_id
68
+
let url t = t.url
69
+
let keys t = t.keys
70
+
let verification_code t = t.verification_code
71
+
let expires t = t.expires
72
+
let types t = t.types
73
+
74
+
let make id device_client_id url keys verification_code expires types =
75
+
{ id; device_client_id; url; keys; verification_code; expires; types }
76
+
77
+
let jsont =
78
+
let kind = "PushSubscription" in
79
+
Jsont.Object.map ~kind make
80
+
|> Jsont.Object.mem "id" Proto_id.jsont ~enc:id
81
+
|> Jsont.Object.mem "deviceClientId" Jsont.string ~enc:device_client_id
82
+
|> Jsont.Object.mem "url" Jsont.string ~enc:url
83
+
|> Jsont.Object.opt_mem "keys" push_keys_jsont ~enc:keys
84
+
|> Jsont.Object.opt_mem "verificationCode" Jsont.string ~enc:verification_code
85
+
|> Jsont.Object.opt_mem "expires" Proto_date.Utc.jsont ~enc:expires
86
+
|> Jsont.Object.opt_mem "types" (Jsont.list Jsont.string) ~enc:types
87
+
|> Jsont.Object.finish
88
+
89
+
let get_args_jsont = Proto_method.get_args_jsont
90
+
let get_response_jsont = Proto_method.get_response_jsont jsont
91
+
92
+
type create_args = {
93
+
device_client_id : string;
94
+
url : string;
95
+
keys : push_keys option;
96
+
verification_code : string option;
97
+
types : string list option;
98
+
}
99
+
100
+
let create_args_make device_client_id url keys verification_code types =
101
+
{ device_client_id; url; keys; verification_code; types }
102
+
103
+
let create_args_jsont =
104
+
let kind = "PushSubscription create" in
105
+
Jsont.Object.map ~kind create_args_make
106
+
|> Jsont.Object.mem "deviceClientId" Jsont.string ~enc:(fun a -> a.device_client_id)
107
+
|> Jsont.Object.mem "url" Jsont.string ~enc:(fun a -> a.url)
108
+
|> Jsont.Object.opt_mem "keys" push_keys_jsont ~enc:(fun a -> a.keys)
109
+
|> Jsont.Object.opt_mem "verificationCode" Jsont.string ~enc:(fun a -> a.verification_code)
110
+
|> Jsont.Object.opt_mem "types" (Jsont.list Jsont.string) ~enc:(fun a -> a.types)
111
+
|> Jsont.Object.finish
112
+
113
+
type set_args = {
114
+
account_id : Proto_id.t option;
115
+
if_in_state : string option;
116
+
create : (Proto_id.t * create_args) list option;
117
+
update : (Proto_id.t * Jsont.json) list option;
118
+
destroy : Proto_id.t list option;
119
+
}
120
+
121
+
let set_args_make account_id if_in_state create update destroy =
122
+
{ account_id; if_in_state; create; update; destroy }
123
+
124
+
let set_args_jsont =
125
+
let kind = "PushSubscription/set args" in
126
+
Jsont.Object.map ~kind set_args_make
127
+
|> Jsont.Object.opt_mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
128
+
|> Jsont.Object.opt_mem "ifInState" Jsont.string ~enc:(fun a -> a.if_in_state)
129
+
|> Jsont.Object.opt_mem "create" (Proto_json_map.of_id create_args_jsont) ~enc:(fun a -> a.create)
130
+
|> Jsont.Object.opt_mem "update" (Proto_json_map.of_id Jsont.json) ~enc:(fun a -> a.update)
131
+
|> Jsont.Object.opt_mem "destroy" (Jsont.list Proto_id.jsont) ~enc:(fun a -> a.destroy)
132
+
|> Jsont.Object.finish
+98
lib/proto/proto_push.mli
+98
lib/proto/proto_push.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP push types as defined in RFC 8620 Section 7
7
+
8
+
@canonical Jmap.Proto.Push *)
9
+
10
+
(** {1 StateChange} *)
11
+
12
+
(** A state change notification for push. *)
13
+
module State_change : sig
14
+
type type_state = {
15
+
type_name : string;
16
+
(** The data type that changed (e.g., "Email", "Mailbox"). *)
17
+
state : string;
18
+
(** The new state string for this type. *)
19
+
}
20
+
21
+
type t = {
22
+
type_ : string;
23
+
(** Always "StateChange". *)
24
+
changed : (Proto_id.t * type_state list) list;
25
+
(** Map of account id to list of type state changes. *)
26
+
}
27
+
28
+
val jsont : t Jsont.t
29
+
end
30
+
31
+
(** {1 PushSubscription} *)
32
+
33
+
(** Web push subscription keys. *)
34
+
type push_keys = {
35
+
p256dh : string;
36
+
(** P-256 ECDH public key as URL-safe base64. *)
37
+
auth : string;
38
+
(** Authentication secret as URL-safe base64. *)
39
+
}
40
+
41
+
val push_keys_jsont : push_keys Jsont.t
42
+
43
+
(** A push subscription object. *)
44
+
type t = {
45
+
id : Proto_id.t;
46
+
(** Server-assigned subscription id. *)
47
+
device_client_id : string;
48
+
(** Client-provided device identifier. *)
49
+
url : string;
50
+
(** The push endpoint URL. *)
51
+
keys : push_keys option;
52
+
(** Optional encryption keys for Web Push. *)
53
+
verification_code : string option;
54
+
(** Code for verifying subscription ownership. *)
55
+
expires : Ptime.t option;
56
+
(** When the subscription expires. *)
57
+
types : string list option;
58
+
(** Data types to receive notifications for. [None] means all. *)
59
+
}
60
+
61
+
val id : t -> Proto_id.t
62
+
val device_client_id : t -> string
63
+
val url : t -> string
64
+
val keys : t -> push_keys option
65
+
val verification_code : t -> string option
66
+
val expires : t -> Ptime.t option
67
+
val types : t -> string list option
68
+
69
+
val jsont : t Jsont.t
70
+
(** JSON codec for PushSubscription. *)
71
+
72
+
(** {1 PushSubscription Methods} *)
73
+
74
+
(** Arguments for PushSubscription/get. *)
75
+
val get_args_jsont : Proto_method.get_args Jsont.t
76
+
77
+
(** Response for PushSubscription/get. *)
78
+
val get_response_jsont : t Proto_method.get_response Jsont.t
79
+
80
+
(** Arguments for PushSubscription/set. *)
81
+
type set_args = {
82
+
account_id : Proto_id.t option;
83
+
(** Not used for PushSubscription. *)
84
+
if_in_state : string option;
85
+
create : (Proto_id.t * create_args) list option;
86
+
update : (Proto_id.t * Jsont.json) list option;
87
+
destroy : Proto_id.t list option;
88
+
}
89
+
90
+
and create_args = {
91
+
device_client_id : string;
92
+
url : string;
93
+
keys : push_keys option;
94
+
verification_code : string option;
95
+
types : string list option;
96
+
}
97
+
98
+
val set_args_jsont : set_args Jsont.t
+34
lib/proto/proto_request.ml
+34
lib/proto/proto_request.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type t = {
7
+
using : string list;
8
+
method_calls : Proto_invocation.t list;
9
+
created_ids : (Proto_id.t * Proto_id.t) list option;
10
+
}
11
+
12
+
let create ~using ~method_calls ?created_ids () =
13
+
{ using; method_calls; created_ids }
14
+
15
+
let using t = t.using
16
+
let method_calls t = t.method_calls
17
+
let created_ids t = t.created_ids
18
+
19
+
let make using method_calls created_ids =
20
+
{ using; method_calls; created_ids }
21
+
22
+
let jsont =
23
+
let kind = "Request" in
24
+
Jsont.Object.map ~kind make
25
+
|> Jsont.Object.mem "using" (Jsont.list Jsont.string) ~enc:using
26
+
|> Jsont.Object.mem "methodCalls" (Jsont.list Proto_invocation.jsont) ~enc:method_calls
27
+
|> Jsont.Object.opt_mem "createdIds" (Proto_json_map.of_id Proto_id.jsont) ~enc:created_ids
28
+
|> Jsont.Object.finish
29
+
30
+
let single ~using invocation =
31
+
{ using; method_calls = [invocation]; created_ids = None }
32
+
33
+
let batch ~using invocations =
34
+
{ using; method_calls = invocations; created_ids = None }
+47
lib/proto/proto_request.mli
+47
lib/proto/proto_request.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP request object as defined in RFC 8620 Section 3.3
7
+
8
+
@canonical Jmap.Proto.Request *)
9
+
10
+
type t = {
11
+
using : string list;
12
+
(** Capability URIs required for this request. *)
13
+
method_calls : Proto_invocation.t list;
14
+
(** The method calls to execute. *)
15
+
created_ids : (Proto_id.t * Proto_id.t) list option;
16
+
(** Map of client-created temporary ids to server-assigned ids.
17
+
Used for result references in batch operations. *)
18
+
}
19
+
20
+
val create :
21
+
using:string list ->
22
+
method_calls:Proto_invocation.t list ->
23
+
?created_ids:(Proto_id.t * Proto_id.t) list ->
24
+
unit ->
25
+
t
26
+
(** [create ~using ~method_calls ?created_ids ()] creates a JMAP request. *)
27
+
28
+
val using : t -> string list
29
+
val method_calls : t -> Proto_invocation.t list
30
+
val created_ids : t -> (Proto_id.t * Proto_id.t) list option
31
+
32
+
val jsont : t Jsont.t
33
+
(** JSON codec for JMAP requests. *)
34
+
35
+
(** {1 Request Builders} *)
36
+
37
+
val single :
38
+
using:string list ->
39
+
Proto_invocation.t ->
40
+
t
41
+
(** [single ~using invocation] creates a request with a single method call. *)
42
+
43
+
val batch :
44
+
using:string list ->
45
+
Proto_invocation.t list ->
46
+
t
47
+
(** [batch ~using invocations] creates a request with multiple method calls. *)
+46
lib/proto/proto_response.ml
+46
lib/proto/proto_response.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type t = {
7
+
method_responses : Proto_invocation.t list;
8
+
created_ids : (Proto_id.t * Proto_id.t) list option;
9
+
session_state : string;
10
+
}
11
+
12
+
let method_responses t = t.method_responses
13
+
let created_ids t = t.created_ids
14
+
let session_state t = t.session_state
15
+
16
+
let make method_responses created_ids session_state =
17
+
{ method_responses; created_ids; session_state }
18
+
19
+
let jsont =
20
+
let kind = "Response" in
21
+
Jsont.Object.map ~kind make
22
+
|> Jsont.Object.mem "methodResponses" (Jsont.list Proto_invocation.jsont) ~enc:method_responses
23
+
|> Jsont.Object.opt_mem "createdIds" (Proto_json_map.of_id Proto_id.jsont) ~enc:created_ids
24
+
|> Jsont.Object.mem "sessionState" Jsont.string ~enc:session_state
25
+
|> Jsont.Object.finish
26
+
27
+
let find_response method_call_id response =
28
+
List.find_opt
29
+
(fun inv -> Proto_invocation.method_call_id inv = method_call_id)
30
+
response.method_responses
31
+
32
+
let get_response method_call_id response =
33
+
match find_response method_call_id response with
34
+
| Some inv -> inv
35
+
| None -> raise Not_found
36
+
37
+
let is_error invocation =
38
+
String.equal (Proto_invocation.name invocation) "error"
39
+
40
+
let get_error invocation =
41
+
if is_error invocation then
42
+
match Jsont.Json.decode' Proto_error.method_error_jsont (Proto_invocation.arguments invocation) with
43
+
| Ok v -> Some v
44
+
| Error _ -> None
45
+
else
46
+
None
+39
lib/proto/proto_response.mli
+39
lib/proto/proto_response.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP response object as defined in RFC 8620 Section 3.4
7
+
8
+
@canonical Jmap.Proto.Response *)
9
+
10
+
type t = {
11
+
method_responses : Proto_invocation.t list;
12
+
(** The method responses. Each is [methodName, responseArgs, methodCallId]. *)
13
+
created_ids : (Proto_id.t * Proto_id.t) list option;
14
+
(** Map of client-created temporary ids to server-assigned ids. *)
15
+
session_state : string;
16
+
(** Current session state. Changes indicate session data has changed. *)
17
+
}
18
+
19
+
val method_responses : t -> Proto_invocation.t list
20
+
val created_ids : t -> (Proto_id.t * Proto_id.t) list option
21
+
val session_state : t -> string
22
+
23
+
val jsont : t Jsont.t
24
+
(** JSON codec for JMAP responses. *)
25
+
26
+
(** {1 Response Inspection} *)
27
+
28
+
val find_response : string -> t -> Proto_invocation.t option
29
+
(** [find_response method_call_id response] finds the response for a method call. *)
30
+
31
+
val get_response : string -> t -> Proto_invocation.t
32
+
(** [get_response method_call_id response] gets the response for a method call.
33
+
@raise Not_found if not found. *)
34
+
35
+
val is_error : Proto_invocation.t -> bool
36
+
(** [is_error invocation] returns [true] if the invocation is an error response. *)
37
+
38
+
val get_error : Proto_invocation.t -> Proto_error.method_error option
39
+
(** [get_error invocation] returns the error if this is an error response. *)
+96
lib/proto/proto_session.ml
+96
lib/proto/proto_session.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module Account = struct
7
+
type t = {
8
+
name : string;
9
+
is_personal : bool;
10
+
is_read_only : bool;
11
+
account_capabilities : (string * Jsont.json) list;
12
+
}
13
+
14
+
let name t = t.name
15
+
let is_personal t = t.is_personal
16
+
let is_read_only t = t.is_read_only
17
+
let account_capabilities t = t.account_capabilities
18
+
19
+
let make name is_personal is_read_only account_capabilities =
20
+
{ name; is_personal; is_read_only; account_capabilities }
21
+
22
+
let jsont =
23
+
let kind = "Account" in
24
+
Jsont.Object.map ~kind make
25
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
26
+
|> Jsont.Object.mem "isPersonal" Jsont.bool ~enc:is_personal
27
+
|> Jsont.Object.mem "isReadOnly" Jsont.bool ~enc:is_read_only
28
+
|> Jsont.Object.mem "accountCapabilities" (Proto_json_map.of_string Jsont.json) ~enc:account_capabilities
29
+
|> Jsont.Object.finish
30
+
end
31
+
32
+
type t = {
33
+
capabilities : (string * Jsont.json) list;
34
+
accounts : (Proto_id.t * Account.t) list;
35
+
primary_accounts : (string * Proto_id.t) list;
36
+
username : string;
37
+
api_url : string;
38
+
download_url : string;
39
+
upload_url : string;
40
+
event_source_url : string;
41
+
state : string;
42
+
}
43
+
44
+
let capabilities t = t.capabilities
45
+
let accounts t = t.accounts
46
+
let primary_accounts t = t.primary_accounts
47
+
let username t = t.username
48
+
let api_url t = t.api_url
49
+
let download_url t = t.download_url
50
+
let upload_url t = t.upload_url
51
+
let event_source_url t = t.event_source_url
52
+
let state t = t.state
53
+
54
+
let make capabilities accounts primary_accounts username api_url
55
+
download_url upload_url event_source_url state =
56
+
{ capabilities; accounts; primary_accounts; username; api_url;
57
+
download_url; upload_url; event_source_url; state }
58
+
59
+
let jsont =
60
+
let kind = "Session" in
61
+
Jsont.Object.map ~kind make
62
+
|> Jsont.Object.mem "capabilities" (Proto_json_map.of_string Jsont.json) ~enc:capabilities
63
+
|> Jsont.Object.mem "accounts" (Proto_json_map.of_id Account.jsont) ~enc:accounts
64
+
|> Jsont.Object.mem "primaryAccounts" (Proto_json_map.of_string Proto_id.jsont) ~enc:primary_accounts
65
+
|> Jsont.Object.mem "username" Jsont.string ~enc:username
66
+
|> Jsont.Object.mem "apiUrl" Jsont.string ~enc:api_url
67
+
|> Jsont.Object.mem "downloadUrl" Jsont.string ~enc:download_url
68
+
|> Jsont.Object.mem "uploadUrl" Jsont.string ~enc:upload_url
69
+
|> Jsont.Object.mem "eventSourceUrl" Jsont.string ~enc:event_source_url
70
+
|> Jsont.Object.mem "state" Jsont.string ~enc:state
71
+
|> Jsont.Object.finish
72
+
73
+
let get_account id session =
74
+
List.assoc_opt id session.accounts
75
+
76
+
let primary_account_for capability session =
77
+
List.assoc_opt capability session.primary_accounts
78
+
79
+
let has_capability uri session =
80
+
List.exists (fun (k, _) -> k = uri) session.capabilities
81
+
82
+
let get_core_capability session =
83
+
match List.assoc_opt Proto_capability.core session.capabilities with
84
+
| None -> None
85
+
| Some json ->
86
+
(match Jsont.Json.decode' Proto_capability.Core.jsont json with
87
+
| Ok v -> Some v
88
+
| Error _ -> None)
89
+
90
+
let get_mail_capability session =
91
+
match List.assoc_opt Proto_capability.mail session.capabilities with
92
+
| None -> None
93
+
| Some json ->
94
+
(match Jsont.Json.decode' Proto_capability.Mail.jsont json with
95
+
| Ok v -> Some v
96
+
| Error _ -> None)
+86
lib/proto/proto_session.mli
+86
lib/proto/proto_session.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP session object as defined in RFC 8620 Section 2
7
+
8
+
@canonical Jmap.Proto.Session *)
9
+
10
+
(** {1 Account} *)
11
+
12
+
(** An account available to the user. *)
13
+
module Account : sig
14
+
type t = {
15
+
name : string;
16
+
(** Human-readable name for the account. *)
17
+
is_personal : bool;
18
+
(** Whether this is a personal account. *)
19
+
is_read_only : bool;
20
+
(** Whether the account is read-only. *)
21
+
account_capabilities : (string * Jsont.json) list;
22
+
(** Capabilities available for this account. *)
23
+
}
24
+
25
+
val name : t -> string
26
+
val is_personal : t -> bool
27
+
val is_read_only : t -> bool
28
+
val account_capabilities : t -> (string * Jsont.json) list
29
+
30
+
val jsont : t Jsont.t
31
+
end
32
+
33
+
(** {1 Session} *)
34
+
35
+
(** The JMAP session resource. *)
36
+
type t = {
37
+
capabilities : (string * Jsont.json) list;
38
+
(** Server capabilities. Keys are capability URIs. *)
39
+
accounts : (Proto_id.t * Account.t) list;
40
+
(** Available accounts keyed by account id. *)
41
+
primary_accounts : (string * Proto_id.t) list;
42
+
(** Map of capability URI to the primary account id for that capability. *)
43
+
username : string;
44
+
(** The username associated with the credentials. *)
45
+
api_url : string;
46
+
(** URL to POST JMAP requests to. *)
47
+
download_url : string;
48
+
(** URL template for downloading blobs. *)
49
+
upload_url : string;
50
+
(** URL template for uploading blobs. *)
51
+
event_source_url : string;
52
+
(** URL for push event source. *)
53
+
state : string;
54
+
(** Opaque session state string. *)
55
+
}
56
+
57
+
val capabilities : t -> (string * Jsont.json) list
58
+
val accounts : t -> (Proto_id.t * Account.t) list
59
+
val primary_accounts : t -> (string * Proto_id.t) list
60
+
val username : t -> string
61
+
val api_url : t -> string
62
+
val download_url : t -> string
63
+
val upload_url : t -> string
64
+
val event_source_url : t -> string
65
+
val state : t -> string
66
+
67
+
val jsont : t Jsont.t
68
+
(** JSON codec for session objects. *)
69
+
70
+
(** {1 Session Helpers} *)
71
+
72
+
val get_account : Proto_id.t -> t -> Account.t option
73
+
(** [get_account id session] returns the account with the given id. *)
74
+
75
+
val primary_account_for : string -> t -> Proto_id.t option
76
+
(** [primary_account_for capability session] returns the primary account
77
+
for the given capability URI. *)
78
+
79
+
val has_capability : string -> t -> bool
80
+
(** [has_capability uri session] returns [true] if the server supports the capability. *)
81
+
82
+
val get_core_capability : t -> Proto_capability.Core.t option
83
+
(** [get_core_capability session] returns the parsed core capability. *)
84
+
85
+
val get_mail_capability : t -> Proto_capability.Mail.t option
86
+
(** [get_mail_capability session] returns the parsed mail capability. *)
+14
lib/proto/proto_unknown.ml
+14
lib/proto/proto_unknown.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type t = Jsont.json
7
+
8
+
let empty = Jsont.Object ([], Jsont.Meta.none)
9
+
10
+
let is_empty = function
11
+
| Jsont.Object ([], _) -> true
12
+
| _ -> false
13
+
14
+
let mems = Jsont.json_mems
+25
lib/proto/proto_unknown.mli
+25
lib/proto/proto_unknown.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Unknown field preservation for forward compatibility.
7
+
8
+
All JMAP objects preserve unknown fields to support future spec versions
9
+
and custom extensions.
10
+
11
+
@canonical Jmap.Proto.Unknown *)
12
+
13
+
type t = Jsont.json
14
+
(** Unknown or unrecognized JSON object members as a generic JSON value.
15
+
This is always an object containing the unknown fields. *)
16
+
17
+
val empty : t
18
+
(** [empty] is the empty set of unknown fields (an empty JSON object). *)
19
+
20
+
val is_empty : t -> bool
21
+
(** [is_empty u] returns [true] if there are no unknown fields. *)
22
+
23
+
val mems : (t, t, Jsont.mem list) Jsont.Object.Mems.map
24
+
(** [mems] is the jsont member map for preserving unknown fields.
25
+
Use with [Jsont.Object.keep_unknown]. *)
+6
lib/top/dune
+6
lib/top/dune
+68
lib/top/jmap_top.ml
+68
lib/top/jmap_top.ml
···
1
+
(* Toplevel printers for JMAP types
2
+
3
+
Usage in toplevel:
4
+
#require "jmap.top";;
5
+
6
+
Printers are automatically installed when the library is loaded.
7
+
*)
8
+
9
+
(* JSON printers *)
10
+
11
+
let json_printer ppf (json : Jsont.json) =
12
+
match Jsont_bytesrw.encode_string Jsont.json json with
13
+
| Ok s -> Format.pp_print_string ppf s
14
+
| Error e -> Format.fprintf ppf "<json encoding error: %s>" e
15
+
16
+
let jsont_error_printer ppf (e : Jsont.Error.t) =
17
+
Format.pp_print_string ppf (Jsont.Error.to_string e)
18
+
19
+
(* JSON encoding helpers *)
20
+
21
+
let encode (type a) (codec : a Jsont.t) (value : a) : Jsont.json =
22
+
match Jsont.Json.encode codec value with
23
+
| Ok json -> json
24
+
| Error e -> invalid_arg e
25
+
26
+
let encode_string (type a) (codec : a Jsont.t) (value : a) : string =
27
+
match Jsont_bytesrw.encode_string codec value with
28
+
| Ok s -> s
29
+
| Error e -> invalid_arg e
30
+
31
+
let pp_as_json (type a) (codec : a Jsont.t) ppf (value : a) =
32
+
json_printer ppf (encode codec value)
33
+
34
+
(* Automatic printer installation *)
35
+
36
+
let printers =
37
+
[ "Jmap.Id.pp";
38
+
"Jmap.Keyword.pp";
39
+
"Jmap.Role.pp";
40
+
"Jmap.Capability.pp";
41
+
"Jmap.Error.pp";
42
+
"Jmap_top.json_printer";
43
+
"Jmap_top.jsont_error_printer" ]
44
+
45
+
(* Suppress stderr during printer installation to avoid noise in MDX tests *)
46
+
let null_formatter = Format.make_formatter (fun _ _ _ -> ()) (fun () -> ())
47
+
48
+
let eval_string_quiet str =
49
+
try
50
+
let lexbuf = Lexing.from_string str in
51
+
let phrase = !Toploop.parse_toplevel_phrase lexbuf in
52
+
Toploop.execute_phrase false null_formatter phrase
53
+
with _ -> false
54
+
55
+
let rec do_install_printers = function
56
+
| [] -> true
57
+
| printer :: rest ->
58
+
let cmd = Printf.sprintf "#install_printer %s;;" printer in
59
+
eval_string_quiet cmd && do_install_printers rest
60
+
61
+
let install () =
62
+
(* Silently ignore failures - this handles non-toplevel contexts like MDX *)
63
+
ignore (do_install_printers printers)
64
+
65
+
(* Only auto-install when OCAML_TOPLEVEL_NAME is set, indicating a real toplevel *)
66
+
let () =
67
+
if Sys.getenv_opt "OCAML_TOPLEVEL_NAME" <> None then
68
+
install ()
+50
lib/top/jmap_top.mli
+50
lib/top/jmap_top.mli
···
1
+
(** Toplevel printers for JMAP types.
2
+
3
+
Printers are automatically installed when the library is loaded:
4
+
{[
5
+
#require "jmap.top";;
6
+
]}
7
+
8
+
After loading, JMAP types will display nicely:
9
+
{[
10
+
# Jmap.Id.of_string_exn "abc123";;
11
+
- : Jmap.Id.t = <id:abc123>
12
+
13
+
# Jmap.Keyword.of_string "$seen";;
14
+
- : Jmap.Keyword.t = `Seen
15
+
16
+
# Jmap.Role.of_string "inbox";;
17
+
- : Jmap.Role.t = `Inbox
18
+
]}
19
+
20
+
JSON values display as formatted strings, making it easy to see
21
+
how OCaml types map to JMAP JSON. *)
22
+
23
+
(** {1 JSON Printers} *)
24
+
25
+
val json_printer : Format.formatter -> Jsont.json -> unit
26
+
(** Formats a JSON value as a compact JSON string. *)
27
+
28
+
val jsont_error_printer : Format.formatter -> Jsont.Error.t -> unit
29
+
(** Formats a Jsont parsing error. *)
30
+
31
+
(** {1 JSON Encoding Helpers}
32
+
33
+
These functions encode OCaml types to JSON, useful for understanding
34
+
how the library maps to JMAP wire format. *)
35
+
36
+
val encode : 'a Jsont.t -> 'a -> Jsont.json
37
+
(** [encode codec value] encodes a value to JSON using the given codec.
38
+
Raises [Invalid_argument] on encoding failure. *)
39
+
40
+
val encode_string : 'a Jsont.t -> 'a -> string
41
+
(** [encode_string codec value] encodes a value to a JSON string. *)
42
+
43
+
val pp_as_json : 'a Jsont.t -> Format.formatter -> 'a -> unit
44
+
(** [pp_as_json codec ppf value] pretty-prints a value as JSON. *)
45
+
46
+
(** {1 Installation} *)
47
+
48
+
val install : unit -> unit
49
+
(** [install ()] installs all printers. This is called automatically when
50
+
the library is loaded, but can be called again if needed. *)
-105
proto/blob.ml
-105
proto/blob.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type upload_response = {
7
-
account_id : Id.t;
8
-
blob_id : Id.t;
9
-
type_ : string;
10
-
size : int64;
11
-
}
12
-
13
-
let upload_response_account_id t = t.account_id
14
-
let upload_response_blob_id t = t.blob_id
15
-
let upload_response_type t = t.type_
16
-
let upload_response_size t = t.size
17
-
18
-
let upload_response_make account_id blob_id type_ size =
19
-
{ account_id; blob_id; type_; size }
20
-
21
-
let upload_response_jsont =
22
-
let kind = "Upload response" in
23
-
Jsont.Object.map ~kind upload_response_make
24
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:upload_response_account_id
25
-
|> Jsont.Object.mem "blobId" Id.jsont ~enc:upload_response_blob_id
26
-
|> Jsont.Object.mem "type" Jsont.string ~enc:upload_response_type
27
-
|> Jsont.Object.mem "size" Int53.Unsigned.jsont ~enc:upload_response_size
28
-
|> Jsont.Object.finish
29
-
30
-
type download_vars = {
31
-
account_id : Id.t;
32
-
blob_id : Id.t;
33
-
type_ : string;
34
-
name : string;
35
-
}
36
-
37
-
let expand_download_url ~template vars =
38
-
let url_encode s =
39
-
(* Simple URL encoding *)
40
-
let buf = Buffer.create (String.length s * 3) in
41
-
String.iter (fun c ->
42
-
match c with
43
-
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '-' | '_' | '.' | '~' ->
44
-
Buffer.add_char buf c
45
-
| _ ->
46
-
Buffer.add_string buf (Printf.sprintf "%%%02X" (Char.code c))
47
-
) s;
48
-
Buffer.contents buf
49
-
in
50
-
template
51
-
|> String.split_on_char '{'
52
-
|> List.mapi (fun i part ->
53
-
if i = 0 then part
54
-
else
55
-
match String.index_opt part '}' with
56
-
| None -> "{" ^ part
57
-
| Some j ->
58
-
let var = String.sub part 0 j in
59
-
let rest = String.sub part (j + 1) (String.length part - j - 1) in
60
-
let value = match var with
61
-
| "accountId" -> url_encode (Id.to_string vars.account_id)
62
-
| "blobId" -> url_encode (Id.to_string vars.blob_id)
63
-
| "type" -> url_encode vars.type_
64
-
| "name" -> url_encode vars.name
65
-
| _ -> "{" ^ var ^ "}"
66
-
in
67
-
value ^ rest
68
-
)
69
-
|> String.concat ""
70
-
71
-
type copy_args = {
72
-
from_account_id : Id.t;
73
-
account_id : Id.t;
74
-
blob_ids : Id.t list;
75
-
}
76
-
77
-
let copy_args_make from_account_id account_id blob_ids =
78
-
{ from_account_id; account_id; blob_ids }
79
-
80
-
let copy_args_jsont =
81
-
let kind = "Blob/copy args" in
82
-
Jsont.Object.map ~kind copy_args_make
83
-
|> Jsont.Object.mem "fromAccountId" Id.jsont ~enc:(fun a -> a.from_account_id)
84
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:(fun a -> a.account_id)
85
-
|> Jsont.Object.mem "blobIds" (Jsont.list Id.jsont) ~enc:(fun a -> a.blob_ids)
86
-
|> Jsont.Object.finish
87
-
88
-
type copy_response = {
89
-
from_account_id : Id.t;
90
-
account_id : Id.t;
91
-
copied : (Id.t * Id.t) list option;
92
-
not_copied : (Id.t * Error.set_error) list option;
93
-
}
94
-
95
-
let copy_response_make from_account_id account_id copied not_copied =
96
-
{ from_account_id; account_id; copied; not_copied }
97
-
98
-
let copy_response_jsont =
99
-
let kind = "Blob/copy response" in
100
-
Jsont.Object.map ~kind copy_response_make
101
-
|> Jsont.Object.mem "fromAccountId" Id.jsont ~enc:(fun r -> r.from_account_id)
102
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:(fun r -> r.account_id)
103
-
|> Jsont.Object.opt_mem "copied" (Json_map.of_id Id.jsont) ~enc:(fun r -> r.copied)
104
-
|> Jsont.Object.opt_mem "notCopied" (Json_map.of_id Error.set_error_jsont) ~enc:(fun r -> r.not_copied)
105
-
|> Jsont.Object.finish
-65
proto/blob.mli
-65
proto/blob.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP blob upload/download types as defined in RFC 8620 Section 6 *)
7
-
8
-
(** {1 Upload Response} *)
9
-
10
-
(** Response from a blob upload. *)
11
-
type upload_response = {
12
-
account_id : Id.t;
13
-
(** The account the blob was uploaded to. *)
14
-
blob_id : Id.t;
15
-
(** The server-assigned blob id. *)
16
-
type_ : string;
17
-
(** The media type of the uploaded blob. *)
18
-
size : int64;
19
-
(** The size in octets. *)
20
-
}
21
-
22
-
val upload_response_account_id : upload_response -> Id.t
23
-
val upload_response_blob_id : upload_response -> Id.t
24
-
val upload_response_type : upload_response -> string
25
-
val upload_response_size : upload_response -> int64
26
-
27
-
val upload_response_jsont : upload_response Jsont.t
28
-
29
-
(** {1 Download URL Template} *)
30
-
31
-
(** Variables for the download URL template. *)
32
-
type download_vars = {
33
-
account_id : Id.t;
34
-
blob_id : Id.t;
35
-
type_ : string;
36
-
name : string;
37
-
}
38
-
39
-
val expand_download_url : template:string -> download_vars -> string
40
-
(** [expand_download_url ~template vars] expands the download URL template
41
-
with the given variables. Template uses {accountId}, {blobId},
42
-
{type}, and {name} placeholders. *)
43
-
44
-
(** {1 Blob/copy} *)
45
-
46
-
(** Arguments for Blob/copy. *)
47
-
type copy_args = {
48
-
from_account_id : Id.t;
49
-
account_id : Id.t;
50
-
blob_ids : Id.t list;
51
-
}
52
-
53
-
val copy_args_jsont : copy_args Jsont.t
54
-
55
-
(** Response for Blob/copy. *)
56
-
type copy_response = {
57
-
from_account_id : Id.t;
58
-
account_id : Id.t;
59
-
copied : (Id.t * Id.t) list option;
60
-
(** Map of old blob id to new blob id. *)
61
-
not_copied : (Id.t * Error.set_error) list option;
62
-
(** Blobs that could not be copied. *)
63
-
}
64
-
65
-
val copy_response_jsont : copy_response Jsont.t
-171
proto/capability.ml
-171
proto/capability.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
let core = "urn:ietf:params:jmap:core"
7
-
let mail = "urn:ietf:params:jmap:mail"
8
-
let submission = "urn:ietf:params:jmap:submission"
9
-
let vacation_response = "urn:ietf:params:jmap:vacationresponse"
10
-
11
-
module Core = struct
12
-
type t = {
13
-
max_size_upload : int64;
14
-
max_concurrent_upload : int;
15
-
max_size_request : int64;
16
-
max_concurrent_requests : int;
17
-
max_calls_in_request : int;
18
-
max_objects_in_get : int;
19
-
max_objects_in_set : int;
20
-
collation_algorithms : string list;
21
-
}
22
-
23
-
let create ~max_size_upload ~max_concurrent_upload ~max_size_request
24
-
~max_concurrent_requests ~max_calls_in_request ~max_objects_in_get
25
-
~max_objects_in_set ~collation_algorithms =
26
-
{ max_size_upload; max_concurrent_upload; max_size_request;
27
-
max_concurrent_requests; max_calls_in_request; max_objects_in_get;
28
-
max_objects_in_set; collation_algorithms }
29
-
30
-
let max_size_upload t = t.max_size_upload
31
-
let max_concurrent_upload t = t.max_concurrent_upload
32
-
let max_size_request t = t.max_size_request
33
-
let max_concurrent_requests t = t.max_concurrent_requests
34
-
let max_calls_in_request t = t.max_calls_in_request
35
-
let max_objects_in_get t = t.max_objects_in_get
36
-
let max_objects_in_set t = t.max_objects_in_set
37
-
let collation_algorithms t = t.collation_algorithms
38
-
39
-
let make max_size_upload max_concurrent_upload max_size_request
40
-
max_concurrent_requests max_calls_in_request max_objects_in_get
41
-
max_objects_in_set collation_algorithms =
42
-
{ max_size_upload; max_concurrent_upload; max_size_request;
43
-
max_concurrent_requests; max_calls_in_request; max_objects_in_get;
44
-
max_objects_in_set; collation_algorithms }
45
-
46
-
let jsont =
47
-
let kind = "Core capability" in
48
-
Jsont.Object.map ~kind make
49
-
|> Jsont.Object.mem "maxSizeUpload" Int53.Unsigned.jsont ~enc:max_size_upload
50
-
|> Jsont.Object.mem "maxConcurrentUpload" Jsont.int ~enc:max_concurrent_upload
51
-
|> Jsont.Object.mem "maxSizeRequest" Int53.Unsigned.jsont ~enc:max_size_request
52
-
|> Jsont.Object.mem "maxConcurrentRequests" Jsont.int ~enc:max_concurrent_requests
53
-
|> Jsont.Object.mem "maxCallsInRequest" Jsont.int ~enc:max_calls_in_request
54
-
|> Jsont.Object.mem "maxObjectsInGet" Jsont.int ~enc:max_objects_in_get
55
-
|> Jsont.Object.mem "maxObjectsInSet" Jsont.int ~enc:max_objects_in_set
56
-
|> Jsont.Object.mem "collationAlgorithms" (Jsont.list Jsont.string) ~enc:collation_algorithms
57
-
|> Jsont.Object.finish
58
-
end
59
-
60
-
module Mail = struct
61
-
type t = {
62
-
max_mailboxes_per_email : int64 option;
63
-
max_mailbox_depth : int64 option;
64
-
max_size_mailbox_name : int64;
65
-
max_size_attachments_per_email : int64;
66
-
email_query_sort_options : string list;
67
-
may_create_top_level_mailbox : bool;
68
-
}
69
-
70
-
let create ?max_mailboxes_per_email ?max_mailbox_depth ~max_size_mailbox_name
71
-
~max_size_attachments_per_email ~email_query_sort_options
72
-
~may_create_top_level_mailbox () =
73
-
{ max_mailboxes_per_email; max_mailbox_depth; max_size_mailbox_name;
74
-
max_size_attachments_per_email; email_query_sort_options;
75
-
may_create_top_level_mailbox }
76
-
77
-
let max_mailboxes_per_email t = t.max_mailboxes_per_email
78
-
let max_mailbox_depth t = t.max_mailbox_depth
79
-
let max_size_mailbox_name t = t.max_size_mailbox_name
80
-
let max_size_attachments_per_email t = t.max_size_attachments_per_email
81
-
let email_query_sort_options t = t.email_query_sort_options
82
-
let may_create_top_level_mailbox t = t.may_create_top_level_mailbox
83
-
84
-
let make max_mailboxes_per_email max_mailbox_depth max_size_mailbox_name
85
-
max_size_attachments_per_email email_query_sort_options
86
-
may_create_top_level_mailbox =
87
-
{ max_mailboxes_per_email; max_mailbox_depth; max_size_mailbox_name;
88
-
max_size_attachments_per_email; email_query_sort_options;
89
-
may_create_top_level_mailbox }
90
-
91
-
let jsont =
92
-
let kind = "Mail capability" in
93
-
Jsont.Object.map ~kind make
94
-
|> Jsont.Object.opt_mem "maxMailboxesPerEmail" Int53.Unsigned.jsont ~enc:max_mailboxes_per_email
95
-
|> Jsont.Object.opt_mem "maxMailboxDepth" Int53.Unsigned.jsont ~enc:max_mailbox_depth
96
-
|> Jsont.Object.mem "maxSizeMailboxName" Int53.Unsigned.jsont ~enc:max_size_mailbox_name
97
-
|> Jsont.Object.mem "maxSizeAttachmentsPerEmail" Int53.Unsigned.jsont ~enc:max_size_attachments_per_email
98
-
|> Jsont.Object.mem "emailQuerySortOptions" (Jsont.list Jsont.string) ~enc:email_query_sort_options
99
-
|> Jsont.Object.mem "mayCreateTopLevelMailbox" Jsont.bool ~enc:may_create_top_level_mailbox
100
-
|> Jsont.Object.finish
101
-
end
102
-
103
-
module Submission = struct
104
-
type t = {
105
-
max_delayed_send : int64;
106
-
submission_extensions : (string * string list) list;
107
-
}
108
-
109
-
let create ~max_delayed_send ~submission_extensions =
110
-
{ max_delayed_send; submission_extensions }
111
-
112
-
let max_delayed_send t = t.max_delayed_send
113
-
let submission_extensions t = t.submission_extensions
114
-
115
-
let make max_delayed_send submission_extensions =
116
-
{ max_delayed_send; submission_extensions }
117
-
118
-
let submission_extensions_jsont =
119
-
Json_map.of_string (Jsont.list Jsont.string)
120
-
121
-
let jsont =
122
-
let kind = "Submission capability" in
123
-
Jsont.Object.map ~kind make
124
-
|> Jsont.Object.mem "maxDelayedSend" Int53.Unsigned.jsont ~enc:max_delayed_send
125
-
|> Jsont.Object.mem "submissionExtensions" submission_extensions_jsont ~enc:submission_extensions
126
-
|> Jsont.Object.finish
127
-
end
128
-
129
-
type capability =
130
-
| Core of Core.t
131
-
| Mail of Mail.t
132
-
| Submission of Submission.t
133
-
| Vacation_response
134
-
| Unknown of Jsont.json
135
-
136
-
let capability_of_json uri json =
137
-
match uri with
138
-
| u when u = core ->
139
-
(match Jsont.Json.decode' Core.jsont json with
140
-
| Ok c -> Core c
141
-
| Error _ -> Unknown json)
142
-
| u when u = mail ->
143
-
(match Jsont.Json.decode' Mail.jsont json with
144
-
| Ok m -> Mail m
145
-
| Error _ -> Unknown json)
146
-
| u when u = submission ->
147
-
(match Jsont.Json.decode' Submission.jsont json with
148
-
| Ok s -> Submission s
149
-
| Error _ -> Unknown json)
150
-
| u when u = vacation_response ->
151
-
Vacation_response
152
-
| _ ->
153
-
Unknown json
154
-
155
-
let capability_to_json (uri, cap) =
156
-
let encode jsont v =
157
-
match Jsont.Json.encode' jsont v with
158
-
| Ok json -> json
159
-
| Error _ -> Jsont.Object ([], Jsont.Meta.none)
160
-
in
161
-
match cap with
162
-
| Core c ->
163
-
(uri, encode Core.jsont c)
164
-
| Mail m ->
165
-
(uri, encode Mail.jsont m)
166
-
| Submission s ->
167
-
(uri, encode Submission.jsont s)
168
-
| Vacation_response ->
169
-
(uri, Jsont.Object ([], Jsont.Meta.none))
170
-
| Unknown json ->
171
-
(uri, json)
-143
proto/capability.mli
-143
proto/capability.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP capability types as defined in RFC 8620 Section 2 *)
7
-
8
-
(** {1 Standard Capability URIs} *)
9
-
10
-
val core : string
11
-
(** [urn:ietf:params:jmap:core] - Core JMAP capability (RFC 8620) *)
12
-
13
-
val mail : string
14
-
(** [urn:ietf:params:jmap:mail] - Mail capability (RFC 8621) *)
15
-
16
-
val submission : string
17
-
(** [urn:ietf:params:jmap:submission] - Email submission capability (RFC 8621) *)
18
-
19
-
val vacation_response : string
20
-
(** [urn:ietf:params:jmap:vacationresponse] - Vacation response capability (RFC 8621) *)
21
-
22
-
(** {1 Core Capability Object} *)
23
-
24
-
(** Core capability limits and configuration per RFC 8620 Section 2. *)
25
-
module Core : sig
26
-
type t = {
27
-
max_size_upload : int64;
28
-
(** Maximum size in octets for a single blob upload. *)
29
-
max_concurrent_upload : int;
30
-
(** Maximum number of concurrent upload requests. *)
31
-
max_size_request : int64;
32
-
(** Maximum size in octets of a single request. *)
33
-
max_concurrent_requests : int;
34
-
(** Maximum number of concurrent requests. *)
35
-
max_calls_in_request : int;
36
-
(** Maximum number of method calls in a single request. *)
37
-
max_objects_in_get : int;
38
-
(** Maximum number of objects in a single /get request. *)
39
-
max_objects_in_set : int;
40
-
(** Maximum number of objects in a single /set request. *)
41
-
collation_algorithms : string list;
42
-
(** Supported collation algorithms for sorting. *)
43
-
}
44
-
45
-
val create :
46
-
max_size_upload:int64 ->
47
-
max_concurrent_upload:int ->
48
-
max_size_request:int64 ->
49
-
max_concurrent_requests:int ->
50
-
max_calls_in_request:int ->
51
-
max_objects_in_get:int ->
52
-
max_objects_in_set:int ->
53
-
collation_algorithms:string list ->
54
-
t
55
-
56
-
val max_size_upload : t -> int64
57
-
val max_concurrent_upload : t -> int
58
-
val max_size_request : t -> int64
59
-
val max_concurrent_requests : t -> int
60
-
val max_calls_in_request : t -> int
61
-
val max_objects_in_get : t -> int
62
-
val max_objects_in_set : t -> int
63
-
val collation_algorithms : t -> string list
64
-
65
-
val jsont : t Jsont.t
66
-
(** JSON codec for core capability. *)
67
-
end
68
-
69
-
(** {1 Mail Capability Object} *)
70
-
71
-
(** Mail capability configuration per RFC 8621. *)
72
-
module Mail : sig
73
-
type t = {
74
-
max_mailboxes_per_email : int64 option;
75
-
(** Maximum number of mailboxes an email can belong to. *)
76
-
max_mailbox_depth : int64 option;
77
-
(** Maximum depth of mailbox hierarchy. *)
78
-
max_size_mailbox_name : int64;
79
-
(** Maximum size of a mailbox name in octets. *)
80
-
max_size_attachments_per_email : int64;
81
-
(** Maximum total size of attachments per email. *)
82
-
email_query_sort_options : string list;
83
-
(** Supported sort options for Email/query. *)
84
-
may_create_top_level_mailbox : bool;
85
-
(** Whether the user may create top-level mailboxes. *)
86
-
}
87
-
88
-
val create :
89
-
?max_mailboxes_per_email:int64 ->
90
-
?max_mailbox_depth:int64 ->
91
-
max_size_mailbox_name:int64 ->
92
-
max_size_attachments_per_email:int64 ->
93
-
email_query_sort_options:string list ->
94
-
may_create_top_level_mailbox:bool ->
95
-
unit ->
96
-
t
97
-
98
-
val max_mailboxes_per_email : t -> int64 option
99
-
val max_mailbox_depth : t -> int64 option
100
-
val max_size_mailbox_name : t -> int64
101
-
val max_size_attachments_per_email : t -> int64
102
-
val email_query_sort_options : t -> string list
103
-
val may_create_top_level_mailbox : t -> bool
104
-
105
-
val jsont : t Jsont.t
106
-
end
107
-
108
-
(** {1 Submission Capability Object} *)
109
-
110
-
module Submission : sig
111
-
type t = {
112
-
max_delayed_send : int64;
113
-
(** Maximum delay in seconds for delayed sending (0 = not supported). *)
114
-
submission_extensions : (string * string list) list;
115
-
(** SMTP extensions supported. *)
116
-
}
117
-
118
-
val create :
119
-
max_delayed_send:int64 ->
120
-
submission_extensions:(string * string list) list ->
121
-
t
122
-
123
-
val max_delayed_send : t -> int64
124
-
val submission_extensions : t -> (string * string list) list
125
-
126
-
val jsont : t Jsont.t
127
-
end
128
-
129
-
(** {1 Generic Capability Handling} *)
130
-
131
-
(** A capability value that can be either a known type or unknown JSON. *)
132
-
type capability =
133
-
| Core of Core.t
134
-
| Mail of Mail.t
135
-
| Submission of Submission.t
136
-
| Vacation_response (* No configuration *)
137
-
| Unknown of Jsont.json
138
-
139
-
val capability_of_json : string -> Jsont.json -> capability
140
-
(** [capability_of_json uri json] parses a capability from its URI and JSON value. *)
141
-
142
-
val capability_to_json : string * capability -> string * Jsont.json
143
-
(** [capability_to_json (uri, cap)] encodes a capability to URI and JSON. *)
-64
proto/date.ml
-64
proto/date.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Date and time types for JMAP.
7
-
8
-
JMAP uses RFC 3339 formatted date-time strings. *)
9
-
10
-
(** RFC 3339 date-time with any timezone offset *)
11
-
module Rfc3339 = struct
12
-
type t = Ptime.t
13
-
14
-
let of_string s =
15
-
match Ptime.of_rfc3339 s with
16
-
| Ok (t, _, _) -> Ok t
17
-
| Error _ -> Error (Printf.sprintf "Invalid RFC 3339 date: %s" s)
18
-
19
-
let to_string t =
20
-
(* Format with 'T' separator and timezone offset *)
21
-
Ptime.to_rfc3339 ~tz_offset_s:0 t
22
-
23
-
let jsont =
24
-
let kind = "Date" in
25
-
let dec s =
26
-
match of_string s with
27
-
| Ok t -> t
28
-
| Error msg -> Jsont.Error.msgf Jsont.Meta.none "%s: %s" kind msg
29
-
in
30
-
let enc = to_string in
31
-
Jsont.map ~kind ~dec ~enc Jsont.string
32
-
end
33
-
34
-
(** UTC date-time (must use 'Z' timezone suffix) *)
35
-
module Utc = struct
36
-
type t = Ptime.t
37
-
38
-
let of_string s =
39
-
(* Must end with 'Z' for UTC *)
40
-
let len = String.length s in
41
-
if len > 0 && s.[len - 1] <> 'Z' then
42
-
Error "UTCDate must use 'Z' timezone suffix"
43
-
else
44
-
match Ptime.of_rfc3339 s with
45
-
| Ok (t, _, _) -> Ok t
46
-
| Error _ -> Error (Printf.sprintf "Invalid RFC 3339 UTC date: %s" s)
47
-
48
-
let to_string t =
49
-
(* Always format with 'Z' suffix *)
50
-
Ptime.to_rfc3339 ~tz_offset_s:0 t
51
-
52
-
let of_ptime t = t
53
-
let to_ptime t = t
54
-
55
-
let jsont =
56
-
let kind = "UTCDate" in
57
-
let dec s =
58
-
match of_string s with
59
-
| Ok t -> t
60
-
| Error msg -> Jsont.Error.msgf Jsont.Meta.none "%s: %s" kind msg
61
-
in
62
-
let enc = to_string in
63
-
Jsont.map ~kind ~dec ~enc Jsont.string
64
-
end
-51
proto/date.mli
-51
proto/date.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Date and time types for JMAP.
7
-
8
-
JMAP uses RFC 3339 formatted date-time strings.
9
-
10
-
See {{:https://datatracker.ietf.org/doc/html/rfc8620#section-1.4} RFC 8620 Section 1.4}. *)
11
-
12
-
(** RFC 3339 date-time.
13
-
14
-
A date-time string with uppercase 'T' separator. May have any timezone. *)
15
-
module Rfc3339 : sig
16
-
type t = Ptime.t
17
-
(** The type of dates. *)
18
-
19
-
val of_string : string -> (t, string) result
20
-
(** [of_string s] parses an RFC 3339 date-time string. *)
21
-
22
-
val to_string : t -> string
23
-
(** [to_string d] formats [d] as an RFC 3339 string. *)
24
-
25
-
val jsont : t Jsont.t
26
-
(** JSON codec for RFC 3339 dates. *)
27
-
end
28
-
29
-
(** UTC date-time.
30
-
31
-
A date-time string that MUST have 'Z' as the timezone (UTC only). *)
32
-
module Utc : sig
33
-
type t = Ptime.t
34
-
(** The type of UTC dates. *)
35
-
36
-
val of_string : string -> (t, string) result
37
-
(** [of_string s] parses an RFC 3339 UTC date-time string.
38
-
Returns error if timezone is not 'Z'. *)
39
-
40
-
val to_string : t -> string
41
-
(** [to_string d] formats [d] as an RFC 3339 UTC string with 'Z'. *)
42
-
43
-
val of_ptime : Ptime.t -> t
44
-
(** [of_ptime p] creates a UTC date from a Ptime value. *)
45
-
46
-
val to_ptime : t -> Ptime.t
47
-
(** [to_ptime d] returns the underlying Ptime value. *)
48
-
49
-
val jsont : t Jsont.t
50
-
(** JSON codec for UTC dates. *)
51
-
end
-21
proto/dune
-21
proto/dune
···
1
-
(library
2
-
(name jmap_proto)
3
-
(public_name jmap)
4
-
(libraries jsont json-pointer ptime)
5
-
(modules
6
-
jmap_proto
7
-
id
8
-
int53
9
-
date
10
-
json_map
11
-
unknown
12
-
error
13
-
capability
14
-
filter
15
-
method_
16
-
invocation
17
-
request
18
-
response
19
-
session
20
-
push
21
-
blob))
-190
proto/error.ml
-190
proto/error.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
module Request_error = struct
7
-
type urn =
8
-
| Unknown_capability
9
-
| Not_json
10
-
| Not_request
11
-
| Limit
12
-
| Other of string
13
-
14
-
let urn_to_string = function
15
-
| Unknown_capability -> "urn:ietf:params:jmap:error:unknownCapability"
16
-
| Not_json -> "urn:ietf:params:jmap:error:notJSON"
17
-
| Not_request -> "urn:ietf:params:jmap:error:notRequest"
18
-
| Limit -> "urn:ietf:params:jmap:error:limit"
19
-
| Other s -> s
20
-
21
-
let urn_of_string = function
22
-
| "urn:ietf:params:jmap:error:unknownCapability" -> Unknown_capability
23
-
| "urn:ietf:params:jmap:error:notJSON" -> Not_json
24
-
| "urn:ietf:params:jmap:error:notRequest" -> Not_request
25
-
| "urn:ietf:params:jmap:error:limit" -> Limit
26
-
| s -> Other s
27
-
28
-
let urn_jsont =
29
-
let kind = "Request error URN" in
30
-
Jsont.map ~kind
31
-
~dec:(fun s -> urn_of_string s)
32
-
~enc:urn_to_string
33
-
Jsont.string
34
-
35
-
type t = {
36
-
type_ : urn;
37
-
status : int;
38
-
title : string option;
39
-
detail : string option;
40
-
limit : string option;
41
-
}
42
-
43
-
let make type_ status title detail limit =
44
-
{ type_; status; title; detail; limit }
45
-
46
-
let type_ t = t.type_
47
-
let status t = t.status
48
-
let title t = t.title
49
-
let detail t = t.detail
50
-
let limit t = t.limit
51
-
52
-
let jsont =
53
-
let kind = "Request error" in
54
-
Jsont.Object.map ~kind make
55
-
|> Jsont.Object.mem "type" urn_jsont ~enc:type_
56
-
|> Jsont.Object.mem "status" Jsont.int ~enc:status
57
-
|> Jsont.Object.opt_mem "title" Jsont.string ~enc:title
58
-
|> Jsont.Object.opt_mem "detail" Jsont.string ~enc:detail
59
-
|> Jsont.Object.opt_mem "limit" Jsont.string ~enc:limit
60
-
|> Jsont.Object.finish
61
-
end
62
-
63
-
type method_error_type =
64
-
| Server_unavailable
65
-
| Server_fail
66
-
| Server_partial_fail
67
-
| Unknown_method
68
-
| Invalid_arguments
69
-
| Invalid_result_reference
70
-
| Forbidden
71
-
| Account_not_found
72
-
| Account_not_supported_by_method
73
-
| Account_read_only
74
-
| Other of string
75
-
76
-
let method_error_type_to_string = function
77
-
| Server_unavailable -> "serverUnavailable"
78
-
| Server_fail -> "serverFail"
79
-
| Server_partial_fail -> "serverPartialFail"
80
-
| Unknown_method -> "unknownMethod"
81
-
| Invalid_arguments -> "invalidArguments"
82
-
| Invalid_result_reference -> "invalidResultReference"
83
-
| Forbidden -> "forbidden"
84
-
| Account_not_found -> "accountNotFound"
85
-
| Account_not_supported_by_method -> "accountNotSupportedByMethod"
86
-
| Account_read_only -> "accountReadOnly"
87
-
| Other s -> s
88
-
89
-
let method_error_type_of_string = function
90
-
| "serverUnavailable" -> Server_unavailable
91
-
| "serverFail" -> Server_fail
92
-
| "serverPartialFail" -> Server_partial_fail
93
-
| "unknownMethod" -> Unknown_method
94
-
| "invalidArguments" -> Invalid_arguments
95
-
| "invalidResultReference" -> Invalid_result_reference
96
-
| "forbidden" -> Forbidden
97
-
| "accountNotFound" -> Account_not_found
98
-
| "accountNotSupportedByMethod" -> Account_not_supported_by_method
99
-
| "accountReadOnly" -> Account_read_only
100
-
| s -> Other s
101
-
102
-
let method_error_type_jsont =
103
-
let kind = "Method error type" in
104
-
Jsont.map ~kind
105
-
~dec:(fun s -> method_error_type_of_string s)
106
-
~enc:method_error_type_to_string
107
-
Jsont.string
108
-
109
-
type method_error = {
110
-
type_ : method_error_type;
111
-
description : string option;
112
-
}
113
-
114
-
let method_error_make type_ description = { type_; description }
115
-
let method_error_type_ t = t.type_
116
-
let method_error_description t = t.description
117
-
118
-
let method_error_jsont =
119
-
let kind = "Method error" in
120
-
Jsont.Object.map ~kind method_error_make
121
-
|> Jsont.Object.mem "type" method_error_type_jsont ~enc:method_error_type_
122
-
|> Jsont.Object.opt_mem "description" Jsont.string ~enc:method_error_description
123
-
|> Jsont.Object.finish
124
-
125
-
type set_error_type =
126
-
| Forbidden
127
-
| Over_quota
128
-
| Too_large
129
-
| Rate_limit
130
-
| Not_found
131
-
| Invalid_patch
132
-
| Will_destroy
133
-
| Invalid_properties
134
-
| Singleton
135
-
| Other of string
136
-
137
-
let set_error_type_to_string = function
138
-
| Forbidden -> "forbidden"
139
-
| Over_quota -> "overQuota"
140
-
| Too_large -> "tooLarge"
141
-
| Rate_limit -> "rateLimit"
142
-
| Not_found -> "notFound"
143
-
| Invalid_patch -> "invalidPatch"
144
-
| Will_destroy -> "willDestroy"
145
-
| Invalid_properties -> "invalidProperties"
146
-
| Singleton -> "singleton"
147
-
| Other s -> s
148
-
149
-
let set_error_type_of_string = function
150
-
| "forbidden" -> Forbidden
151
-
| "overQuota" -> Over_quota
152
-
| "tooLarge" -> Too_large
153
-
| "rateLimit" -> Rate_limit
154
-
| "notFound" -> Not_found
155
-
| "invalidPatch" -> Invalid_patch
156
-
| "willDestroy" -> Will_destroy
157
-
| "invalidProperties" -> Invalid_properties
158
-
| "singleton" -> Singleton
159
-
| s -> Other s
160
-
161
-
let set_error_type_jsont =
162
-
let kind = "SetError type" in
163
-
Jsont.map ~kind
164
-
~dec:(fun s -> set_error_type_of_string s)
165
-
~enc:set_error_type_to_string
166
-
Jsont.string
167
-
168
-
type set_error = {
169
-
type_ : set_error_type;
170
-
description : string option;
171
-
properties : string list option;
172
-
}
173
-
174
-
let set_error ?description ?properties type_ =
175
-
{ type_; description; properties }
176
-
177
-
let set_error_make type_ description properties =
178
-
{ type_; description; properties }
179
-
180
-
let set_error_type_ t = t.type_
181
-
let set_error_description t = t.description
182
-
let set_error_properties t = t.properties
183
-
184
-
let set_error_jsont =
185
-
let kind = "SetError" in
186
-
Jsont.Object.map ~kind set_error_make
187
-
|> Jsont.Object.mem "type" set_error_type_jsont ~enc:set_error_type_
188
-
|> Jsont.Object.opt_mem "description" Jsont.string ~enc:set_error_description
189
-
|> Jsont.Object.opt_mem "properties" (Jsont.list Jsont.string) ~enc:set_error_properties
190
-
|> Jsont.Object.finish
-146
proto/error.mli
-146
proto/error.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP error types as defined in RFC 8620 Section 3.6.1-3.6.2 *)
7
-
8
-
(** {1 Request-Level Errors}
9
-
10
-
These errors are returned with an HTTP error status code and a JSON
11
-
Problem Details body (RFC 7807). *)
12
-
13
-
(** Request-level error URNs *)
14
-
module Request_error : sig
15
-
type urn =
16
-
| Unknown_capability
17
-
(** urn:ietf:params:jmap:error:unknownCapability
18
-
The client included a capability in "using" that the server does not support. *)
19
-
| Not_json
20
-
(** urn:ietf:params:jmap:error:notJSON
21
-
The content type was not application/json or the request was not valid JSON. *)
22
-
| Not_request
23
-
(** urn:ietf:params:jmap:error:notRequest
24
-
The request was valid JSON but not a valid JMAP Request object. *)
25
-
| Limit
26
-
(** urn:ietf:params:jmap:error:limit
27
-
A server-defined limit was reached. *)
28
-
| Other of string
29
-
(** Other URN not in the standard set. *)
30
-
31
-
val urn_to_string : urn -> string
32
-
(** [urn_to_string urn] returns the URN string. *)
33
-
34
-
val urn_of_string : string -> urn
35
-
(** [urn_of_string s] parses a URN string. *)
36
-
37
-
type t = {
38
-
type_ : urn;
39
-
(** The error type URN. *)
40
-
status : int;
41
-
(** HTTP status code. *)
42
-
title : string option;
43
-
(** Short human-readable summary. *)
44
-
detail : string option;
45
-
(** Longer human-readable explanation. *)
46
-
limit : string option;
47
-
(** For "limit" errors, the name of the limit that was exceeded. *)
48
-
}
49
-
(** A request-level error per RFC 7807 Problem Details. *)
50
-
51
-
val jsont : t Jsont.t
52
-
(** JSON codec for request-level errors. *)
53
-
end
54
-
55
-
(** {1 Method-Level Errors}
56
-
57
-
These are returned as the second element of an Invocation tuple
58
-
when a method call fails. *)
59
-
60
-
(** Standard method error types per RFC 8620 Section 3.6.2 *)
61
-
type method_error_type =
62
-
| Server_unavailable
63
-
(** The server is temporarily unavailable. *)
64
-
| Server_fail
65
-
(** An unexpected error occurred. *)
66
-
| Server_partial_fail
67
-
(** Some, but not all, changes were successfully made. *)
68
-
| Unknown_method
69
-
(** The method name is not recognized. *)
70
-
| Invalid_arguments
71
-
(** One or more arguments are invalid. *)
72
-
| Invalid_result_reference
73
-
(** A result reference could not be resolved. *)
74
-
| Forbidden
75
-
(** The method/arguments are valid but forbidden. *)
76
-
| Account_not_found
77
-
(** The accountId does not correspond to a valid account. *)
78
-
| Account_not_supported_by_method
79
-
(** The account does not support this method. *)
80
-
| Account_read_only
81
-
(** The account is read-only. *)
82
-
| Other of string
83
-
(** Other error type not in the standard set. *)
84
-
85
-
val method_error_type_to_string : method_error_type -> string
86
-
(** [method_error_type_to_string t] returns the type string. *)
87
-
88
-
val method_error_type_of_string : string -> method_error_type
89
-
(** [method_error_type_of_string s] parses a type string. *)
90
-
91
-
(** A method-level error response. *)
92
-
type method_error = {
93
-
type_ : method_error_type;
94
-
(** The error type. *)
95
-
description : string option;
96
-
(** Human-readable description of the error. *)
97
-
}
98
-
99
-
val method_error_jsont : method_error Jsont.t
100
-
(** JSON codec for method errors. *)
101
-
102
-
(** {1 SetError}
103
-
104
-
Errors returned in notCreated/notUpdated/notDestroyed responses. *)
105
-
106
-
(** Standard SetError types per RFC 8620 Section 5.3 *)
107
-
type set_error_type =
108
-
| Forbidden
109
-
(** The operation is not permitted. *)
110
-
| Over_quota
111
-
(** The maximum server quota has been reached. *)
112
-
| Too_large
113
-
(** The object is too large. *)
114
-
| Rate_limit
115
-
(** Too many objects of this type have been created recently. *)
116
-
| Not_found
117
-
(** The id does not exist (for update/destroy). *)
118
-
| Invalid_patch
119
-
(** The PatchObject is invalid. *)
120
-
| Will_destroy
121
-
(** The object will be destroyed by another operation in the request. *)
122
-
| Invalid_properties
123
-
(** Some properties were invalid. *)
124
-
| Singleton
125
-
(** Only one object of this type can exist (for create). *)
126
-
| Other of string
127
-
(** Other error type. *)
128
-
129
-
val set_error_type_to_string : set_error_type -> string
130
-
val set_error_type_of_string : string -> set_error_type
131
-
132
-
(** A SetError object. *)
133
-
type set_error = {
134
-
type_ : set_error_type;
135
-
(** The error type. *)
136
-
description : string option;
137
-
(** Human-readable description. *)
138
-
properties : string list option;
139
-
(** For invalidProperties errors, the list of invalid property names. *)
140
-
}
141
-
142
-
val set_error : ?description:string -> ?properties:string list -> set_error_type -> set_error
143
-
(** [set_error ?description ?properties type_] creates a SetError. *)
144
-
145
-
val set_error_jsont : set_error Jsont.t
146
-
(** JSON codec for SetError. *)
-123
proto/filter.ml
-123
proto/filter.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type operator = And | Or | Not
7
-
8
-
let operator_to_string = function
9
-
| And -> "AND"
10
-
| Or -> "OR"
11
-
| Not -> "NOT"
12
-
13
-
let operator_of_string = function
14
-
| "AND" -> And
15
-
| "OR" -> Or
16
-
| "NOT" -> Not
17
-
| s -> Jsont.Error.msgf Jsont.Meta.none "Unknown filter operator: %s" s
18
-
19
-
let operator_jsont =
20
-
let kind = "Filter operator" in
21
-
Jsont.map ~kind
22
-
~dec:(fun s -> operator_of_string s)
23
-
~enc:operator_to_string
24
-
Jsont.string
25
-
26
-
type 'condition filter_operator = {
27
-
operator : operator;
28
-
conditions : 'condition filter list;
29
-
}
30
-
31
-
and 'condition filter =
32
-
| Operator of 'condition filter_operator
33
-
| Condition of 'condition
34
-
35
-
let filter_jsont (type c) (condition_jsont : c Jsont.t) : c filter Jsont.t =
36
-
let kind = "Filter" in
37
-
(* Create a recursive codec using Jsont.rec' *)
38
-
let rec make_filter_jsont () =
39
-
let lazy_self = lazy (make_filter_jsont ()) in
40
-
(* Filter operator codec *)
41
-
let filter_operator_jsont =
42
-
let make operator conditions = { operator; conditions } in
43
-
Jsont.Object.map ~kind:"FilterOperator" make
44
-
|> Jsont.Object.mem "operator" operator_jsont ~enc:(fun o -> o.operator)
45
-
|> Jsont.Object.mem "conditions"
46
-
(Jsont.list (Jsont.rec' lazy_self))
47
-
~enc:(fun o -> o.conditions)
48
-
|> Jsont.Object.finish
49
-
in
50
-
(* Decode function: check for "operator" field to determine type *)
51
-
let dec json =
52
-
match json with
53
-
| Jsont.Object (members, _) ->
54
-
(* members has type (name * json) list where name = string * Meta.t *)
55
-
if List.exists (fun ((k, _), _) -> k = "operator") members then begin
56
-
(* It's an operator *)
57
-
match Jsont.Json.decode' filter_operator_jsont json with
58
-
| Ok op -> Operator op
59
-
| Error e -> raise (Jsont.Error e)
60
-
end else begin
61
-
(* It's a condition *)
62
-
match Jsont.Json.decode' condition_jsont json with
63
-
| Ok c -> Condition c
64
-
| Error e -> raise (Jsont.Error e)
65
-
end
66
-
| Jsont.Null _ | Jsont.Bool _ | Jsont.Number _ | Jsont.String _ | Jsont.Array _ ->
67
-
Jsont.Error.msg Jsont.Meta.none "Filter must be an object"
68
-
in
69
-
(* Encode function *)
70
-
let enc = function
71
-
| Operator op ->
72
-
(match Jsont.Json.encode' filter_operator_jsont op with
73
-
| Ok j -> j
74
-
| Error e -> raise (Jsont.Error e))
75
-
| Condition c ->
76
-
(match Jsont.Json.encode' condition_jsont c with
77
-
| Ok j -> j
78
-
| Error e -> raise (Jsont.Error e))
79
-
in
80
-
Jsont.map ~kind ~dec ~enc Jsont.json
81
-
in
82
-
make_filter_jsont ()
83
-
84
-
type comparator = {
85
-
property : string;
86
-
is_ascending : bool;
87
-
collation : string option;
88
-
}
89
-
90
-
let comparator ?(is_ascending = true) ?collation property =
91
-
{ property; is_ascending; collation }
92
-
93
-
let comparator_property c = c.property
94
-
let comparator_is_ascending c = c.is_ascending
95
-
let comparator_collation c = c.collation
96
-
97
-
let comparator_make property is_ascending collation =
98
-
{ property; is_ascending; collation }
99
-
100
-
let comparator_jsont =
101
-
let kind = "Comparator" in
102
-
Jsont.Object.map ~kind comparator_make
103
-
|> Jsont.Object.mem "property" Jsont.string ~enc:comparator_property
104
-
|> Jsont.Object.mem "isAscending" Jsont.bool ~dec_absent:true ~enc:comparator_is_ascending
105
-
~enc_omit:(fun b -> b = true)
106
-
|> Jsont.Object.opt_mem "collation" Jsont.string ~enc:comparator_collation
107
-
|> Jsont.Object.finish
108
-
109
-
type added_item = {
110
-
id : Id.t;
111
-
index : int64;
112
-
}
113
-
114
-
let added_item_make id index = { id; index }
115
-
let added_item_id a = a.id
116
-
let added_item_index a = a.index
117
-
118
-
let added_item_jsont =
119
-
let kind = "AddedItem" in
120
-
Jsont.Object.map ~kind added_item_make
121
-
|> Jsont.Object.mem "id" Id.jsont ~enc:added_item_id
122
-
|> Jsont.Object.mem "index" Int53.Unsigned.jsont ~enc:added_item_index
123
-
|> Jsont.Object.finish
-73
proto/filter.mli
-73
proto/filter.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP filter and sort types as defined in RFC 8620 Section 5.5 *)
7
-
8
-
(** {1 Filter Operators} *)
9
-
10
-
(** Filter operator types. *)
11
-
type operator =
12
-
| And (** All conditions must match *)
13
-
| Or (** At least one condition must match *)
14
-
| Not (** Inverts a single condition *)
15
-
16
-
val operator_jsont : operator Jsont.t
17
-
(** JSON codec for filter operators. *)
18
-
19
-
(** A filter operator that combines conditions.
20
-
21
-
When decoding, the filter determines whether a JSON object is an
22
-
operator (has "operator" field) or a condition. *)
23
-
type 'condition filter_operator = {
24
-
operator : operator;
25
-
conditions : 'condition filter list;
26
-
}
27
-
28
-
(** A filter is either an operator combining filters, or a leaf condition. *)
29
-
and 'condition filter =
30
-
| Operator of 'condition filter_operator
31
-
| Condition of 'condition
32
-
33
-
val filter_jsont : 'c Jsont.t -> 'c filter Jsont.t
34
-
(** [filter_jsont condition_jsont] creates a codec for filters with the
35
-
given condition type. The codec automatically distinguishes operators
36
-
from conditions by the presence of the "operator" field. *)
37
-
38
-
(** {1 Comparators} *)
39
-
40
-
(** A comparator for sorting query results. *)
41
-
type comparator = {
42
-
property : string;
43
-
(** The property to sort by. *)
44
-
is_ascending : bool;
45
-
(** [true] for ascending order (default), [false] for descending. *)
46
-
collation : string option;
47
-
(** Optional collation algorithm for string comparison. *)
48
-
}
49
-
50
-
val comparator :
51
-
?is_ascending:bool ->
52
-
?collation:string ->
53
-
string ->
54
-
comparator
55
-
(** [comparator ?is_ascending ?collation property] creates a comparator.
56
-
[is_ascending] defaults to [true]. *)
57
-
58
-
val comparator_property : comparator -> string
59
-
val comparator_is_ascending : comparator -> bool
60
-
val comparator_collation : comparator -> string option
61
-
62
-
val comparator_jsont : comparator Jsont.t
63
-
(** JSON codec for comparators. *)
64
-
65
-
(** {1 Position Information} *)
66
-
67
-
(** Added entry position in query change results. *)
68
-
type added_item = {
69
-
id : Id.t;
70
-
index : int64;
71
-
}
72
-
73
-
val added_item_jsont : added_item Jsont.t
-51
proto/id.ml
-51
proto/id.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP identifier type as defined in RFC 8620 Section 1.2.
7
-
8
-
An Id is a string of 1-255 octets from the URL-safe base64 alphabet. *)
9
-
10
-
type t = string
11
-
12
-
(* Valid characters: A-Za-z0-9_- (URL-safe base64 alphabet) *)
13
-
let is_valid_char c =
14
-
(c >= 'A' && c <= 'Z') ||
15
-
(c >= 'a' && c <= 'z') ||
16
-
(c >= '0' && c <= '9') ||
17
-
c = '_' || c = '-'
18
-
19
-
let validate s =
20
-
let len = String.length s in
21
-
if len = 0 then Error "Id cannot be empty"
22
-
else if len > 255 then Error "Id cannot exceed 255 characters"
23
-
else
24
-
let rec check i =
25
-
if i >= len then Ok s
26
-
else if is_valid_char s.[i] then check (i + 1)
27
-
else Error (Printf.sprintf "Invalid character '%c' in Id at position %d" s.[i] i)
28
-
in
29
-
check 0
30
-
31
-
let of_string = validate
32
-
33
-
let of_string_exn s =
34
-
match validate s with
35
-
| Ok id -> id
36
-
| Error msg -> invalid_arg msg
37
-
38
-
let to_string t = t
39
-
let equal = String.equal
40
-
let compare = String.compare
41
-
let pp ppf t = Format.pp_print_string ppf t
42
-
43
-
let jsont =
44
-
let kind = "Id" in
45
-
let dec s =
46
-
match validate s with
47
-
| Ok id -> id
48
-
| Error msg -> Jsont.Error.msgf Jsont.Meta.none "%s: %s" kind msg
49
-
in
50
-
let enc t = t in
51
-
Jsont.map ~kind ~dec ~enc Jsont.string
-38
proto/id.mli
-38
proto/id.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP identifier type.
7
-
8
-
An Id is a string of 1-255 octets from the URL-safe base64 alphabet
9
-
(A-Za-z0-9_-), plus the ASCII alphanumeric characters.
10
-
11
-
See {{:https://datatracker.ietf.org/doc/html/rfc8620#section-1.2} RFC 8620 Section 1.2}. *)
12
-
13
-
type t
14
-
(** The type of JMAP identifiers. *)
15
-
16
-
val of_string : string -> (t, string) result
17
-
(** [of_string s] creates an Id from string [s].
18
-
Returns [Error msg] if [s] is empty, longer than 255 characters,
19
-
or contains invalid characters. *)
20
-
21
-
val of_string_exn : string -> t
22
-
(** [of_string_exn s] creates an Id from string [s].
23
-
@raise Invalid_argument if the string is invalid. *)
24
-
25
-
val to_string : t -> string
26
-
(** [to_string id] returns the string representation of [id]. *)
27
-
28
-
val equal : t -> t -> bool
29
-
(** [equal a b] tests equality of identifiers. *)
30
-
31
-
val compare : t -> t -> int
32
-
(** [compare a b] compares two identifiers. *)
33
-
34
-
val pp : Format.formatter -> t -> unit
35
-
(** [pp ppf id] pretty-prints [id] to [ppf]. *)
36
-
37
-
val jsont : t Jsont.t
38
-
(** JSON codec for JMAP identifiers. *)
-67
proto/int53.ml
-67
proto/int53.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JavaScript-safe integer types for JSON.
7
-
8
-
These types represent integers that can be safely represented in JavaScript's
9
-
IEEE 754 double-precision floating point format without loss of precision. *)
10
-
11
-
(** 53-bit signed integer with range -2^53+1 to 2^53-1 *)
12
-
module Signed = struct
13
-
type t = int64
14
-
15
-
(* 2^53 - 1 *)
16
-
let max_value = 9007199254740991L
17
-
(* -(2^53 - 1) *)
18
-
let min_value = -9007199254740991L
19
-
20
-
let of_int n = Int64.of_int n
21
-
22
-
let to_int n =
23
-
if n >= Int64.of_int min_int && n <= Int64.of_int max_int then
24
-
Some (Int64.to_int n)
25
-
else
26
-
None
27
-
28
-
let of_int64 n =
29
-
if n >= min_value && n <= max_value then Ok n
30
-
else Error (Printf.sprintf "Int53 out of range: %Ld" n)
31
-
32
-
let jsont =
33
-
let kind = "Int53" in
34
-
let dec f =
35
-
let n = Int64.of_float f in
36
-
if n >= min_value && n <= max_value then n
37
-
else Jsont.Error.msgf Jsont.Meta.none "%s: value %Ld out of safe integer range" kind n
38
-
in
39
-
let enc n = Int64.to_float n in
40
-
Jsont.map ~kind ~dec ~enc Jsont.number
41
-
end
42
-
43
-
(** 53-bit unsigned integer with range 0 to 2^53-1 *)
44
-
module Unsigned = struct
45
-
type t = int64
46
-
47
-
let min_value = 0L
48
-
let max_value = 9007199254740991L
49
-
50
-
let of_int n =
51
-
if n >= 0 then Ok (Int64.of_int n)
52
-
else Error "UnsignedInt53 cannot be negative"
53
-
54
-
let of_int64 n =
55
-
if n >= min_value && n <= max_value then Ok n
56
-
else Error (Printf.sprintf "UnsignedInt53 out of range: %Ld" n)
57
-
58
-
let jsont =
59
-
let kind = "UnsignedInt53" in
60
-
let dec f =
61
-
let n = Int64.of_float f in
62
-
if n >= min_value && n <= max_value then n
63
-
else Jsont.Error.msgf Jsont.Meta.none "%s: value %Ld out of range [0, 2^53-1]" kind n
64
-
in
65
-
let enc n = Int64.to_float n in
66
-
Jsont.map ~kind ~dec ~enc Jsont.number
67
-
end
-62
proto/int53.mli
-62
proto/int53.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JavaScript-safe integer types for JSON.
7
-
8
-
These types represent integers that can be safely represented in JavaScript's
9
-
IEEE 754 double-precision floating point format without loss of precision.
10
-
The safe range is -2^53+1 to 2^53-1.
11
-
12
-
See {{:https://datatracker.ietf.org/doc/html/rfc8620#section-1.3} RFC 8620 Section 1.3}. *)
13
-
14
-
(** 53-bit signed integer.
15
-
16
-
The range is -2^53+1 to 2^53-1, which is the safe integer range
17
-
for JavaScript/JSON numbers. *)
18
-
module Signed : sig
19
-
type t = int64
20
-
(** The type of 53-bit signed integers. *)
21
-
22
-
val min_value : t
23
-
(** Minimum value: -9007199254740991 (-2^53+1) *)
24
-
25
-
val max_value : t
26
-
(** Maximum value: 9007199254740991 (2^53-1) *)
27
-
28
-
val of_int : int -> t
29
-
(** [of_int n] converts an OCaml int to Int53. *)
30
-
31
-
val to_int : t -> int option
32
-
(** [to_int n] converts to OCaml int if it fits. *)
33
-
34
-
val of_int64 : int64 -> (t, string) result
35
-
(** [of_int64 n] validates that [n] is in the safe range. *)
36
-
37
-
val jsont : t Jsont.t
38
-
(** JSON codec for 53-bit integers. Encoded as JSON number. *)
39
-
end
40
-
41
-
(** 53-bit unsigned integer.
42
-
43
-
The range is 0 to 2^53-1. *)
44
-
module Unsigned : sig
45
-
type t = int64
46
-
(** The type of 53-bit unsigned integers. *)
47
-
48
-
val min_value : t
49
-
(** Minimum value: 0 *)
50
-
51
-
val max_value : t
52
-
(** Maximum value: 9007199254740991 (2^53-1) *)
53
-
54
-
val of_int : int -> (t, string) result
55
-
(** [of_int n] converts an OCaml int to UnsignedInt53. *)
56
-
57
-
val of_int64 : int64 -> (t, string) result
58
-
(** [of_int64 n] validates that [n] is in the valid range. *)
59
-
60
-
val jsont : t Jsont.t
61
-
(** JSON codec for 53-bit unsigned integers. *)
62
-
end
-113
proto/invocation.ml
-113
proto/invocation.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type result_reference = {
7
-
result_of : string;
8
-
name : string;
9
-
path : Json_pointer.Jmap.t;
10
-
}
11
-
12
-
let result_reference ~result_of ~name ~path =
13
-
{ result_of; name; path }
14
-
15
-
let result_reference_of_strings ~result_of ~name ~path =
16
-
{ result_of; name; path = Json_pointer.Jmap.of_string path }
17
-
18
-
let result_reference_make result_of name path =
19
-
{ result_of; name; path }
20
-
21
-
let result_reference_jsont =
22
-
let kind = "ResultReference" in
23
-
Jsont.Object.map ~kind result_reference_make
24
-
|> Jsont.Object.mem "resultOf" Jsont.string ~enc:(fun r -> r.result_of)
25
-
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun r -> r.name)
26
-
|> Jsont.Object.mem "path" Json_pointer.Jmap.jsont ~enc:(fun r -> r.path)
27
-
|> Jsont.Object.finish
28
-
29
-
(* Result reference resolution *)
30
-
31
-
let find_response ref ~responses =
32
-
List.find_map (fun (call_id, name, json) ->
33
-
if call_id = ref.result_of && name = ref.name
34
-
then Some json
35
-
else None
36
-
) responses
37
-
38
-
let resolve ref ~responses codec =
39
-
match find_response ref ~responses with
40
-
| None ->
41
-
Jsont.Error.msgf Jsont.Meta.none
42
-
"Result reference: no response found for resultOf=%s name=%s"
43
-
ref.result_of ref.name
44
-
| Some json ->
45
-
let extraction_codec = Json_pointer.Jmap.path ref.path codec in
46
-
match Jsont.Json.decode' extraction_codec json with
47
-
| Ok v -> v
48
-
| Error e -> raise (Jsont.Error e)
49
-
50
-
let resolve_ids ref ~responses =
51
-
resolve ref ~responses (Jsont.list Jsont.string)
52
-
53
-
type t = {
54
-
name : string;
55
-
arguments : Jsont.json;
56
-
method_call_id : string;
57
-
}
58
-
59
-
let create ~name ~arguments ~method_call_id =
60
-
{ name; arguments; method_call_id }
61
-
62
-
let name t = t.name
63
-
let arguments t = t.arguments
64
-
let method_call_id t = t.method_call_id
65
-
66
-
(* Helper to encode a typed value back to Jsont.json *)
67
-
let encode_json_value jsont value =
68
-
match Jsont.Json.encode' jsont value with
69
-
| Ok json -> json
70
-
| Error _ -> Jsont.Object ([], Jsont.Meta.none)
71
-
72
-
let jsont =
73
-
let kind = "Invocation" in
74
-
(* Invocation is [name, args, callId] - a 3-element heterogeneous array *)
75
-
(* We need to handle this as a json array since elements have different types *)
76
-
let dec json =
77
-
match json with
78
-
| Jsont.Array ([name_json; arguments; call_id_json], _) ->
79
-
let name = match name_json with
80
-
| Jsont.String (s, _) -> s
81
-
| _ -> Jsont.Error.msg Jsont.Meta.none "Invocation[0] must be a string"
82
-
in
83
-
let method_call_id = match call_id_json with
84
-
| Jsont.String (s, _) -> s
85
-
| _ -> Jsont.Error.msg Jsont.Meta.none "Invocation[2] must be a string"
86
-
in
87
-
{ name; arguments; method_call_id }
88
-
| Jsont.Array _ ->
89
-
Jsont.Error.msg Jsont.Meta.none "Invocation must be a 3-element array"
90
-
| _ ->
91
-
Jsont.Error.msg Jsont.Meta.none "Invocation must be an array"
92
-
in
93
-
let enc t =
94
-
Jsont.Array ([
95
-
Jsont.String (t.name, Jsont.Meta.none);
96
-
t.arguments;
97
-
Jsont.String (t.method_call_id, Jsont.Meta.none);
98
-
], Jsont.Meta.none)
99
-
in
100
-
Jsont.map ~kind ~dec ~enc Jsont.json
101
-
102
-
let make_get ~method_call_id ~method_name args =
103
-
let arguments = encode_json_value Method_.get_args_jsont args in
104
-
{ name = method_name; arguments; method_call_id }
105
-
106
-
let make_changes ~method_call_id ~method_name args =
107
-
let arguments = encode_json_value Method_.changes_args_jsont args in
108
-
{ name = method_name; arguments; method_call_id }
109
-
110
-
let make_query (type f) ~method_call_id ~method_name
111
-
~(filter_cond_jsont : f Jsont.t) (args : f Method_.query_args) =
112
-
let arguments = encode_json_value (Method_.query_args_jsont filter_cond_jsont) args in
113
-
{ name = method_name; arguments; method_call_id }
-123
proto/invocation.mli
-123
proto/invocation.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP method invocation as defined in RFC 8620 Section 3.2 *)
7
-
8
-
(** {1 Result References} *)
9
-
10
-
(** A reference to a result from a previous method call.
11
-
12
-
Used for back-referencing values within a single request.
13
-
The path is a JMAP extended JSON Pointer (RFC 8620 Section 3.7)
14
-
which may contain [*] wildcards for array mapping. *)
15
-
type result_reference = {
16
-
result_of : string;
17
-
(** The method call id to reference. *)
18
-
name : string;
19
-
(** The method name that was called. *)
20
-
path : Json_pointer.Jmap.t;
21
-
(** A JMAP extended JSON Pointer to the value within the result.
22
-
May contain [*] wildcards for mapping through arrays. *)
23
-
}
24
-
25
-
val result_reference :
26
-
result_of:string ->
27
-
name:string ->
28
-
path:Json_pointer.Jmap.t ->
29
-
result_reference
30
-
31
-
val result_reference_of_strings :
32
-
result_of:string ->
33
-
name:string ->
34
-
path:string ->
35
-
result_reference
36
-
(** [result_reference_of_strings] creates a result reference, parsing
37
-
the path string into a JMAP pointer.
38
-
@raise Jsont.Error if the path is not a valid JMAP pointer. *)
39
-
40
-
val result_reference_jsont : result_reference Jsont.t
41
-
42
-
(** {2 Typed Extraction}
43
-
44
-
These functions extract typed values from method responses using
45
-
the result reference's path. *)
46
-
47
-
val resolve_ids :
48
-
result_reference ->
49
-
responses:(string * string * Jsont.json) list ->
50
-
string list
51
-
(** [resolve_ids ref ~responses] resolves the result reference against
52
-
the list of previous responses and extracts a list of string IDs.
53
-
54
-
[responses] is a list of [(method_call_id, method_name, result_json)]
55
-
tuples from previously executed method calls.
56
-
57
-
This is the most common pattern in JMAP where result references are
58
-
used to pass IDs between method calls.
59
-
60
-
@raise Jsont.Error if resolution fails or the result is not a string list. *)
61
-
62
-
val resolve :
63
-
result_reference ->
64
-
responses:(string * string * Jsont.json) list ->
65
-
'a Jsont.t ->
66
-
'a
67
-
(** [resolve ref ~responses codec] resolves the result reference and
68
-
decodes the extracted value with [codec].
69
-
70
-
@raise Jsont.Error if resolution fails or decoding fails. *)
71
-
72
-
(** {1 Invocations} *)
73
-
74
-
(** A method invocation.
75
-
76
-
In JSON, this is represented as a 3-element array:
77
-
["methodName", {args}, "methodCallId"] *)
78
-
type t = {
79
-
name : string;
80
-
(** The method name, e.g., "Email/get". *)
81
-
arguments : Jsont.json;
82
-
(** The method arguments as a JSON object. *)
83
-
method_call_id : string;
84
-
(** Client-specified identifier for this call. *)
85
-
}
86
-
87
-
val create :
88
-
name:string ->
89
-
arguments:Jsont.json ->
90
-
method_call_id:string ->
91
-
t
92
-
(** [create ~name ~arguments ~method_call_id] creates an invocation. *)
93
-
94
-
val name : t -> string
95
-
val arguments : t -> Jsont.json
96
-
val method_call_id : t -> string
97
-
98
-
val jsont : t Jsont.t
99
-
(** JSON codec for invocations (as 3-element array). *)
100
-
101
-
(** {1 Typed Invocation Helpers} *)
102
-
103
-
val make_get :
104
-
method_call_id:string ->
105
-
method_name:string ->
106
-
Method_.get_args ->
107
-
t
108
-
(** [make_get ~method_call_id ~method_name args] creates a /get invocation. *)
109
-
110
-
val make_changes :
111
-
method_call_id:string ->
112
-
method_name:string ->
113
-
Method_.changes_args ->
114
-
t
115
-
(** [make_changes ~method_call_id ~method_name args] creates a /changes invocation. *)
116
-
117
-
val make_query :
118
-
method_call_id:string ->
119
-
method_name:string ->
120
-
filter_cond_jsont:'f Jsont.t ->
121
-
'f Method_.query_args ->
122
-
t
123
-
(** [make_query ~method_call_id ~method_name ~filter_cond_jsont args] creates a /query invocation. *)
-24
proto/jmap_proto.ml
-24
proto/jmap_proto.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP Protocol Types (RFC 8620)
7
-
8
-
This module re-exports all JMAP core protocol types. *)
9
-
10
-
module Id = Id
11
-
module Int53 = Int53
12
-
module Date = Date
13
-
module Json_map = Json_map
14
-
module Unknown = Unknown
15
-
module Error = Error
16
-
module Capability = Capability
17
-
module Filter = Filter
18
-
module Method = Method_
19
-
module Invocation = Invocation
20
-
module Request = Request
21
-
module Response = Response
22
-
module Session = Session
23
-
module Push = Push
24
-
module Blob = Blob
-40
proto/json_map.ml
-40
proto/json_map.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JSON object-as-map codec utilities.
7
-
8
-
JMAP frequently uses JSON objects as maps with string or Id keys.
9
-
These codecs convert between JSON objects and OCaml association lists. *)
10
-
11
-
module String_map = Map.Make(String)
12
-
13
-
let of_string value_jsont =
14
-
let kind = "String map" in
15
-
Jsont.Object.map ~kind Fun.id
16
-
|> Jsont.Object.keep_unknown (Jsont.Object.Mems.string_map value_jsont) ~enc:Fun.id
17
-
|> Jsont.Object.finish
18
-
|> Jsont.map
19
-
~dec:(fun m -> List.of_seq (String_map.to_seq m))
20
-
~enc:(fun l -> String_map.of_list l)
21
-
22
-
let of_id value_jsont =
23
-
let kind = "Id map" in
24
-
(* Use string map internally, then convert keys to Ids *)
25
-
let string_codec = of_string value_jsont in
26
-
let dec pairs =
27
-
List.map (fun (k, v) ->
28
-
match Id.of_string k with
29
-
| Ok id -> (id, v)
30
-
| Error msg -> Jsont.Error.msgf Jsont.Meta.none "%s: invalid key %s - %s" kind k msg
31
-
) pairs
32
-
in
33
-
let enc pairs =
34
-
List.map (fun (id, v) -> (Id.to_string id, v)) pairs
35
-
in
36
-
Jsont.map ~kind ~dec ~enc string_codec
37
-
38
-
let id_to_bool = of_id Jsont.bool
39
-
40
-
let string_to_bool = of_string Jsont.bool
-23
proto/json_map.mli
-23
proto/json_map.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JSON object-as-map codec utilities.
7
-
8
-
JMAP frequently uses JSON objects as maps with string or Id keys.
9
-
These codecs convert between JSON objects and OCaml association lists. *)
10
-
11
-
val of_string : 'a Jsont.t -> (string * 'a) list Jsont.t
12
-
(** [of_string value_jsont] creates a codec for JSON objects
13
-
used as string-keyed maps. Returns an association list. *)
14
-
15
-
val of_id : 'a Jsont.t -> (Id.t * 'a) list Jsont.t
16
-
(** [of_id value_jsont] creates a codec for JSON objects
17
-
keyed by JMAP identifiers. *)
18
-
19
-
val id_to_bool : (Id.t * bool) list Jsont.t
20
-
(** Codec for Id[Boolean] maps, common in JMAP (e.g., mailboxIds, keywords). *)
21
-
22
-
val string_to_bool : (string * bool) list Jsont.t
23
-
(** Codec for String[Boolean] maps. *)
-17
proto/mail/dune
-17
proto/mail/dune
-216
proto/mail/email.ml
-216
proto/mail/email.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
module Keyword = struct
7
-
let draft = "$draft"
8
-
let seen = "$seen"
9
-
let flagged = "$flagged"
10
-
let answered = "$answered"
11
-
let forwarded = "$forwarded"
12
-
let phishing = "$phishing"
13
-
let junk = "$junk"
14
-
let not_junk = "$notjunk"
15
-
end
16
-
17
-
type t = {
18
-
id : Jmap_proto.Id.t;
19
-
blob_id : Jmap_proto.Id.t;
20
-
thread_id : Jmap_proto.Id.t;
21
-
size : int64;
22
-
received_at : Ptime.t;
23
-
mailbox_ids : (Jmap_proto.Id.t * bool) list;
24
-
keywords : (string * bool) list;
25
-
message_id : string list option;
26
-
in_reply_to : string list option;
27
-
references : string list option;
28
-
sender : Email_address.t list option;
29
-
from : Email_address.t list option;
30
-
to_ : Email_address.t list option;
31
-
cc : Email_address.t list option;
32
-
bcc : Email_address.t list option;
33
-
reply_to : Email_address.t list option;
34
-
subject : string option;
35
-
sent_at : Ptime.t option;
36
-
headers : Email_header.t list option;
37
-
body_structure : Email_body.Part.t option;
38
-
body_values : (string * Email_body.Value.t) list option;
39
-
text_body : Email_body.Part.t list option;
40
-
html_body : Email_body.Part.t list option;
41
-
attachments : Email_body.Part.t list option;
42
-
has_attachment : bool;
43
-
preview : string;
44
-
}
45
-
46
-
let id t = t.id
47
-
let blob_id t = t.blob_id
48
-
let thread_id t = t.thread_id
49
-
let size t = t.size
50
-
let received_at t = t.received_at
51
-
let mailbox_ids t = t.mailbox_ids
52
-
let keywords t = t.keywords
53
-
let message_id t = t.message_id
54
-
let in_reply_to t = t.in_reply_to
55
-
let references t = t.references
56
-
let sender t = t.sender
57
-
let from t = t.from
58
-
let to_ t = t.to_
59
-
let cc t = t.cc
60
-
let bcc t = t.bcc
61
-
let reply_to t = t.reply_to
62
-
let subject t = t.subject
63
-
let sent_at t = t.sent_at
64
-
let headers t = t.headers
65
-
let body_structure t = t.body_structure
66
-
let body_values t = t.body_values
67
-
let text_body t = t.text_body
68
-
let html_body t = t.html_body
69
-
let attachments t = t.attachments
70
-
let has_attachment t = t.has_attachment
71
-
let preview t = t.preview
72
-
73
-
let make id blob_id thread_id size received_at mailbox_ids keywords
74
-
message_id in_reply_to references sender from to_ cc bcc reply_to
75
-
subject sent_at headers body_structure body_values text_body html_body
76
-
attachments has_attachment preview =
77
-
{ id; blob_id; thread_id; size; received_at; mailbox_ids; keywords;
78
-
message_id; in_reply_to; references; sender; from; to_; cc; bcc;
79
-
reply_to; subject; sent_at; headers; body_structure; body_values;
80
-
text_body; html_body; attachments; has_attachment; preview }
81
-
82
-
let jsont =
83
-
let kind = "Email" in
84
-
let body_values_jsont = Jmap_proto.Json_map.of_string Email_body.Value.jsont in
85
-
Jsont.Object.map ~kind make
86
-
|> Jsont.Object.mem "id" Jmap_proto.Id.jsont ~enc:id
87
-
|> Jsont.Object.mem "blobId" Jmap_proto.Id.jsont ~enc:blob_id
88
-
|> Jsont.Object.mem "threadId" Jmap_proto.Id.jsont ~enc:thread_id
89
-
|> Jsont.Object.mem "size" Jmap_proto.Int53.Unsigned.jsont ~enc:size
90
-
|> Jsont.Object.mem "receivedAt" Jmap_proto.Date.Utc.jsont ~enc:received_at
91
-
|> Jsont.Object.mem "mailboxIds" Jmap_proto.Json_map.id_to_bool ~enc:mailbox_ids
92
-
|> Jsont.Object.mem "keywords" Jmap_proto.Json_map.string_to_bool ~dec_absent:[] ~enc:keywords
93
-
|> Jsont.Object.opt_mem "messageId" (Jsont.list Jsont.string) ~enc:message_id
94
-
|> Jsont.Object.opt_mem "inReplyTo" (Jsont.list Jsont.string) ~enc:in_reply_to
95
-
|> Jsont.Object.opt_mem "references" (Jsont.list Jsont.string) ~enc:references
96
-
|> Jsont.Object.opt_mem "sender" (Jsont.list Email_address.jsont) ~enc:sender
97
-
|> Jsont.Object.opt_mem "from" (Jsont.list Email_address.jsont) ~enc:from
98
-
|> Jsont.Object.opt_mem "to" (Jsont.list Email_address.jsont) ~enc:to_
99
-
|> Jsont.Object.opt_mem "cc" (Jsont.list Email_address.jsont) ~enc:cc
100
-
|> Jsont.Object.opt_mem "bcc" (Jsont.list Email_address.jsont) ~enc:bcc
101
-
|> Jsont.Object.opt_mem "replyTo" (Jsont.list Email_address.jsont) ~enc:reply_to
102
-
|> Jsont.Object.opt_mem "subject" Jsont.string ~enc:subject
103
-
|> Jsont.Object.opt_mem "sentAt" Jmap_proto.Date.Rfc3339.jsont ~enc:sent_at
104
-
|> Jsont.Object.opt_mem "headers" (Jsont.list Email_header.jsont) ~enc:headers
105
-
|> Jsont.Object.opt_mem "bodyStructure" Email_body.Part.jsont ~enc:body_structure
106
-
|> Jsont.Object.opt_mem "bodyValues" body_values_jsont ~enc:body_values
107
-
|> Jsont.Object.opt_mem "textBody" (Jsont.list Email_body.Part.jsont) ~enc:text_body
108
-
|> Jsont.Object.opt_mem "htmlBody" (Jsont.list Email_body.Part.jsont) ~enc:html_body
109
-
|> Jsont.Object.opt_mem "attachments" (Jsont.list Email_body.Part.jsont) ~enc:attachments
110
-
|> Jsont.Object.mem "hasAttachment" Jsont.bool ~dec_absent:false ~enc:has_attachment
111
-
|> Jsont.Object.mem "preview" Jsont.string ~dec_absent:"" ~enc:preview
112
-
|> Jsont.Object.finish
113
-
114
-
module Filter_condition = struct
115
-
type t = {
116
-
in_mailbox : Jmap_proto.Id.t option;
117
-
in_mailbox_other_than : Jmap_proto.Id.t list option;
118
-
before : Ptime.t option;
119
-
after : Ptime.t option;
120
-
min_size : int64 option;
121
-
max_size : int64 option;
122
-
all_in_thread_have_keyword : string option;
123
-
some_in_thread_have_keyword : string option;
124
-
none_in_thread_have_keyword : string option;
125
-
has_keyword : string option;
126
-
not_keyword : string option;
127
-
has_attachment : bool option;
128
-
text : string option;
129
-
from : string option;
130
-
to_ : string option;
131
-
cc : string option;
132
-
bcc : string option;
133
-
subject : string option;
134
-
body : string option;
135
-
header : (string * string option) option;
136
-
}
137
-
138
-
let make in_mailbox in_mailbox_other_than before after min_size max_size
139
-
all_in_thread_have_keyword some_in_thread_have_keyword
140
-
none_in_thread_have_keyword has_keyword not_keyword has_attachment
141
-
text from to_ cc bcc subject body header =
142
-
{ in_mailbox; in_mailbox_other_than; before; after; min_size; max_size;
143
-
all_in_thread_have_keyword; some_in_thread_have_keyword;
144
-
none_in_thread_have_keyword; has_keyword; not_keyword; has_attachment;
145
-
text; from; to_; cc; bcc; subject; body; header }
146
-
147
-
(* Header filter is encoded as [name] or [name, value] array *)
148
-
let header_jsont =
149
-
let kind = "HeaderFilter" in
150
-
let dec json =
151
-
match json with
152
-
| Jsont.Array ([Jsont.String (name, _)], _) ->
153
-
(name, None)
154
-
| Jsont.Array ([Jsont.String (name, _); Jsont.String (value, _)], _) ->
155
-
(name, Some value)
156
-
| _ ->
157
-
Jsont.Error.msgf Jsont.Meta.none "%s: expected [name] or [name, value]" kind
158
-
in
159
-
let enc (name, value) =
160
-
match value with
161
-
| None -> Jsont.Array ([Jsont.String (name, Jsont.Meta.none)], Jsont.Meta.none)
162
-
| Some v -> Jsont.Array ([Jsont.String (name, Jsont.Meta.none); Jsont.String (v, Jsont.Meta.none)], Jsont.Meta.none)
163
-
in
164
-
Jsont.map ~kind ~dec ~enc Jsont.json
165
-
166
-
let jsont =
167
-
let kind = "EmailFilterCondition" in
168
-
Jsont.Object.map ~kind make
169
-
|> Jsont.Object.opt_mem "inMailbox" Jmap_proto.Id.jsont ~enc:(fun f -> f.in_mailbox)
170
-
|> Jsont.Object.opt_mem "inMailboxOtherThan" (Jsont.list Jmap_proto.Id.jsont) ~enc:(fun f -> f.in_mailbox_other_than)
171
-
|> Jsont.Object.opt_mem "before" Jmap_proto.Date.Utc.jsont ~enc:(fun f -> f.before)
172
-
|> Jsont.Object.opt_mem "after" Jmap_proto.Date.Utc.jsont ~enc:(fun f -> f.after)
173
-
|> Jsont.Object.opt_mem "minSize" Jmap_proto.Int53.Unsigned.jsont ~enc:(fun f -> f.min_size)
174
-
|> Jsont.Object.opt_mem "maxSize" Jmap_proto.Int53.Unsigned.jsont ~enc:(fun f -> f.max_size)
175
-
|> Jsont.Object.opt_mem "allInThreadHaveKeyword" Jsont.string ~enc:(fun f -> f.all_in_thread_have_keyword)
176
-
|> Jsont.Object.opt_mem "someInThreadHaveKeyword" Jsont.string ~enc:(fun f -> f.some_in_thread_have_keyword)
177
-
|> Jsont.Object.opt_mem "noneInThreadHaveKeyword" Jsont.string ~enc:(fun f -> f.none_in_thread_have_keyword)
178
-
|> Jsont.Object.opt_mem "hasKeyword" Jsont.string ~enc:(fun f -> f.has_keyword)
179
-
|> Jsont.Object.opt_mem "notKeyword" Jsont.string ~enc:(fun f -> f.not_keyword)
180
-
|> Jsont.Object.opt_mem "hasAttachment" Jsont.bool ~enc:(fun f -> f.has_attachment)
181
-
|> Jsont.Object.opt_mem "text" Jsont.string ~enc:(fun f -> f.text)
182
-
|> Jsont.Object.opt_mem "from" Jsont.string ~enc:(fun f -> f.from)
183
-
|> Jsont.Object.opt_mem "to" Jsont.string ~enc:(fun f -> f.to_)
184
-
|> Jsont.Object.opt_mem "cc" Jsont.string ~enc:(fun f -> f.cc)
185
-
|> Jsont.Object.opt_mem "bcc" Jsont.string ~enc:(fun f -> f.bcc)
186
-
|> Jsont.Object.opt_mem "subject" Jsont.string ~enc:(fun f -> f.subject)
187
-
|> Jsont.Object.opt_mem "body" Jsont.string ~enc:(fun f -> f.body)
188
-
|> Jsont.Object.opt_mem "header" header_jsont ~enc:(fun f -> f.header)
189
-
|> Jsont.Object.finish
190
-
end
191
-
192
-
type get_args_extra = {
193
-
body_properties : string list option;
194
-
fetch_text_body_values : bool;
195
-
fetch_html_body_values : bool;
196
-
fetch_all_body_values : bool;
197
-
max_body_value_bytes : int64 option;
198
-
}
199
-
200
-
let get_args_extra_make body_properties fetch_text_body_values
201
-
fetch_html_body_values fetch_all_body_values max_body_value_bytes =
202
-
{ body_properties; fetch_text_body_values; fetch_html_body_values;
203
-
fetch_all_body_values; max_body_value_bytes }
204
-
205
-
let get_args_extra_jsont =
206
-
let kind = "Email/get extra args" in
207
-
Jsont.Object.map ~kind get_args_extra_make
208
-
|> Jsont.Object.opt_mem "bodyProperties" (Jsont.list Jsont.string) ~enc:(fun a -> a.body_properties)
209
-
|> Jsont.Object.mem "fetchTextBodyValues" Jsont.bool ~dec_absent:false
210
-
~enc:(fun a -> a.fetch_text_body_values) ~enc_omit:(fun b -> not b)
211
-
|> Jsont.Object.mem "fetchHTMLBodyValues" Jsont.bool ~dec_absent:false
212
-
~enc:(fun a -> a.fetch_html_body_values) ~enc_omit:(fun b -> not b)
213
-
|> Jsont.Object.mem "fetchAllBodyValues" Jsont.bool ~dec_absent:false
214
-
~enc:(fun a -> a.fetch_all_body_values) ~enc_omit:(fun b -> not b)
215
-
|> Jsont.Object.opt_mem "maxBodyValueBytes" Jmap_proto.Int53.Unsigned.jsont ~enc:(fun a -> a.max_body_value_bytes)
216
-
|> Jsont.Object.finish
-146
proto/mail/email.mli
-146
proto/mail/email.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Email type as defined in RFC 8621 Section 4 *)
7
-
8
-
(** {1 Standard Keywords} *)
9
-
10
-
(** Standard email keywords per RFC 8621. *)
11
-
module Keyword : sig
12
-
val draft : string
13
-
(** ["$draft"] *)
14
-
15
-
val seen : string
16
-
(** ["$seen"] *)
17
-
18
-
val flagged : string
19
-
(** ["$flagged"] *)
20
-
21
-
val answered : string
22
-
(** ["$answered"] *)
23
-
24
-
val forwarded : string
25
-
(** ["$forwarded"] *)
26
-
27
-
val phishing : string
28
-
(** ["$phishing"] *)
29
-
30
-
val junk : string
31
-
(** ["$junk"] *)
32
-
33
-
val not_junk : string
34
-
(** ["$notjunk"] *)
35
-
end
36
-
37
-
(** {1 Email Object} *)
38
-
39
-
type t = {
40
-
(* Metadata - server-set, immutable *)
41
-
id : Jmap_proto.Id.t;
42
-
blob_id : Jmap_proto.Id.t;
43
-
thread_id : Jmap_proto.Id.t;
44
-
size : int64;
45
-
received_at : Ptime.t;
46
-
47
-
(* Metadata - mutable *)
48
-
mailbox_ids : (Jmap_proto.Id.t * bool) list;
49
-
keywords : (string * bool) list;
50
-
51
-
(* Parsed headers *)
52
-
message_id : string list option;
53
-
in_reply_to : string list option;
54
-
references : string list option;
55
-
sender : Email_address.t list option;
56
-
from : Email_address.t list option;
57
-
to_ : Email_address.t list option;
58
-
cc : Email_address.t list option;
59
-
bcc : Email_address.t list option;
60
-
reply_to : Email_address.t list option;
61
-
subject : string option;
62
-
sent_at : Ptime.t option;
63
-
64
-
(* Raw headers *)
65
-
headers : Email_header.t list option;
66
-
67
-
(* Body structure *)
68
-
body_structure : Email_body.Part.t option;
69
-
body_values : (string * Email_body.Value.t) list option;
70
-
text_body : Email_body.Part.t list option;
71
-
html_body : Email_body.Part.t list option;
72
-
attachments : Email_body.Part.t list option;
73
-
has_attachment : bool;
74
-
preview : string;
75
-
}
76
-
77
-
val id : t -> Jmap_proto.Id.t
78
-
val blob_id : t -> Jmap_proto.Id.t
79
-
val thread_id : t -> Jmap_proto.Id.t
80
-
val size : t -> int64
81
-
val received_at : t -> Ptime.t
82
-
val mailbox_ids : t -> (Jmap_proto.Id.t * bool) list
83
-
val keywords : t -> (string * bool) list
84
-
val message_id : t -> string list option
85
-
val in_reply_to : t -> string list option
86
-
val references : t -> string list option
87
-
val sender : t -> Email_address.t list option
88
-
val from : t -> Email_address.t list option
89
-
val to_ : t -> Email_address.t list option
90
-
val cc : t -> Email_address.t list option
91
-
val bcc : t -> Email_address.t list option
92
-
val reply_to : t -> Email_address.t list option
93
-
val subject : t -> string option
94
-
val sent_at : t -> Ptime.t option
95
-
val headers : t -> Email_header.t list option
96
-
val body_structure : t -> Email_body.Part.t option
97
-
val body_values : t -> (string * Email_body.Value.t) list option
98
-
val text_body : t -> Email_body.Part.t list option
99
-
val html_body : t -> Email_body.Part.t list option
100
-
val attachments : t -> Email_body.Part.t list option
101
-
val has_attachment : t -> bool
102
-
val preview : t -> string
103
-
104
-
val jsont : t Jsont.t
105
-
106
-
(** {1 Email Filter Conditions} *)
107
-
108
-
module Filter_condition : sig
109
-
type t = {
110
-
in_mailbox : Jmap_proto.Id.t option;
111
-
in_mailbox_other_than : Jmap_proto.Id.t list option;
112
-
before : Ptime.t option;
113
-
after : Ptime.t option;
114
-
min_size : int64 option;
115
-
max_size : int64 option;
116
-
all_in_thread_have_keyword : string option;
117
-
some_in_thread_have_keyword : string option;
118
-
none_in_thread_have_keyword : string option;
119
-
has_keyword : string option;
120
-
not_keyword : string option;
121
-
has_attachment : bool option;
122
-
text : string option;
123
-
from : string option;
124
-
to_ : string option;
125
-
cc : string option;
126
-
bcc : string option;
127
-
subject : string option;
128
-
body : string option;
129
-
header : (string * string option) option;
130
-
}
131
-
132
-
val jsont : t Jsont.t
133
-
end
134
-
135
-
(** {1 Email/get Arguments} *)
136
-
137
-
(** Extra arguments for Email/get beyond standard /get. *)
138
-
type get_args_extra = {
139
-
body_properties : string list option;
140
-
fetch_text_body_values : bool;
141
-
fetch_html_body_values : bool;
142
-
fetch_all_body_values : bool;
143
-
max_body_value_bytes : int64 option;
144
-
}
145
-
146
-
val get_args_extra_jsont : get_args_extra Jsont.t
-53
proto/mail/email_address.ml
-53
proto/mail/email_address.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = {
7
-
name : string option;
8
-
email : string;
9
-
}
10
-
11
-
let create ?name email = { name; email }
12
-
13
-
let name t = t.name
14
-
let email t = t.email
15
-
16
-
let equal a b = a.email = b.email
17
-
18
-
let pp ppf t =
19
-
match t.name with
20
-
| Some name -> Format.fprintf ppf "%s <%s>" name t.email
21
-
| None -> Format.pp_print_string ppf t.email
22
-
23
-
let make name email = { name; email }
24
-
25
-
let jsont =
26
-
let kind = "EmailAddress" in
27
-
Jsont.Object.map ~kind make
28
-
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:name
29
-
|> Jsont.Object.mem "email" Jsont.string ~enc:email
30
-
|> Jsont.Object.finish
31
-
32
-
module Group = struct
33
-
type address = t
34
-
35
-
type t = {
36
-
name : string option;
37
-
addresses : address list;
38
-
}
39
-
40
-
let create ?name addresses = { name; addresses }
41
-
42
-
let name t = t.name
43
-
let addresses t = t.addresses
44
-
45
-
let make name addresses = { name; addresses }
46
-
47
-
let jsont =
48
-
let kind = "EmailAddressGroup" in
49
-
Jsont.Object.map ~kind make
50
-
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:name
51
-
|> Jsont.Object.mem "addresses" (Jsont.list jsont) ~enc:addresses
52
-
|> Jsont.Object.finish
53
-
end
-49
proto/mail/email_address.mli
-49
proto/mail/email_address.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Email address types as defined in RFC 8621 Section 4.1.2.3 *)
7
-
8
-
(** {1 Email Address} *)
9
-
10
-
(** An email address with optional display name. *)
11
-
type t = {
12
-
name : string option;
13
-
(** The display name (from the phrase in RFC 5322). *)
14
-
email : string;
15
-
(** The email address (addr-spec in RFC 5322). *)
16
-
}
17
-
18
-
val create : ?name:string -> string -> t
19
-
(** [create ?name email] creates an email address. *)
20
-
21
-
val name : t -> string option
22
-
val email : t -> string
23
-
24
-
val equal : t -> t -> bool
25
-
val pp : Format.formatter -> t -> unit
26
-
27
-
val jsont : t Jsont.t
28
-
(** JSON codec for email addresses. *)
29
-
30
-
(** {1 Address Groups} *)
31
-
32
-
(** A group of email addresses with an optional group name. *)
33
-
module Group : sig
34
-
type address = t
35
-
36
-
type t = {
37
-
name : string option;
38
-
(** The group name, or [None] for ungrouped addresses. *)
39
-
addresses : address list;
40
-
(** The addresses in this group. *)
41
-
}
42
-
43
-
val create : ?name:string -> address list -> t
44
-
45
-
val name : t -> string option
46
-
val addresses : t -> address list
47
-
48
-
val jsont : t Jsont.t
49
-
end
-85
proto/mail/email_body.ml
-85
proto/mail/email_body.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
module Value = struct
7
-
type t = {
8
-
value : string;
9
-
is_encoding_problem : bool;
10
-
is_truncated : bool;
11
-
}
12
-
13
-
let value t = t.value
14
-
let is_encoding_problem t = t.is_encoding_problem
15
-
let is_truncated t = t.is_truncated
16
-
17
-
let make value is_encoding_problem is_truncated =
18
-
{ value; is_encoding_problem; is_truncated }
19
-
20
-
let jsont =
21
-
let kind = "EmailBodyValue" in
22
-
Jsont.Object.map ~kind make
23
-
|> Jsont.Object.mem "value" Jsont.string ~enc:value
24
-
|> Jsont.Object.mem "isEncodingProblem" Jsont.bool ~dec_absent:false
25
-
~enc:is_encoding_problem ~enc_omit:(fun b -> not b)
26
-
|> Jsont.Object.mem "isTruncated" Jsont.bool ~dec_absent:false
27
-
~enc:is_truncated ~enc_omit:(fun b -> not b)
28
-
|> Jsont.Object.finish
29
-
end
30
-
31
-
module Part = struct
32
-
type t = {
33
-
part_id : string option;
34
-
blob_id : Jmap_proto.Id.t option;
35
-
size : int64 option;
36
-
headers : Email_header.t list option;
37
-
name : string option;
38
-
type_ : string;
39
-
charset : string option;
40
-
disposition : string option;
41
-
cid : string option;
42
-
language : string list option;
43
-
location : string option;
44
-
sub_parts : t list option;
45
-
}
46
-
47
-
let part_id t = t.part_id
48
-
let blob_id t = t.blob_id
49
-
let size t = t.size
50
-
let headers t = t.headers
51
-
let name t = t.name
52
-
let type_ t = t.type_
53
-
let charset t = t.charset
54
-
let disposition t = t.disposition
55
-
let cid t = t.cid
56
-
let language t = t.language
57
-
let location t = t.location
58
-
let sub_parts t = t.sub_parts
59
-
60
-
let rec jsont =
61
-
let kind = "EmailBodyPart" in
62
-
let make part_id blob_id size headers name type_ charset disposition
63
-
cid language location sub_parts =
64
-
{ part_id; blob_id; size; headers; name; type_; charset; disposition;
65
-
cid; language; location; sub_parts }
66
-
in
67
-
lazy (
68
-
Jsont.Object.map ~kind make
69
-
|> Jsont.Object.opt_mem "partId" Jsont.string ~enc:part_id
70
-
|> Jsont.Object.opt_mem "blobId" Jmap_proto.Id.jsont ~enc:blob_id
71
-
|> Jsont.Object.opt_mem "size" Jmap_proto.Int53.Unsigned.jsont ~enc:size
72
-
|> Jsont.Object.opt_mem "headers" (Jsont.list Email_header.jsont) ~enc:headers
73
-
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:name
74
-
|> Jsont.Object.mem "type" Jsont.string ~enc:type_
75
-
|> Jsont.Object.opt_mem "charset" Jsont.string ~enc:charset
76
-
|> Jsont.Object.opt_mem "disposition" Jsont.string ~enc:disposition
77
-
|> Jsont.Object.opt_mem "cid" Jsont.string ~enc:cid
78
-
|> Jsont.Object.opt_mem "language" (Jsont.list Jsont.string) ~enc:language
79
-
|> Jsont.Object.opt_mem "location" Jsont.string ~enc:location
80
-
|> Jsont.Object.opt_mem "subParts" (Jsont.list (Jsont.rec' jsont)) ~enc:sub_parts
81
-
|> Jsont.Object.finish
82
-
)
83
-
84
-
let jsont = Lazy.force jsont
85
-
end
-73
proto/mail/email_body.mli
-73
proto/mail/email_body.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Email body types as defined in RFC 8621 Section 4.1.4 *)
7
-
8
-
(** {1 Body Value} *)
9
-
10
-
(** Fetched body part content. *)
11
-
module Value : sig
12
-
type t = {
13
-
value : string;
14
-
(** The body part content. *)
15
-
is_encoding_problem : bool;
16
-
(** True if there was a problem decoding the content transfer encoding. *)
17
-
is_truncated : bool;
18
-
(** True if the value was truncated. *)
19
-
}
20
-
21
-
val value : t -> string
22
-
val is_encoding_problem : t -> bool
23
-
val is_truncated : t -> bool
24
-
25
-
val jsont : t Jsont.t
26
-
end
27
-
28
-
(** {1 Body Part} *)
29
-
30
-
(** An email body part structure. *)
31
-
module Part : sig
32
-
type t = {
33
-
part_id : string option;
34
-
(** Identifier for this part, used to fetch content. *)
35
-
blob_id : Jmap_proto.Id.t option;
36
-
(** Blob id if the part can be fetched as a blob. *)
37
-
size : int64 option;
38
-
(** Size in octets. *)
39
-
headers : Email_header.t list option;
40
-
(** Headers specific to this part. *)
41
-
name : string option;
42
-
(** Suggested filename from Content-Disposition. *)
43
-
type_ : string;
44
-
(** MIME type (e.g., "text/plain"). *)
45
-
charset : string option;
46
-
(** Character set parameter. *)
47
-
disposition : string option;
48
-
(** Content-Disposition value. *)
49
-
cid : string option;
50
-
(** Content-ID value. *)
51
-
language : string list option;
52
-
(** Content-Language values. *)
53
-
location : string option;
54
-
(** Content-Location value. *)
55
-
sub_parts : t list option;
56
-
(** Nested parts for multipart types. *)
57
-
}
58
-
59
-
val part_id : t -> string option
60
-
val blob_id : t -> Jmap_proto.Id.t option
61
-
val size : t -> int64 option
62
-
val headers : t -> Email_header.t list option
63
-
val name : t -> string option
64
-
val type_ : t -> string
65
-
val charset : t -> string option
66
-
val disposition : t -> string option
67
-
val cid : t -> string option
68
-
val language : t -> string list option
69
-
val location : t -> string option
70
-
val sub_parts : t -> t list option
71
-
72
-
val jsont : t Jsont.t
73
-
end
-39
proto/mail/email_header.ml
-39
proto/mail/email_header.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = {
7
-
name : string;
8
-
value : string;
9
-
}
10
-
11
-
let create ~name ~value = { name; value }
12
-
13
-
let name t = t.name
14
-
let value t = t.value
15
-
16
-
let make name value = { name; value }
17
-
18
-
let jsont =
19
-
let kind = "EmailHeader" in
20
-
Jsont.Object.map ~kind make
21
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
22
-
|> Jsont.Object.mem "value" Jsont.string ~enc:value
23
-
|> Jsont.Object.finish
24
-
25
-
(* Header parsed forms - these are used with header:Name:form properties *)
26
-
27
-
let raw_jsont = Jsont.string
28
-
29
-
let text_jsont = Jsont.string
30
-
31
-
let addresses_jsont = Jsont.list Email_address.jsont
32
-
33
-
let grouped_addresses_jsont = Jsont.list Email_address.Group.jsont
34
-
35
-
let message_ids_jsont = Jsont.list Jsont.string
36
-
37
-
let date_jsont = Jmap_proto.Date.Rfc3339.jsont
38
-
39
-
let urls_jsont = Jsont.list Jsont.string
-49
proto/mail/email_header.mli
-49
proto/mail/email_header.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Email header types as defined in RFC 8621 Section 4.1.2 *)
7
-
8
-
(** {1 Raw Headers} *)
9
-
10
-
(** A raw email header name-value pair. *)
11
-
type t = {
12
-
name : string;
13
-
(** The header field name. *)
14
-
value : string;
15
-
(** The raw header field value. *)
16
-
}
17
-
18
-
val create : name:string -> value:string -> t
19
-
20
-
val name : t -> string
21
-
val value : t -> string
22
-
23
-
val jsont : t Jsont.t
24
-
25
-
(** {1 Header Parsed Forms}
26
-
27
-
RFC 8621 defines several parsed forms for headers.
28
-
These can be requested via the header:Name:form properties. *)
29
-
30
-
(** The raw form - header value as-is. *)
31
-
val raw_jsont : string Jsont.t
32
-
33
-
(** The text form - decoded and unfolded value. *)
34
-
val text_jsont : string Jsont.t
35
-
36
-
(** The addresses form - list of email addresses. *)
37
-
val addresses_jsont : Email_address.t list Jsont.t
38
-
39
-
(** The grouped addresses form - addresses with group info. *)
40
-
val grouped_addresses_jsont : Email_address.Group.t list Jsont.t
41
-
42
-
(** The message IDs form - list of message-id strings. *)
43
-
val message_ids_jsont : string list Jsont.t
44
-
45
-
(** The date form - parsed RFC 3339 date. *)
46
-
val date_jsont : Ptime.t Jsont.t
47
-
48
-
(** The URLs form - list of URL strings. *)
49
-
val urls_jsont : string list Jsont.t
-40
proto/mail/identity.ml
-40
proto/mail/identity.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = {
7
-
id : Jmap_proto.Id.t;
8
-
name : string;
9
-
email : string;
10
-
reply_to : Email_address.t list option;
11
-
bcc : Email_address.t list option;
12
-
text_signature : string;
13
-
html_signature : string;
14
-
may_delete : bool;
15
-
}
16
-
17
-
let id t = t.id
18
-
let name t = t.name
19
-
let email t = t.email
20
-
let reply_to t = t.reply_to
21
-
let bcc t = t.bcc
22
-
let text_signature t = t.text_signature
23
-
let html_signature t = t.html_signature
24
-
let may_delete t = t.may_delete
25
-
26
-
let make id name email reply_to bcc text_signature html_signature may_delete =
27
-
{ id; name; email; reply_to; bcc; text_signature; html_signature; may_delete }
28
-
29
-
let jsont =
30
-
let kind = "Identity" in
31
-
Jsont.Object.map ~kind make
32
-
|> Jsont.Object.mem "id" Jmap_proto.Id.jsont ~enc:id
33
-
|> Jsont.Object.mem "name" Jsont.string ~dec_absent:"" ~enc:name
34
-
|> Jsont.Object.mem "email" Jsont.string ~enc:email
35
-
|> Jsont.Object.opt_mem "replyTo" (Jsont.list Email_address.jsont) ~enc:reply_to
36
-
|> Jsont.Object.opt_mem "bcc" (Jsont.list Email_address.jsont) ~enc:bcc
37
-
|> Jsont.Object.mem "textSignature" Jsont.string ~dec_absent:"" ~enc:text_signature
38
-
|> Jsont.Object.mem "htmlSignature" Jsont.string ~dec_absent:"" ~enc:html_signature
39
-
|> Jsont.Object.mem "mayDelete" Jsont.bool ~enc:may_delete
40
-
|> Jsont.Object.finish
-36
proto/mail/identity.mli
-36
proto/mail/identity.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Identity type as defined in RFC 8621 Section 6 *)
7
-
8
-
type t = {
9
-
id : Jmap_proto.Id.t;
10
-
(** Server-assigned identity id. *)
11
-
name : string;
12
-
(** Display name for sent emails. *)
13
-
email : string;
14
-
(** The email address to use. *)
15
-
reply_to : Email_address.t list option;
16
-
(** Default Reply-To addresses. *)
17
-
bcc : Email_address.t list option;
18
-
(** Default BCC addresses. *)
19
-
text_signature : string;
20
-
(** Plain text signature. *)
21
-
html_signature : string;
22
-
(** HTML signature. *)
23
-
may_delete : bool;
24
-
(** Whether the user may delete this identity. *)
25
-
}
26
-
27
-
val id : t -> Jmap_proto.Id.t
28
-
val name : t -> string
29
-
val email : t -> string
30
-
val reply_to : t -> Email_address.t list option
31
-
val bcc : t -> Email_address.t list option
32
-
val text_signature : t -> string
33
-
val html_signature : t -> string
34
-
val may_delete : t -> bool
35
-
36
-
val jsont : t Jsont.t
-20
proto/mail/jmap_mail.ml
-20
proto/mail/jmap_mail.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP Mail Types (RFC 8621)
7
-
8
-
This module re-exports all JMAP mail protocol types. *)
9
-
10
-
module Email_address = Email_address
11
-
module Email_header = Email_header
12
-
module Email_body = Email_body
13
-
module Mailbox = Mailbox
14
-
module Thread = Thread
15
-
module Email = Email
16
-
module Search_snippet = Search_snippet
17
-
module Identity = Identity
18
-
module Submission = Submission
19
-
module Vacation = Vacation
20
-
module Mail_filter = Mail_filter
-16
proto/mail/mail_filter.ml
-16
proto/mail/mail_filter.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type email_filter = Email.Filter_condition.t Jmap_proto.Filter.filter
7
-
8
-
let email_filter_jsont = Jmap_proto.Filter.filter_jsont Email.Filter_condition.jsont
9
-
10
-
type mailbox_filter = Mailbox.Filter_condition.t Jmap_proto.Filter.filter
11
-
12
-
let mailbox_filter_jsont = Jmap_proto.Filter.filter_jsont Mailbox.Filter_condition.jsont
13
-
14
-
type submission_filter = Submission.Filter_condition.t Jmap_proto.Filter.filter
15
-
16
-
let submission_filter_jsont = Jmap_proto.Filter.filter_jsont Submission.Filter_condition.jsont
-21
proto/mail/mail_filter.mli
-21
proto/mail/mail_filter.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Mail-specific filter types *)
7
-
8
-
(** Email filter with Email-specific conditions. *)
9
-
type email_filter = Email.Filter_condition.t Jmap_proto.Filter.filter
10
-
11
-
val email_filter_jsont : email_filter Jsont.t
12
-
13
-
(** Mailbox filter with Mailbox-specific conditions. *)
14
-
type mailbox_filter = Mailbox.Filter_condition.t Jmap_proto.Filter.filter
15
-
16
-
val mailbox_filter_jsont : mailbox_filter Jsont.t
17
-
18
-
(** EmailSubmission filter with Submission-specific conditions. *)
19
-
type submission_filter = Submission.Filter_condition.t Jmap_proto.Filter.filter
20
-
21
-
val submission_filter_jsont : submission_filter Jsont.t
-165
proto/mail/mailbox.ml
-165
proto/mail/mailbox.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
module Rights = struct
7
-
type t = {
8
-
may_read_items : bool;
9
-
may_add_items : bool;
10
-
may_remove_items : bool;
11
-
may_set_seen : bool;
12
-
may_set_keywords : bool;
13
-
may_create_child : bool;
14
-
may_rename : bool;
15
-
may_delete : bool;
16
-
may_submit : bool;
17
-
}
18
-
19
-
let may_read_items t = t.may_read_items
20
-
let may_add_items t = t.may_add_items
21
-
let may_remove_items t = t.may_remove_items
22
-
let may_set_seen t = t.may_set_seen
23
-
let may_set_keywords t = t.may_set_keywords
24
-
let may_create_child t = t.may_create_child
25
-
let may_rename t = t.may_rename
26
-
let may_delete t = t.may_delete
27
-
let may_submit t = t.may_submit
28
-
29
-
let make may_read_items may_add_items may_remove_items may_set_seen
30
-
may_set_keywords may_create_child may_rename may_delete may_submit =
31
-
{ may_read_items; may_add_items; may_remove_items; may_set_seen;
32
-
may_set_keywords; may_create_child; may_rename; may_delete; may_submit }
33
-
34
-
let jsont =
35
-
let kind = "MailboxRights" in
36
-
Jsont.Object.map ~kind make
37
-
|> Jsont.Object.mem "mayReadItems" Jsont.bool ~enc:may_read_items
38
-
|> Jsont.Object.mem "mayAddItems" Jsont.bool ~enc:may_add_items
39
-
|> Jsont.Object.mem "mayRemoveItems" Jsont.bool ~enc:may_remove_items
40
-
|> Jsont.Object.mem "maySetSeen" Jsont.bool ~enc:may_set_seen
41
-
|> Jsont.Object.mem "maySetKeywords" Jsont.bool ~enc:may_set_keywords
42
-
|> Jsont.Object.mem "mayCreateChild" Jsont.bool ~enc:may_create_child
43
-
|> Jsont.Object.mem "mayRename" Jsont.bool ~enc:may_rename
44
-
|> Jsont.Object.mem "mayDelete" Jsont.bool ~enc:may_delete
45
-
|> Jsont.Object.mem "maySubmit" Jsont.bool ~enc:may_submit
46
-
|> Jsont.Object.finish
47
-
end
48
-
49
-
type role =
50
-
| All
51
-
| Archive
52
-
| Drafts
53
-
| Flagged
54
-
| Important
55
-
| Inbox
56
-
| Junk
57
-
| Sent
58
-
| Subscribed
59
-
| Trash
60
-
| Other of string
61
-
62
-
let role_to_string = function
63
-
| All -> "all"
64
-
| Archive -> "archive"
65
-
| Drafts -> "drafts"
66
-
| Flagged -> "flagged"
67
-
| Important -> "important"
68
-
| Inbox -> "inbox"
69
-
| Junk -> "junk"
70
-
| Sent -> "sent"
71
-
| Subscribed -> "subscribed"
72
-
| Trash -> "trash"
73
-
| Other s -> s
74
-
75
-
let role_of_string = function
76
-
| "all" -> All
77
-
| "archive" -> Archive
78
-
| "drafts" -> Drafts
79
-
| "flagged" -> Flagged
80
-
| "important" -> Important
81
-
| "inbox" -> Inbox
82
-
| "junk" -> Junk
83
-
| "sent" -> Sent
84
-
| "subscribed" -> Subscribed
85
-
| "trash" -> Trash
86
-
| s -> Other s
87
-
88
-
let role_jsont =
89
-
Jsont.map ~kind:"MailboxRole"
90
-
~dec:(fun s -> role_of_string s)
91
-
~enc:role_to_string
92
-
Jsont.string
93
-
94
-
type t = {
95
-
id : Jmap_proto.Id.t;
96
-
name : string;
97
-
parent_id : Jmap_proto.Id.t option;
98
-
role : role option;
99
-
sort_order : int64;
100
-
total_emails : int64;
101
-
unread_emails : int64;
102
-
total_threads : int64;
103
-
unread_threads : int64;
104
-
my_rights : Rights.t;
105
-
is_subscribed : bool;
106
-
}
107
-
108
-
let id t = t.id
109
-
let name t = t.name
110
-
let parent_id t = t.parent_id
111
-
let role t = t.role
112
-
let sort_order t = t.sort_order
113
-
let total_emails t = t.total_emails
114
-
let unread_emails t = t.unread_emails
115
-
let total_threads t = t.total_threads
116
-
let unread_threads t = t.unread_threads
117
-
let my_rights t = t.my_rights
118
-
let is_subscribed t = t.is_subscribed
119
-
120
-
let make id name parent_id role sort_order total_emails unread_emails
121
-
total_threads unread_threads my_rights is_subscribed =
122
-
{ id; name; parent_id; role; sort_order; total_emails; unread_emails;
123
-
total_threads; unread_threads; my_rights; is_subscribed }
124
-
125
-
let jsont =
126
-
let kind = "Mailbox" in
127
-
Jsont.Object.map ~kind make
128
-
|> Jsont.Object.mem "id" Jmap_proto.Id.jsont ~enc:id
129
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
130
-
|> Jsont.Object.opt_mem "parentId" Jmap_proto.Id.jsont ~enc:parent_id
131
-
|> Jsont.Object.opt_mem "role" role_jsont ~enc:role
132
-
|> Jsont.Object.mem "sortOrder" Jmap_proto.Int53.Unsigned.jsont ~dec_absent:0L ~enc:sort_order
133
-
|> Jsont.Object.mem "totalEmails" Jmap_proto.Int53.Unsigned.jsont ~enc:total_emails
134
-
|> Jsont.Object.mem "unreadEmails" Jmap_proto.Int53.Unsigned.jsont ~enc:unread_emails
135
-
|> Jsont.Object.mem "totalThreads" Jmap_proto.Int53.Unsigned.jsont ~enc:total_threads
136
-
|> Jsont.Object.mem "unreadThreads" Jmap_proto.Int53.Unsigned.jsont ~enc:unread_threads
137
-
|> Jsont.Object.mem "myRights" Rights.jsont ~enc:my_rights
138
-
|> Jsont.Object.mem "isSubscribed" Jsont.bool ~enc:is_subscribed
139
-
|> Jsont.Object.finish
140
-
141
-
module Filter_condition = struct
142
-
type t = {
143
-
parent_id : Jmap_proto.Id.t option option;
144
-
name : string option;
145
-
role : role option option;
146
-
has_any_role : bool option;
147
-
is_subscribed : bool option;
148
-
}
149
-
150
-
let make parent_id name role has_any_role is_subscribed =
151
-
{ parent_id; name; role; has_any_role; is_subscribed }
152
-
153
-
let jsont =
154
-
let kind = "MailboxFilterCondition" in
155
-
(* parentId can be null (meaning top-level) or an id *)
156
-
let nullable_id = Jsont.(some Jmap_proto.Id.jsont) in
157
-
let nullable_role = Jsont.(some role_jsont) in
158
-
Jsont.Object.map ~kind make
159
-
|> Jsont.Object.opt_mem "parentId" nullable_id ~enc:(fun f -> f.parent_id)
160
-
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:(fun f -> f.name)
161
-
|> Jsont.Object.opt_mem "role" nullable_role ~enc:(fun f -> f.role)
162
-
|> Jsont.Object.opt_mem "hasAnyRole" Jsont.bool ~enc:(fun f -> f.has_any_role)
163
-
|> Jsont.Object.opt_mem "isSubscribed" Jsont.bool ~enc:(fun f -> f.is_subscribed)
164
-
|> Jsont.Object.finish
165
-
end
-116
proto/mail/mailbox.mli
-116
proto/mail/mailbox.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Mailbox type as defined in RFC 8621 Section 2 *)
7
-
8
-
(** {1 Mailbox Rights} *)
9
-
10
-
(** Rights the user has on a mailbox. *)
11
-
module Rights : sig
12
-
type t = {
13
-
may_read_items : bool;
14
-
may_add_items : bool;
15
-
may_remove_items : bool;
16
-
may_set_seen : bool;
17
-
may_set_keywords : bool;
18
-
may_create_child : bool;
19
-
may_rename : bool;
20
-
may_delete : bool;
21
-
may_submit : bool;
22
-
}
23
-
24
-
val may_read_items : t -> bool
25
-
val may_add_items : t -> bool
26
-
val may_remove_items : t -> bool
27
-
val may_set_seen : t -> bool
28
-
val may_set_keywords : t -> bool
29
-
val may_create_child : t -> bool
30
-
val may_rename : t -> bool
31
-
val may_delete : t -> bool
32
-
val may_submit : t -> bool
33
-
34
-
val jsont : t Jsont.t
35
-
end
36
-
37
-
(** {1 Standard Roles} *)
38
-
39
-
(** Standard mailbox roles per RFC 8621 Section 2. *)
40
-
type role =
41
-
| All
42
-
| Archive
43
-
| Drafts
44
-
| Flagged
45
-
| Important
46
-
| Inbox
47
-
| Junk
48
-
| Sent
49
-
| Subscribed
50
-
| Trash
51
-
| Other of string
52
-
53
-
val role_to_string : role -> string
54
-
val role_of_string : string -> role
55
-
val role_jsont : role Jsont.t
56
-
57
-
(** {1 Mailbox} *)
58
-
59
-
type t = {
60
-
id : Jmap_proto.Id.t;
61
-
(** Server-assigned mailbox id. *)
62
-
name : string;
63
-
(** User-visible name (UTF-8). *)
64
-
parent_id : Jmap_proto.Id.t option;
65
-
(** Id of parent mailbox, or [None] for root. *)
66
-
role : role option;
67
-
(** Standard role, if any. *)
68
-
sort_order : int64;
69
-
(** Sort order hint (lower = displayed first). *)
70
-
total_emails : int64;
71
-
(** Total number of emails in mailbox. *)
72
-
unread_emails : int64;
73
-
(** Number of unread emails. *)
74
-
total_threads : int64;
75
-
(** Total number of threads. *)
76
-
unread_threads : int64;
77
-
(** Number of threads with unread emails. *)
78
-
my_rights : Rights.t;
79
-
(** User's rights on this mailbox. *)
80
-
is_subscribed : bool;
81
-
(** Whether user is subscribed to this mailbox. *)
82
-
}
83
-
84
-
val id : t -> Jmap_proto.Id.t
85
-
val name : t -> string
86
-
val parent_id : t -> Jmap_proto.Id.t option
87
-
val role : t -> role option
88
-
val sort_order : t -> int64
89
-
val total_emails : t -> int64
90
-
val unread_emails : t -> int64
91
-
val total_threads : t -> int64
92
-
val unread_threads : t -> int64
93
-
val my_rights : t -> Rights.t
94
-
val is_subscribed : t -> bool
95
-
96
-
val jsont : t Jsont.t
97
-
98
-
(** {1 Mailbox Filter Conditions} *)
99
-
100
-
(** Filter conditions for Mailbox/query. *)
101
-
module Filter_condition : sig
102
-
type t = {
103
-
parent_id : Jmap_proto.Id.t option option;
104
-
(** Filter by parent. [Some None] = top-level only. *)
105
-
name : string option;
106
-
(** Filter by exact name match. *)
107
-
role : role option option;
108
-
(** Filter by role. [Some None] = no role. *)
109
-
has_any_role : bool option;
110
-
(** Filter by whether mailbox has any role. *)
111
-
is_subscribed : bool option;
112
-
(** Filter by subscription status. *)
113
-
}
114
-
115
-
val jsont : t Jsont.t
116
-
end
-24
proto/mail/search_snippet.ml
-24
proto/mail/search_snippet.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = {
7
-
email_id : Jmap_proto.Id.t;
8
-
subject : string option;
9
-
preview : string option;
10
-
}
11
-
12
-
let email_id t = t.email_id
13
-
let subject t = t.subject
14
-
let preview t = t.preview
15
-
16
-
let make email_id subject preview = { email_id; subject; preview }
17
-
18
-
let jsont =
19
-
let kind = "SearchSnippet" in
20
-
Jsont.Object.map ~kind make
21
-
|> Jsont.Object.mem "emailId" Jmap_proto.Id.jsont ~enc:email_id
22
-
|> Jsont.Object.opt_mem "subject" Jsont.string ~enc:subject
23
-
|> Jsont.Object.opt_mem "preview" Jsont.string ~enc:preview
24
-
|> Jsont.Object.finish
-21
proto/mail/search_snippet.mli
-21
proto/mail/search_snippet.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** SearchSnippet type as defined in RFC 8621 Section 5 *)
7
-
8
-
type t = {
9
-
email_id : Jmap_proto.Id.t;
10
-
(** The email this snippet is for. *)
11
-
subject : string option;
12
-
(** HTML snippet of matching subject text. *)
13
-
preview : string option;
14
-
(** HTML snippet of matching body text. *)
15
-
}
16
-
17
-
val email_id : t -> Jmap_proto.Id.t
18
-
val subject : t -> string option
19
-
val preview : t -> string option
20
-
21
-
val jsont : t Jsont.t
-183
proto/mail/submission.ml
-183
proto/mail/submission.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
module Address = struct
7
-
type t = {
8
-
email : string;
9
-
parameters : (string * string) list option;
10
-
}
11
-
12
-
let email t = t.email
13
-
let parameters t = t.parameters
14
-
15
-
let make email parameters = { email; parameters }
16
-
17
-
let jsont =
18
-
let kind = "EmailSubmission Address" in
19
-
Jsont.Object.map ~kind make
20
-
|> Jsont.Object.mem "email" Jsont.string ~enc:email
21
-
|> Jsont.Object.opt_mem "parameters" (Jmap_proto.Json_map.of_string Jsont.string) ~enc:parameters
22
-
|> Jsont.Object.finish
23
-
end
24
-
25
-
module Envelope = struct
26
-
type t = {
27
-
mail_from : Address.t;
28
-
rcpt_to : Address.t list;
29
-
}
30
-
31
-
let mail_from t = t.mail_from
32
-
let rcpt_to t = t.rcpt_to
33
-
34
-
let make mail_from rcpt_to = { mail_from; rcpt_to }
35
-
36
-
let jsont =
37
-
let kind = "Envelope" in
38
-
Jsont.Object.map ~kind make
39
-
|> Jsont.Object.mem "mailFrom" Address.jsont ~enc:mail_from
40
-
|> Jsont.Object.mem "rcptTo" (Jsont.list Address.jsont) ~enc:rcpt_to
41
-
|> Jsont.Object.finish
42
-
end
43
-
44
-
module Delivery_status = struct
45
-
type delivered = Queued | Yes | No | Unknown
46
-
47
-
let delivered_to_string = function
48
-
| Queued -> "queued"
49
-
| Yes -> "yes"
50
-
| No -> "no"
51
-
| Unknown -> "unknown"
52
-
53
-
let delivered_of_string = function
54
-
| "queued" -> Queued
55
-
| "yes" -> Yes
56
-
| "no" -> No
57
-
| _ -> Unknown
58
-
59
-
let delivered_jsont =
60
-
Jsont.map ~kind:"DeliveryStatus.delivered"
61
-
~dec:delivered_of_string ~enc:delivered_to_string Jsont.string
62
-
63
-
type displayed = Unknown | Yes
64
-
65
-
let displayed_to_string = function
66
-
| Unknown -> "unknown"
67
-
| Yes -> "yes"
68
-
69
-
let displayed_of_string = function
70
-
| "yes" -> Yes
71
-
| _ -> Unknown
72
-
73
-
let displayed_jsont =
74
-
Jsont.map ~kind:"DeliveryStatus.displayed"
75
-
~dec:displayed_of_string ~enc:displayed_to_string Jsont.string
76
-
77
-
type t = {
78
-
smtp_reply : string;
79
-
delivered : delivered;
80
-
displayed : displayed;
81
-
}
82
-
83
-
let smtp_reply t = t.smtp_reply
84
-
let delivered t = t.delivered
85
-
let displayed t = t.displayed
86
-
87
-
let make smtp_reply delivered displayed =
88
-
{ smtp_reply; delivered; displayed }
89
-
90
-
let jsont =
91
-
let kind = "DeliveryStatus" in
92
-
Jsont.Object.map ~kind make
93
-
|> Jsont.Object.mem "smtpReply" Jsont.string ~enc:smtp_reply
94
-
|> Jsont.Object.mem "delivered" delivered_jsont ~enc:delivered
95
-
|> Jsont.Object.mem "displayed" displayed_jsont ~enc:displayed
96
-
|> Jsont.Object.finish
97
-
end
98
-
99
-
type undo_status = Pending | Final | Canceled
100
-
101
-
let undo_status_to_string = function
102
-
| Pending -> "pending"
103
-
| Final -> "final"
104
-
| Canceled -> "canceled"
105
-
106
-
let undo_status_of_string = function
107
-
| "pending" -> Pending
108
-
| "final" -> Final
109
-
| "canceled" -> Canceled
110
-
| s -> Jsont.Error.msgf Jsont.Meta.none "Unknown undo status: %s" s
111
-
112
-
let undo_status_jsont =
113
-
Jsont.map ~kind:"UndoStatus"
114
-
~dec:undo_status_of_string ~enc:undo_status_to_string Jsont.string
115
-
116
-
type t = {
117
-
id : Jmap_proto.Id.t;
118
-
identity_id : Jmap_proto.Id.t;
119
-
email_id : Jmap_proto.Id.t;
120
-
thread_id : Jmap_proto.Id.t;
121
-
envelope : Envelope.t option;
122
-
send_at : Ptime.t;
123
-
undo_status : undo_status;
124
-
delivery_status : (string * Delivery_status.t) list option;
125
-
dsn_blob_ids : Jmap_proto.Id.t list;
126
-
mdn_blob_ids : Jmap_proto.Id.t list;
127
-
}
128
-
129
-
let id t = t.id
130
-
let identity_id t = t.identity_id
131
-
let email_id t = t.email_id
132
-
let thread_id t = t.thread_id
133
-
let envelope t = t.envelope
134
-
let send_at t = t.send_at
135
-
let undo_status t = t.undo_status
136
-
let delivery_status t = t.delivery_status
137
-
let dsn_blob_ids t = t.dsn_blob_ids
138
-
let mdn_blob_ids t = t.mdn_blob_ids
139
-
140
-
let make id identity_id email_id thread_id envelope send_at undo_status
141
-
delivery_status dsn_blob_ids mdn_blob_ids =
142
-
{ id; identity_id; email_id; thread_id; envelope; send_at; undo_status;
143
-
delivery_status; dsn_blob_ids; mdn_blob_ids }
144
-
145
-
let jsont =
146
-
let kind = "EmailSubmission" in
147
-
Jsont.Object.map ~kind make
148
-
|> Jsont.Object.mem "id" Jmap_proto.Id.jsont ~enc:id
149
-
|> Jsont.Object.mem "identityId" Jmap_proto.Id.jsont ~enc:identity_id
150
-
|> Jsont.Object.mem "emailId" Jmap_proto.Id.jsont ~enc:email_id
151
-
|> Jsont.Object.mem "threadId" Jmap_proto.Id.jsont ~enc:thread_id
152
-
|> Jsont.Object.opt_mem "envelope" Envelope.jsont ~enc:envelope
153
-
|> Jsont.Object.mem "sendAt" Jmap_proto.Date.Utc.jsont ~enc:send_at
154
-
|> Jsont.Object.mem "undoStatus" undo_status_jsont ~enc:undo_status
155
-
|> Jsont.Object.opt_mem "deliveryStatus" (Jmap_proto.Json_map.of_string Delivery_status.jsont) ~enc:delivery_status
156
-
|> Jsont.Object.mem "dsnBlobIds" (Jsont.list Jmap_proto.Id.jsont) ~dec_absent:[] ~enc:dsn_blob_ids
157
-
|> Jsont.Object.mem "mdnBlobIds" (Jsont.list Jmap_proto.Id.jsont) ~dec_absent:[] ~enc:mdn_blob_ids
158
-
|> Jsont.Object.finish
159
-
160
-
module Filter_condition = struct
161
-
type t = {
162
-
identity_ids : Jmap_proto.Id.t list option;
163
-
email_ids : Jmap_proto.Id.t list option;
164
-
thread_ids : Jmap_proto.Id.t list option;
165
-
undo_status : undo_status option;
166
-
before : Ptime.t option;
167
-
after : Ptime.t option;
168
-
}
169
-
170
-
let make identity_ids email_ids thread_ids undo_status before after =
171
-
{ identity_ids; email_ids; thread_ids; undo_status; before; after }
172
-
173
-
let jsont =
174
-
let kind = "EmailSubmissionFilterCondition" in
175
-
Jsont.Object.map ~kind make
176
-
|> Jsont.Object.opt_mem "identityIds" (Jsont.list Jmap_proto.Id.jsont) ~enc:(fun f -> f.identity_ids)
177
-
|> Jsont.Object.opt_mem "emailIds" (Jsont.list Jmap_proto.Id.jsont) ~enc:(fun f -> f.email_ids)
178
-
|> Jsont.Object.opt_mem "threadIds" (Jsont.list Jmap_proto.Id.jsont) ~enc:(fun f -> f.thread_ids)
179
-
|> Jsont.Object.opt_mem "undoStatus" undo_status_jsont ~enc:(fun f -> f.undo_status)
180
-
|> Jsont.Object.opt_mem "before" Jmap_proto.Date.Utc.jsont ~enc:(fun f -> f.before)
181
-
|> Jsont.Object.opt_mem "after" Jmap_proto.Date.Utc.jsont ~enc:(fun f -> f.after)
182
-
|> Jsont.Object.finish
183
-
end
-132
proto/mail/submission.mli
-132
proto/mail/submission.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** EmailSubmission type as defined in RFC 8621 Section 7 *)
7
-
8
-
(** {1 Address} *)
9
-
10
-
(** An address with optional SMTP parameters. *)
11
-
module Address : sig
12
-
type t = {
13
-
email : string;
14
-
(** The email address. *)
15
-
parameters : (string * string) list option;
16
-
(** Optional SMTP parameters. *)
17
-
}
18
-
19
-
val email : t -> string
20
-
val parameters : t -> (string * string) list option
21
-
22
-
val jsont : t Jsont.t
23
-
end
24
-
25
-
(** {1 Envelope} *)
26
-
27
-
(** SMTP envelope. *)
28
-
module Envelope : sig
29
-
type t = {
30
-
mail_from : Address.t;
31
-
(** MAIL FROM address. *)
32
-
rcpt_to : Address.t list;
33
-
(** RCPT TO addresses. *)
34
-
}
35
-
36
-
val mail_from : t -> Address.t
37
-
val rcpt_to : t -> Address.t list
38
-
39
-
val jsont : t Jsont.t
40
-
end
41
-
42
-
(** {1 Delivery Status} *)
43
-
44
-
(** Status of delivery to a recipient. *)
45
-
module Delivery_status : sig
46
-
type delivered =
47
-
| Queued
48
-
| Yes
49
-
| No
50
-
| Unknown
51
-
52
-
type displayed =
53
-
| Unknown
54
-
| Yes
55
-
56
-
type t = {
57
-
smtp_reply : string;
58
-
(** The SMTP reply string. *)
59
-
delivered : delivered;
60
-
(** Delivery status. *)
61
-
displayed : displayed;
62
-
(** MDN display status. *)
63
-
}
64
-
65
-
val smtp_reply : t -> string
66
-
val delivered : t -> delivered
67
-
val displayed : t -> displayed
68
-
69
-
val jsont : t Jsont.t
70
-
end
71
-
72
-
(** {1 Undo Status} *)
73
-
74
-
type undo_status =
75
-
| Pending
76
-
| Final
77
-
| Canceled
78
-
79
-
val undo_status_jsont : undo_status Jsont.t
80
-
81
-
(** {1 EmailSubmission} *)
82
-
83
-
type t = {
84
-
id : Jmap_proto.Id.t;
85
-
(** Server-assigned submission id. *)
86
-
identity_id : Jmap_proto.Id.t;
87
-
(** The identity used to send. *)
88
-
email_id : Jmap_proto.Id.t;
89
-
(** The email that was submitted. *)
90
-
thread_id : Jmap_proto.Id.t;
91
-
(** The thread of the submitted email. *)
92
-
envelope : Envelope.t option;
93
-
(** The envelope used, if different from email headers. *)
94
-
send_at : Ptime.t;
95
-
(** When the email was/will be sent. *)
96
-
undo_status : undo_status;
97
-
(** Whether sending can be undone. *)
98
-
delivery_status : (string * Delivery_status.t) list option;
99
-
(** Delivery status per recipient. *)
100
-
dsn_blob_ids : Jmap_proto.Id.t list;
101
-
(** Blob ids of received DSN messages. *)
102
-
mdn_blob_ids : Jmap_proto.Id.t list;
103
-
(** Blob ids of received MDN messages. *)
104
-
}
105
-
106
-
val id : t -> Jmap_proto.Id.t
107
-
val identity_id : t -> Jmap_proto.Id.t
108
-
val email_id : t -> Jmap_proto.Id.t
109
-
val thread_id : t -> Jmap_proto.Id.t
110
-
val envelope : t -> Envelope.t option
111
-
val send_at : t -> Ptime.t
112
-
val undo_status : t -> undo_status
113
-
val delivery_status : t -> (string * Delivery_status.t) list option
114
-
val dsn_blob_ids : t -> Jmap_proto.Id.t list
115
-
val mdn_blob_ids : t -> Jmap_proto.Id.t list
116
-
117
-
val jsont : t Jsont.t
118
-
119
-
(** {1 Filter Conditions} *)
120
-
121
-
module Filter_condition : sig
122
-
type t = {
123
-
identity_ids : Jmap_proto.Id.t list option;
124
-
email_ids : Jmap_proto.Id.t list option;
125
-
thread_ids : Jmap_proto.Id.t list option;
126
-
undo_status : undo_status option;
127
-
before : Ptime.t option;
128
-
after : Ptime.t option;
129
-
}
130
-
131
-
val jsont : t Jsont.t
132
-
end
-21
proto/mail/thread.ml
-21
proto/mail/thread.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = {
7
-
id : Jmap_proto.Id.t;
8
-
email_ids : Jmap_proto.Id.t list;
9
-
}
10
-
11
-
let id t = t.id
12
-
let email_ids t = t.email_ids
13
-
14
-
let make id email_ids = { id; email_ids }
15
-
16
-
let jsont =
17
-
let kind = "Thread" in
18
-
Jsont.Object.map ~kind make
19
-
|> Jsont.Object.mem "id" Jmap_proto.Id.jsont ~enc:id
20
-
|> Jsont.Object.mem "emailIds" (Jsont.list Jmap_proto.Id.jsont) ~enc:email_ids
21
-
|> Jsont.Object.finish
-18
proto/mail/thread.mli
-18
proto/mail/thread.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Thread type as defined in RFC 8621 Section 3 *)
7
-
8
-
type t = {
9
-
id : Jmap_proto.Id.t;
10
-
(** Server-assigned thread id. *)
11
-
email_ids : Jmap_proto.Id.t list;
12
-
(** Ids of emails in this thread, in date order. *)
13
-
}
14
-
15
-
val id : t -> Jmap_proto.Id.t
16
-
val email_ids : t -> Jmap_proto.Id.t list
17
-
18
-
val jsont : t Jsont.t
-39
proto/mail/vacation.ml
-39
proto/mail/vacation.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = {
7
-
id : Jmap_proto.Id.t;
8
-
is_enabled : bool;
9
-
from_date : Ptime.t option;
10
-
to_date : Ptime.t option;
11
-
subject : string option;
12
-
text_body : string option;
13
-
html_body : string option;
14
-
}
15
-
16
-
let id t = t.id
17
-
let is_enabled t = t.is_enabled
18
-
let from_date t = t.from_date
19
-
let to_date t = t.to_date
20
-
let subject t = t.subject
21
-
let text_body t = t.text_body
22
-
let html_body t = t.html_body
23
-
24
-
let singleton_id = Jmap_proto.Id.of_string_exn "singleton"
25
-
26
-
let make id is_enabled from_date to_date subject text_body html_body =
27
-
{ id; is_enabled; from_date; to_date; subject; text_body; html_body }
28
-
29
-
let jsont =
30
-
let kind = "VacationResponse" in
31
-
Jsont.Object.map ~kind make
32
-
|> Jsont.Object.mem "id" Jmap_proto.Id.jsont ~enc:id
33
-
|> Jsont.Object.mem "isEnabled" Jsont.bool ~enc:is_enabled
34
-
|> Jsont.Object.opt_mem "fromDate" Jmap_proto.Date.Utc.jsont ~enc:from_date
35
-
|> Jsont.Object.opt_mem "toDate" Jmap_proto.Date.Utc.jsont ~enc:to_date
36
-
|> Jsont.Object.opt_mem "subject" Jsont.string ~enc:subject
37
-
|> Jsont.Object.opt_mem "textBody" Jsont.string ~enc:text_body
38
-
|> Jsont.Object.opt_mem "htmlBody" Jsont.string ~enc:html_body
39
-
|> Jsont.Object.finish
-36
proto/mail/vacation.mli
-36
proto/mail/vacation.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** VacationResponse type as defined in RFC 8621 Section 8 *)
7
-
8
-
type t = {
9
-
id : Jmap_proto.Id.t;
10
-
(** Always "singleton" - there is only one vacation response. *)
11
-
is_enabled : bool;
12
-
(** Whether the vacation response is active. *)
13
-
from_date : Ptime.t option;
14
-
(** When to start sending responses. *)
15
-
to_date : Ptime.t option;
16
-
(** When to stop sending responses. *)
17
-
subject : string option;
18
-
(** Subject for the auto-reply. *)
19
-
text_body : string option;
20
-
(** Plain text body. *)
21
-
html_body : string option;
22
-
(** HTML body. *)
23
-
}
24
-
25
-
val id : t -> Jmap_proto.Id.t
26
-
val is_enabled : t -> bool
27
-
val from_date : t -> Ptime.t option
28
-
val to_date : t -> Ptime.t option
29
-
val subject : t -> string option
30
-
val text_body : t -> string option
31
-
val html_body : t -> string option
32
-
33
-
val jsont : t Jsont.t
34
-
35
-
(** The singleton id for VacationResponse. *)
36
-
val singleton_id : Jmap_proto.Id.t
-316
proto/method_.ml
-316
proto/method_.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(* Foo/get *)
7
-
8
-
type get_args = {
9
-
account_id : Id.t;
10
-
ids : Id.t list option;
11
-
properties : string list option;
12
-
}
13
-
14
-
let get_args ~account_id ?ids ?properties () =
15
-
{ account_id; ids; properties }
16
-
17
-
let get_args_make account_id ids properties =
18
-
{ account_id; ids; properties }
19
-
20
-
let get_args_jsont =
21
-
let kind = "GetArgs" in
22
-
Jsont.Object.map ~kind get_args_make
23
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:(fun a -> a.account_id)
24
-
|> Jsont.Object.opt_mem "ids" (Jsont.list Id.jsont) ~enc:(fun a -> a.ids)
25
-
|> Jsont.Object.opt_mem "properties" (Jsont.list Jsont.string) ~enc:(fun a -> a.properties)
26
-
|> Jsont.Object.finish
27
-
28
-
type 'a get_response = {
29
-
account_id : Id.t;
30
-
state : string;
31
-
list : 'a list;
32
-
not_found : Id.t list;
33
-
}
34
-
35
-
let get_response_jsont (type a) (obj_jsont : a Jsont.t) : a get_response Jsont.t =
36
-
let kind = "GetResponse" in
37
-
let make account_id state list not_found =
38
-
{ account_id; state; list; not_found }
39
-
in
40
-
Jsont.Object.map ~kind make
41
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:(fun r -> r.account_id)
42
-
|> Jsont.Object.mem "state" Jsont.string ~enc:(fun r -> r.state)
43
-
|> Jsont.Object.mem "list" (Jsont.list obj_jsont) ~enc:(fun r -> r.list)
44
-
|> Jsont.Object.mem "notFound" (Jsont.list Id.jsont) ~enc:(fun r -> r.not_found)
45
-
|> Jsont.Object.finish
46
-
47
-
(* Foo/changes *)
48
-
49
-
type changes_args = {
50
-
account_id : Id.t;
51
-
since_state : string;
52
-
max_changes : int64 option;
53
-
}
54
-
55
-
let changes_args ~account_id ~since_state ?max_changes () =
56
-
{ account_id; since_state; max_changes }
57
-
58
-
let changes_args_make account_id since_state max_changes =
59
-
{ account_id; since_state; max_changes }
60
-
61
-
let changes_args_jsont =
62
-
let kind = "ChangesArgs" in
63
-
Jsont.Object.map ~kind changes_args_make
64
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:(fun a -> a.account_id)
65
-
|> Jsont.Object.mem "sinceState" Jsont.string ~enc:(fun a -> a.since_state)
66
-
|> Jsont.Object.opt_mem "maxChanges" Int53.Unsigned.jsont ~enc:(fun a -> a.max_changes)
67
-
|> Jsont.Object.finish
68
-
69
-
type changes_response = {
70
-
account_id : Id.t;
71
-
old_state : string;
72
-
new_state : string;
73
-
has_more_changes : bool;
74
-
created : Id.t list;
75
-
updated : Id.t list;
76
-
destroyed : Id.t list;
77
-
}
78
-
79
-
let changes_response_make account_id old_state new_state has_more_changes
80
-
created updated destroyed =
81
-
{ account_id; old_state; new_state; has_more_changes; created; updated; destroyed }
82
-
83
-
let changes_response_jsont =
84
-
let kind = "ChangesResponse" in
85
-
Jsont.Object.map ~kind changes_response_make
86
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:(fun r -> r.account_id)
87
-
|> Jsont.Object.mem "oldState" Jsont.string ~enc:(fun r -> r.old_state)
88
-
|> Jsont.Object.mem "newState" Jsont.string ~enc:(fun r -> r.new_state)
89
-
|> Jsont.Object.mem "hasMoreChanges" Jsont.bool ~enc:(fun r -> r.has_more_changes)
90
-
|> Jsont.Object.mem "created" (Jsont.list Id.jsont) ~enc:(fun r -> r.created)
91
-
|> Jsont.Object.mem "updated" (Jsont.list Id.jsont) ~enc:(fun r -> r.updated)
92
-
|> Jsont.Object.mem "destroyed" (Jsont.list Id.jsont) ~enc:(fun r -> r.destroyed)
93
-
|> Jsont.Object.finish
94
-
95
-
(* Foo/set *)
96
-
97
-
type 'a set_args = {
98
-
account_id : Id.t;
99
-
if_in_state : string option;
100
-
create : (Id.t * 'a) list option;
101
-
update : (Id.t * Jsont.json) list option;
102
-
destroy : Id.t list option;
103
-
}
104
-
105
-
let set_args ~account_id ?if_in_state ?create ?update ?destroy () =
106
-
{ account_id; if_in_state; create; update; destroy }
107
-
108
-
let set_args_jsont (type a) (obj_jsont : a Jsont.t) : a set_args Jsont.t =
109
-
let kind = "SetArgs" in
110
-
let make account_id if_in_state create update destroy =
111
-
{ account_id; if_in_state; create; update; destroy }
112
-
in
113
-
Jsont.Object.map ~kind make
114
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:(fun a -> a.account_id)
115
-
|> Jsont.Object.opt_mem "ifInState" Jsont.string ~enc:(fun a -> a.if_in_state)
116
-
|> Jsont.Object.opt_mem "create" (Json_map.of_id obj_jsont) ~enc:(fun a -> a.create)
117
-
|> Jsont.Object.opt_mem "update" (Json_map.of_id Jsont.json) ~enc:(fun a -> a.update)
118
-
|> Jsont.Object.opt_mem "destroy" (Jsont.list Id.jsont) ~enc:(fun a -> a.destroy)
119
-
|> Jsont.Object.finish
120
-
121
-
type 'a set_response = {
122
-
account_id : Id.t;
123
-
old_state : string option;
124
-
new_state : string;
125
-
created : (Id.t * 'a) list option;
126
-
updated : (Id.t * 'a option) list option;
127
-
destroyed : Id.t list option;
128
-
not_created : (Id.t * Error.set_error) list option;
129
-
not_updated : (Id.t * Error.set_error) list option;
130
-
not_destroyed : (Id.t * Error.set_error) list option;
131
-
}
132
-
133
-
let set_response_jsont (type a) (obj_jsont : a Jsont.t) : a set_response Jsont.t =
134
-
let kind = "SetResponse" in
135
-
let make account_id old_state new_state created updated destroyed
136
-
not_created not_updated not_destroyed =
137
-
{ account_id; old_state; new_state; created; updated; destroyed;
138
-
not_created; not_updated; not_destroyed }
139
-
in
140
-
(* For updated values, the server may return null or an object *)
141
-
let nullable_obj = Jsont.(some obj_jsont) in
142
-
Jsont.Object.map ~kind make
143
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:(fun r -> r.account_id)
144
-
|> Jsont.Object.opt_mem "oldState" Jsont.string ~enc:(fun r -> r.old_state)
145
-
|> Jsont.Object.mem "newState" Jsont.string ~enc:(fun r -> r.new_state)
146
-
|> Jsont.Object.opt_mem "created" (Json_map.of_id obj_jsont) ~enc:(fun r -> r.created)
147
-
|> Jsont.Object.opt_mem "updated" (Json_map.of_id nullable_obj) ~enc:(fun r -> r.updated)
148
-
|> Jsont.Object.opt_mem "destroyed" (Jsont.list Id.jsont) ~enc:(fun r -> r.destroyed)
149
-
|> Jsont.Object.opt_mem "notCreated" (Json_map.of_id Error.set_error_jsont) ~enc:(fun r -> r.not_created)
150
-
|> Jsont.Object.opt_mem "notUpdated" (Json_map.of_id Error.set_error_jsont) ~enc:(fun r -> r.not_updated)
151
-
|> Jsont.Object.opt_mem "notDestroyed" (Json_map.of_id Error.set_error_jsont) ~enc:(fun r -> r.not_destroyed)
152
-
|> Jsont.Object.finish
153
-
154
-
(* Foo/copy *)
155
-
156
-
type 'a copy_args = {
157
-
from_account_id : Id.t;
158
-
if_from_in_state : string option;
159
-
account_id : Id.t;
160
-
if_in_state : string option;
161
-
create : (Id.t * 'a) list;
162
-
on_success_destroy_original : bool;
163
-
destroy_from_if_in_state : string option;
164
-
}
165
-
166
-
let copy_args_jsont (type a) (obj_jsont : a Jsont.t) : a copy_args Jsont.t =
167
-
let kind = "CopyArgs" in
168
-
let make from_account_id if_from_in_state account_id if_in_state create
169
-
on_success_destroy_original destroy_from_if_in_state =
170
-
{ from_account_id; if_from_in_state; account_id; if_in_state; create;
171
-
on_success_destroy_original; destroy_from_if_in_state }
172
-
in
173
-
Jsont.Object.map ~kind make
174
-
|> Jsont.Object.mem "fromAccountId" Id.jsont ~enc:(fun a -> a.from_account_id)
175
-
|> Jsont.Object.opt_mem "ifFromInState" Jsont.string ~enc:(fun a -> a.if_from_in_state)
176
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:(fun a -> a.account_id)
177
-
|> Jsont.Object.opt_mem "ifInState" Jsont.string ~enc:(fun a -> a.if_in_state)
178
-
|> Jsont.Object.mem "create" (Json_map.of_id obj_jsont) ~enc:(fun a -> a.create)
179
-
|> Jsont.Object.mem "onSuccessDestroyOriginal" Jsont.bool ~dec_absent:false
180
-
~enc:(fun a -> a.on_success_destroy_original)
181
-
~enc_omit:(fun b -> not b)
182
-
|> Jsont.Object.opt_mem "destroyFromIfInState" Jsont.string ~enc:(fun a -> a.destroy_from_if_in_state)
183
-
|> Jsont.Object.finish
184
-
185
-
type 'a copy_response = {
186
-
from_account_id : Id.t;
187
-
account_id : Id.t;
188
-
old_state : string option;
189
-
new_state : string;
190
-
created : (Id.t * 'a) list option;
191
-
not_created : (Id.t * Error.set_error) list option;
192
-
}
193
-
194
-
let copy_response_jsont (type a) (obj_jsont : a Jsont.t) : a copy_response Jsont.t =
195
-
let kind = "CopyResponse" in
196
-
let make from_account_id account_id old_state new_state created not_created =
197
-
{ from_account_id; account_id; old_state; new_state; created; not_created }
198
-
in
199
-
Jsont.Object.map ~kind make
200
-
|> Jsont.Object.mem "fromAccountId" Id.jsont ~enc:(fun r -> r.from_account_id)
201
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:(fun r -> r.account_id)
202
-
|> Jsont.Object.opt_mem "oldState" Jsont.string ~enc:(fun r -> r.old_state)
203
-
|> Jsont.Object.mem "newState" Jsont.string ~enc:(fun r -> r.new_state)
204
-
|> Jsont.Object.opt_mem "created" (Json_map.of_id obj_jsont) ~enc:(fun r -> r.created)
205
-
|> Jsont.Object.opt_mem "notCreated" (Json_map.of_id Error.set_error_jsont) ~enc:(fun r -> r.not_created)
206
-
|> Jsont.Object.finish
207
-
208
-
(* Foo/query *)
209
-
210
-
type 'filter query_args = {
211
-
account_id : Id.t;
212
-
filter : 'filter Filter.filter option;
213
-
sort : Filter.comparator list option;
214
-
position : int64;
215
-
anchor : Id.t option;
216
-
anchor_offset : int64;
217
-
limit : int64 option;
218
-
calculate_total : bool;
219
-
}
220
-
221
-
let query_args ~account_id ?filter ?sort ?(position = 0L) ?anchor
222
-
?(anchor_offset = 0L) ?limit ?(calculate_total = false) () =
223
-
{ account_id; filter; sort; position; anchor; anchor_offset; limit; calculate_total }
224
-
225
-
let query_args_jsont (type f) (filter_cond_jsont : f Jsont.t) : f query_args Jsont.t =
226
-
let kind = "QueryArgs" in
227
-
let make account_id filter sort position anchor anchor_offset limit calculate_total =
228
-
{ account_id; filter; sort; position; anchor; anchor_offset; limit; calculate_total }
229
-
in
230
-
Jsont.Object.map ~kind make
231
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:(fun a -> a.account_id)
232
-
|> Jsont.Object.opt_mem "filter" (Filter.filter_jsont filter_cond_jsont) ~enc:(fun a -> a.filter)
233
-
|> Jsont.Object.opt_mem "sort" (Jsont.list Filter.comparator_jsont) ~enc:(fun a -> a.sort)
234
-
|> Jsont.Object.mem "position" Int53.Signed.jsont ~dec_absent:0L ~enc:(fun a -> a.position)
235
-
~enc_omit:(fun p -> p = 0L)
236
-
|> Jsont.Object.opt_mem "anchor" Id.jsont ~enc:(fun a -> a.anchor)
237
-
|> Jsont.Object.mem "anchorOffset" Int53.Signed.jsont ~dec_absent:0L ~enc:(fun a -> a.anchor_offset)
238
-
~enc_omit:(fun o -> o = 0L)
239
-
|> Jsont.Object.opt_mem "limit" Int53.Unsigned.jsont ~enc:(fun a -> a.limit)
240
-
|> Jsont.Object.mem "calculateTotal" Jsont.bool ~dec_absent:false ~enc:(fun a -> a.calculate_total)
241
-
~enc_omit:(fun b -> not b)
242
-
|> Jsont.Object.finish
243
-
244
-
type query_response = {
245
-
account_id : Id.t;
246
-
query_state : string;
247
-
can_calculate_changes : bool;
248
-
position : int64;
249
-
ids : Id.t list;
250
-
total : int64 option;
251
-
}
252
-
253
-
let query_response_make account_id query_state can_calculate_changes position ids total =
254
-
{ account_id; query_state; can_calculate_changes; position; ids; total }
255
-
256
-
let query_response_jsont =
257
-
let kind = "QueryResponse" in
258
-
Jsont.Object.map ~kind query_response_make
259
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:(fun r -> r.account_id)
260
-
|> Jsont.Object.mem "queryState" Jsont.string ~enc:(fun r -> r.query_state)
261
-
|> Jsont.Object.mem "canCalculateChanges" Jsont.bool ~enc:(fun r -> r.can_calculate_changes)
262
-
|> Jsont.Object.mem "position" Int53.Unsigned.jsont ~enc:(fun r -> r.position)
263
-
|> Jsont.Object.mem "ids" (Jsont.list Id.jsont) ~enc:(fun r -> r.ids)
264
-
|> Jsont.Object.opt_mem "total" Int53.Unsigned.jsont ~enc:(fun r -> r.total)
265
-
|> Jsont.Object.finish
266
-
267
-
(* Foo/queryChanges *)
268
-
269
-
type 'filter query_changes_args = {
270
-
account_id : Id.t;
271
-
filter : 'filter Filter.filter option;
272
-
sort : Filter.comparator list option;
273
-
since_query_state : string;
274
-
max_changes : int64 option;
275
-
up_to_id : Id.t option;
276
-
calculate_total : bool;
277
-
}
278
-
279
-
let query_changes_args_jsont (type f) (filter_cond_jsont : f Jsont.t) : f query_changes_args Jsont.t =
280
-
let kind = "QueryChangesArgs" in
281
-
let make account_id filter sort since_query_state max_changes up_to_id calculate_total =
282
-
{ account_id; filter; sort; since_query_state; max_changes; up_to_id; calculate_total }
283
-
in
284
-
Jsont.Object.map ~kind make
285
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:(fun a -> a.account_id)
286
-
|> Jsont.Object.opt_mem "filter" (Filter.filter_jsont filter_cond_jsont) ~enc:(fun a -> a.filter)
287
-
|> Jsont.Object.opt_mem "sort" (Jsont.list Filter.comparator_jsont) ~enc:(fun a -> a.sort)
288
-
|> Jsont.Object.mem "sinceQueryState" Jsont.string ~enc:(fun a -> a.since_query_state)
289
-
|> Jsont.Object.opt_mem "maxChanges" Int53.Unsigned.jsont ~enc:(fun a -> a.max_changes)
290
-
|> Jsont.Object.opt_mem "upToId" Id.jsont ~enc:(fun a -> a.up_to_id)
291
-
|> Jsont.Object.mem "calculateTotal" Jsont.bool ~dec_absent:false ~enc:(fun a -> a.calculate_total)
292
-
~enc_omit:(fun b -> not b)
293
-
|> Jsont.Object.finish
294
-
295
-
type query_changes_response = {
296
-
account_id : Id.t;
297
-
old_query_state : string;
298
-
new_query_state : string;
299
-
total : int64 option;
300
-
removed : Id.t list;
301
-
added : Filter.added_item list;
302
-
}
303
-
304
-
let query_changes_response_make account_id old_query_state new_query_state total removed added =
305
-
{ account_id; old_query_state; new_query_state; total; removed; added }
306
-
307
-
let query_changes_response_jsont =
308
-
let kind = "QueryChangesResponse" in
309
-
Jsont.Object.map ~kind query_changes_response_make
310
-
|> Jsont.Object.mem "accountId" Id.jsont ~enc:(fun r -> r.account_id)
311
-
|> Jsont.Object.mem "oldQueryState" Jsont.string ~enc:(fun r -> r.old_query_state)
312
-
|> Jsont.Object.mem "newQueryState" Jsont.string ~enc:(fun r -> r.new_query_state)
313
-
|> Jsont.Object.opt_mem "total" Int53.Unsigned.jsont ~enc:(fun r -> r.total)
314
-
|> Jsont.Object.mem "removed" (Jsont.list Id.jsont) ~enc:(fun r -> r.removed)
315
-
|> Jsont.Object.mem "added" (Jsont.list Filter.added_item_jsont) ~enc:(fun r -> r.added)
316
-
|> Jsont.Object.finish
-215
proto/method_.mli
-215
proto/method_.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP standard method types as defined in RFC 8620 Section 5 *)
7
-
8
-
(** {1 Foo/get} *)
9
-
10
-
(** Arguments for /get methods. *)
11
-
type get_args = {
12
-
account_id : Id.t;
13
-
(** The account to fetch from. *)
14
-
ids : Id.t list option;
15
-
(** The ids to fetch. [None] means fetch all. *)
16
-
properties : string list option;
17
-
(** Properties to include. [None] means all. *)
18
-
}
19
-
20
-
val get_args :
21
-
account_id:Id.t ->
22
-
?ids:Id.t list ->
23
-
?properties:string list ->
24
-
unit ->
25
-
get_args
26
-
27
-
val get_args_jsont : get_args Jsont.t
28
-
29
-
(** Response for /get methods. *)
30
-
type 'a get_response = {
31
-
account_id : Id.t;
32
-
(** The account fetched from. *)
33
-
state : string;
34
-
(** Current state string. *)
35
-
list : 'a list;
36
-
(** The objects fetched. *)
37
-
not_found : Id.t list;
38
-
(** Ids that were not found. *)
39
-
}
40
-
41
-
val get_response_jsont : 'a Jsont.t -> 'a get_response Jsont.t
42
-
43
-
(** {1 Foo/changes} *)
44
-
45
-
(** Arguments for /changes methods. *)
46
-
type changes_args = {
47
-
account_id : Id.t;
48
-
since_state : string;
49
-
max_changes : int64 option;
50
-
}
51
-
52
-
val changes_args :
53
-
account_id:Id.t ->
54
-
since_state:string ->
55
-
?max_changes:int64 ->
56
-
unit ->
57
-
changes_args
58
-
59
-
val changes_args_jsont : changes_args Jsont.t
60
-
61
-
(** Response for /changes methods. *)
62
-
type changes_response = {
63
-
account_id : Id.t;
64
-
old_state : string;
65
-
new_state : string;
66
-
has_more_changes : bool;
67
-
created : Id.t list;
68
-
updated : Id.t list;
69
-
destroyed : Id.t list;
70
-
}
71
-
72
-
val changes_response_jsont : changes_response Jsont.t
73
-
74
-
(** {1 Foo/set} *)
75
-
76
-
(** Arguments for /set methods.
77
-
78
-
The ['a] type parameter is the object type being created/updated. *)
79
-
type 'a set_args = {
80
-
account_id : Id.t;
81
-
if_in_state : string option;
82
-
(** If set, only apply if current state matches. *)
83
-
create : (Id.t * 'a) list option;
84
-
(** Objects to create, keyed by temporary id. *)
85
-
update : (Id.t * Jsont.json) list option;
86
-
(** Objects to update. Value is a PatchObject. *)
87
-
destroy : Id.t list option;
88
-
(** Ids to destroy. *)
89
-
}
90
-
91
-
val set_args :
92
-
account_id:Id.t ->
93
-
?if_in_state:string ->
94
-
?create:(Id.t * 'a) list ->
95
-
?update:(Id.t * Jsont.json) list ->
96
-
?destroy:Id.t list ->
97
-
unit ->
98
-
'a set_args
99
-
100
-
val set_args_jsont : 'a Jsont.t -> 'a set_args Jsont.t
101
-
102
-
(** Response for /set methods. *)
103
-
type 'a set_response = {
104
-
account_id : Id.t;
105
-
old_state : string option;
106
-
new_state : string;
107
-
created : (Id.t * 'a) list option;
108
-
(** Successfully created objects, keyed by temporary id. *)
109
-
updated : (Id.t * 'a option) list option;
110
-
(** Successfully updated objects. Value may include server-set properties. *)
111
-
destroyed : Id.t list option;
112
-
(** Successfully destroyed ids. *)
113
-
not_created : (Id.t * Error.set_error) list option;
114
-
(** Failed creates. *)
115
-
not_updated : (Id.t * Error.set_error) list option;
116
-
(** Failed updates. *)
117
-
not_destroyed : (Id.t * Error.set_error) list option;
118
-
(** Failed destroys. *)
119
-
}
120
-
121
-
val set_response_jsont : 'a Jsont.t -> 'a set_response Jsont.t
122
-
123
-
(** {1 Foo/copy} *)
124
-
125
-
(** Arguments for /copy methods. *)
126
-
type 'a copy_args = {
127
-
from_account_id : Id.t;
128
-
if_from_in_state : string option;
129
-
account_id : Id.t;
130
-
if_in_state : string option;
131
-
create : (Id.t * 'a) list;
132
-
on_success_destroy_original : bool;
133
-
destroy_from_if_in_state : string option;
134
-
}
135
-
136
-
val copy_args_jsont : 'a Jsont.t -> 'a copy_args Jsont.t
137
-
138
-
(** Response for /copy methods. *)
139
-
type 'a copy_response = {
140
-
from_account_id : Id.t;
141
-
account_id : Id.t;
142
-
old_state : string option;
143
-
new_state : string;
144
-
created : (Id.t * 'a) list option;
145
-
not_created : (Id.t * Error.set_error) list option;
146
-
}
147
-
148
-
val copy_response_jsont : 'a Jsont.t -> 'a copy_response Jsont.t
149
-
150
-
(** {1 Foo/query} *)
151
-
152
-
(** Arguments for /query methods. *)
153
-
type 'filter query_args = {
154
-
account_id : Id.t;
155
-
filter : 'filter Filter.filter option;
156
-
sort : Filter.comparator list option;
157
-
position : int64;
158
-
anchor : Id.t option;
159
-
anchor_offset : int64;
160
-
limit : int64 option;
161
-
calculate_total : bool;
162
-
}
163
-
164
-
val query_args :
165
-
account_id:Id.t ->
166
-
?filter:'filter Filter.filter ->
167
-
?sort:Filter.comparator list ->
168
-
?position:int64 ->
169
-
?anchor:Id.t ->
170
-
?anchor_offset:int64 ->
171
-
?limit:int64 ->
172
-
?calculate_total:bool ->
173
-
unit ->
174
-
'filter query_args
175
-
176
-
val query_args_jsont : 'filter Jsont.t -> 'filter query_args Jsont.t
177
-
178
-
(** Response for /query methods. *)
179
-
type query_response = {
180
-
account_id : Id.t;
181
-
query_state : string;
182
-
can_calculate_changes : bool;
183
-
position : int64;
184
-
ids : Id.t list;
185
-
total : int64 option;
186
-
}
187
-
188
-
val query_response_jsont : query_response Jsont.t
189
-
190
-
(** {1 Foo/queryChanges} *)
191
-
192
-
(** Arguments for /queryChanges methods. *)
193
-
type 'filter query_changes_args = {
194
-
account_id : Id.t;
195
-
filter : 'filter Filter.filter option;
196
-
sort : Filter.comparator list option;
197
-
since_query_state : string;
198
-
max_changes : int64 option;
199
-
up_to_id : Id.t option;
200
-
calculate_total : bool;
201
-
}
202
-
203
-
val query_changes_args_jsont : 'filter Jsont.t -> 'filter query_changes_args Jsont.t
204
-
205
-
(** Response for /queryChanges methods. *)
206
-
type query_changes_response = {
207
-
account_id : Id.t;
208
-
old_query_state : string;
209
-
new_query_state : string;
210
-
total : int64 option;
211
-
removed : Id.t list;
212
-
added : Filter.added_item list;
213
-
}
214
-
215
-
val query_changes_response_jsont : query_changes_response Jsont.t
-132
proto/push.ml
-132
proto/push.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
module State_change = struct
7
-
type type_state = {
8
-
type_name : string;
9
-
state : string;
10
-
}
11
-
12
-
type t = {
13
-
type_ : string;
14
-
changed : (Id.t * type_state list) list;
15
-
}
16
-
17
-
(* The changed object is account_id -> { typeName: state } *)
18
-
let changed_jsont =
19
-
let kind = "Changed" in
20
-
(* Inner is type -> state string map *)
21
-
let type_states_jsont = Json_map.of_string Jsont.string in
22
-
(* Convert list of (string * string) to type_state list *)
23
-
let decode_type_states pairs =
24
-
List.map (fun (type_name, state) -> { type_name; state }) pairs
25
-
in
26
-
let encode_type_states states =
27
-
List.map (fun ts -> (ts.type_name, ts.state)) states
28
-
in
29
-
Json_map.of_id
30
-
(Jsont.map ~kind ~dec:decode_type_states ~enc:encode_type_states type_states_jsont)
31
-
32
-
let make type_ changed = { type_; changed }
33
-
34
-
let jsont =
35
-
let kind = "StateChange" in
36
-
Jsont.Object.map ~kind make
37
-
|> Jsont.Object.mem "@type" Jsont.string ~enc:(fun t -> t.type_)
38
-
|> Jsont.Object.mem "changed" changed_jsont ~enc:(fun t -> t.changed)
39
-
|> Jsont.Object.finish
40
-
end
41
-
42
-
type push_keys = {
43
-
p256dh : string;
44
-
auth : string;
45
-
}
46
-
47
-
let push_keys_make p256dh auth = { p256dh; auth }
48
-
49
-
let push_keys_jsont =
50
-
let kind = "PushKeys" in
51
-
Jsont.Object.map ~kind push_keys_make
52
-
|> Jsont.Object.mem "p256dh" Jsont.string ~enc:(fun k -> k.p256dh)
53
-
|> Jsont.Object.mem "auth" Jsont.string ~enc:(fun k -> k.auth)
54
-
|> Jsont.Object.finish
55
-
56
-
type t = {
57
-
id : Id.t;
58
-
device_client_id : string;
59
-
url : string;
60
-
keys : push_keys option;
61
-
verification_code : string option;
62
-
expires : Ptime.t option;
63
-
types : string list option;
64
-
}
65
-
66
-
let id t = t.id
67
-
let device_client_id t = t.device_client_id
68
-
let url t = t.url
69
-
let keys t = t.keys
70
-
let verification_code t = t.verification_code
71
-
let expires t = t.expires
72
-
let types t = t.types
73
-
74
-
let make id device_client_id url keys verification_code expires types =
75
-
{ id; device_client_id; url; keys; verification_code; expires; types }
76
-
77
-
let jsont =
78
-
let kind = "PushSubscription" in
79
-
Jsont.Object.map ~kind make
80
-
|> Jsont.Object.mem "id" Id.jsont ~enc:id
81
-
|> Jsont.Object.mem "deviceClientId" Jsont.string ~enc:device_client_id
82
-
|> Jsont.Object.mem "url" Jsont.string ~enc:url
83
-
|> Jsont.Object.opt_mem "keys" push_keys_jsont ~enc:keys
84
-
|> Jsont.Object.opt_mem "verificationCode" Jsont.string ~enc:verification_code
85
-
|> Jsont.Object.opt_mem "expires" Date.Utc.jsont ~enc:expires
86
-
|> Jsont.Object.opt_mem "types" (Jsont.list Jsont.string) ~enc:types
87
-
|> Jsont.Object.finish
88
-
89
-
let get_args_jsont = Method_.get_args_jsont
90
-
let get_response_jsont = Method_.get_response_jsont jsont
91
-
92
-
type create_args = {
93
-
device_client_id : string;
94
-
url : string;
95
-
keys : push_keys option;
96
-
verification_code : string option;
97
-
types : string list option;
98
-
}
99
-
100
-
let create_args_make device_client_id url keys verification_code types =
101
-
{ device_client_id; url; keys; verification_code; types }
102
-
103
-
let create_args_jsont =
104
-
let kind = "PushSubscription create" in
105
-
Jsont.Object.map ~kind create_args_make
106
-
|> Jsont.Object.mem "deviceClientId" Jsont.string ~enc:(fun a -> a.device_client_id)
107
-
|> Jsont.Object.mem "url" Jsont.string ~enc:(fun a -> a.url)
108
-
|> Jsont.Object.opt_mem "keys" push_keys_jsont ~enc:(fun a -> a.keys)
109
-
|> Jsont.Object.opt_mem "verificationCode" Jsont.string ~enc:(fun a -> a.verification_code)
110
-
|> Jsont.Object.opt_mem "types" (Jsont.list Jsont.string) ~enc:(fun a -> a.types)
111
-
|> Jsont.Object.finish
112
-
113
-
type set_args = {
114
-
account_id : Id.t option;
115
-
if_in_state : string option;
116
-
create : (Id.t * create_args) list option;
117
-
update : (Id.t * Jsont.json) list option;
118
-
destroy : Id.t list option;
119
-
}
120
-
121
-
let set_args_make account_id if_in_state create update destroy =
122
-
{ account_id; if_in_state; create; update; destroy }
123
-
124
-
let set_args_jsont =
125
-
let kind = "PushSubscription/set args" in
126
-
Jsont.Object.map ~kind set_args_make
127
-
|> Jsont.Object.opt_mem "accountId" Id.jsont ~enc:(fun a -> a.account_id)
128
-
|> Jsont.Object.opt_mem "ifInState" Jsont.string ~enc:(fun a -> a.if_in_state)
129
-
|> Jsont.Object.opt_mem "create" (Json_map.of_id create_args_jsont) ~enc:(fun a -> a.create)
130
-
|> Jsont.Object.opt_mem "update" (Json_map.of_id Jsont.json) ~enc:(fun a -> a.update)
131
-
|> Jsont.Object.opt_mem "destroy" (Jsont.list Id.jsont) ~enc:(fun a -> a.destroy)
132
-
|> Jsont.Object.finish
-96
proto/push.mli
-96
proto/push.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP push types as defined in RFC 8620 Section 7 *)
7
-
8
-
(** {1 StateChange} *)
9
-
10
-
(** A state change notification for push. *)
11
-
module State_change : sig
12
-
type type_state = {
13
-
type_name : string;
14
-
(** The data type that changed (e.g., "Email", "Mailbox"). *)
15
-
state : string;
16
-
(** The new state string for this type. *)
17
-
}
18
-
19
-
type t = {
20
-
type_ : string;
21
-
(** Always "StateChange". *)
22
-
changed : (Id.t * type_state list) list;
23
-
(** Map of account id to list of type state changes. *)
24
-
}
25
-
26
-
val jsont : t Jsont.t
27
-
end
28
-
29
-
(** {1 PushSubscription} *)
30
-
31
-
(** Web push subscription keys. *)
32
-
type push_keys = {
33
-
p256dh : string;
34
-
(** P-256 ECDH public key as URL-safe base64. *)
35
-
auth : string;
36
-
(** Authentication secret as URL-safe base64. *)
37
-
}
38
-
39
-
val push_keys_jsont : push_keys Jsont.t
40
-
41
-
(** A push subscription object. *)
42
-
type t = {
43
-
id : Id.t;
44
-
(** Server-assigned subscription id. *)
45
-
device_client_id : string;
46
-
(** Client-provided device identifier. *)
47
-
url : string;
48
-
(** The push endpoint URL. *)
49
-
keys : push_keys option;
50
-
(** Optional encryption keys for Web Push. *)
51
-
verification_code : string option;
52
-
(** Code for verifying subscription ownership. *)
53
-
expires : Ptime.t option;
54
-
(** When the subscription expires. *)
55
-
types : string list option;
56
-
(** Data types to receive notifications for. [None] means all. *)
57
-
}
58
-
59
-
val id : t -> Id.t
60
-
val device_client_id : t -> string
61
-
val url : t -> string
62
-
val keys : t -> push_keys option
63
-
val verification_code : t -> string option
64
-
val expires : t -> Ptime.t option
65
-
val types : t -> string list option
66
-
67
-
val jsont : t Jsont.t
68
-
(** JSON codec for PushSubscription. *)
69
-
70
-
(** {1 PushSubscription Methods} *)
71
-
72
-
(** Arguments for PushSubscription/get. *)
73
-
val get_args_jsont : Method_.get_args Jsont.t
74
-
75
-
(** Response for PushSubscription/get. *)
76
-
val get_response_jsont : t Method_.get_response Jsont.t
77
-
78
-
(** Arguments for PushSubscription/set. *)
79
-
type set_args = {
80
-
account_id : Id.t option;
81
-
(** Not used for PushSubscription. *)
82
-
if_in_state : string option;
83
-
create : (Id.t * create_args) list option;
84
-
update : (Id.t * Jsont.json) list option;
85
-
destroy : Id.t list option;
86
-
}
87
-
88
-
and create_args = {
89
-
device_client_id : string;
90
-
url : string;
91
-
keys : push_keys option;
92
-
verification_code : string option;
93
-
types : string list option;
94
-
}
95
-
96
-
val set_args_jsont : set_args Jsont.t
-34
proto/request.ml
-34
proto/request.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = {
7
-
using : string list;
8
-
method_calls : Invocation.t list;
9
-
created_ids : (Id.t * Id.t) list option;
10
-
}
11
-
12
-
let create ~using ~method_calls ?created_ids () =
13
-
{ using; method_calls; created_ids }
14
-
15
-
let using t = t.using
16
-
let method_calls t = t.method_calls
17
-
let created_ids t = t.created_ids
18
-
19
-
let make using method_calls created_ids =
20
-
{ using; method_calls; created_ids }
21
-
22
-
let jsont =
23
-
let kind = "Request" in
24
-
Jsont.Object.map ~kind make
25
-
|> Jsont.Object.mem "using" (Jsont.list Jsont.string) ~enc:using
26
-
|> Jsont.Object.mem "methodCalls" (Jsont.list Invocation.jsont) ~enc:method_calls
27
-
|> Jsont.Object.opt_mem "createdIds" (Json_map.of_id Id.jsont) ~enc:created_ids
28
-
|> Jsont.Object.finish
29
-
30
-
let single ~using invocation =
31
-
{ using; method_calls = [invocation]; created_ids = None }
32
-
33
-
let batch ~using invocations =
34
-
{ using; method_calls = invocations; created_ids = None }
-45
proto/request.mli
-45
proto/request.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP request object as defined in RFC 8620 Section 3.3 *)
7
-
8
-
type t = {
9
-
using : string list;
10
-
(** Capability URIs required for this request. *)
11
-
method_calls : Invocation.t list;
12
-
(** The method calls to execute. *)
13
-
created_ids : (Id.t * Id.t) list option;
14
-
(** Map of client-created temporary ids to server-assigned ids.
15
-
Used for result references in batch operations. *)
16
-
}
17
-
18
-
val create :
19
-
using:string list ->
20
-
method_calls:Invocation.t list ->
21
-
?created_ids:(Id.t * Id.t) list ->
22
-
unit ->
23
-
t
24
-
(** [create ~using ~method_calls ?created_ids ()] creates a JMAP request. *)
25
-
26
-
val using : t -> string list
27
-
val method_calls : t -> Invocation.t list
28
-
val created_ids : t -> (Id.t * Id.t) list option
29
-
30
-
val jsont : t Jsont.t
31
-
(** JSON codec for JMAP requests. *)
32
-
33
-
(** {1 Request Builders} *)
34
-
35
-
val single :
36
-
using:string list ->
37
-
Invocation.t ->
38
-
t
39
-
(** [single ~using invocation] creates a request with a single method call. *)
40
-
41
-
val batch :
42
-
using:string list ->
43
-
Invocation.t list ->
44
-
t
45
-
(** [batch ~using invocations] creates a request with multiple method calls. *)
-46
proto/response.ml
-46
proto/response.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = {
7
-
method_responses : Invocation.t list;
8
-
created_ids : (Id.t * Id.t) list option;
9
-
session_state : string;
10
-
}
11
-
12
-
let method_responses t = t.method_responses
13
-
let created_ids t = t.created_ids
14
-
let session_state t = t.session_state
15
-
16
-
let make method_responses created_ids session_state =
17
-
{ method_responses; created_ids; session_state }
18
-
19
-
let jsont =
20
-
let kind = "Response" in
21
-
Jsont.Object.map ~kind make
22
-
|> Jsont.Object.mem "methodResponses" (Jsont.list Invocation.jsont) ~enc:method_responses
23
-
|> Jsont.Object.opt_mem "createdIds" (Json_map.of_id Id.jsont) ~enc:created_ids
24
-
|> Jsont.Object.mem "sessionState" Jsont.string ~enc:session_state
25
-
|> Jsont.Object.finish
26
-
27
-
let find_response method_call_id response =
28
-
List.find_opt
29
-
(fun inv -> Invocation.method_call_id inv = method_call_id)
30
-
response.method_responses
31
-
32
-
let get_response method_call_id response =
33
-
match find_response method_call_id response with
34
-
| Some inv -> inv
35
-
| None -> raise Not_found
36
-
37
-
let is_error invocation =
38
-
String.equal (Invocation.name invocation) "error"
39
-
40
-
let get_error invocation =
41
-
if is_error invocation then
42
-
match Jsont.Json.decode' Error.method_error_jsont (Invocation.arguments invocation) with
43
-
| Ok v -> Some v
44
-
| Error _ -> None
45
-
else
46
-
None
-37
proto/response.mli
-37
proto/response.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP response object as defined in RFC 8620 Section 3.4 *)
7
-
8
-
type t = {
9
-
method_responses : Invocation.t list;
10
-
(** The method responses. Each is [methodName, responseArgs, methodCallId]. *)
11
-
created_ids : (Id.t * Id.t) list option;
12
-
(** Map of client-created temporary ids to server-assigned ids. *)
13
-
session_state : string;
14
-
(** Current session state. Changes indicate session data has changed. *)
15
-
}
16
-
17
-
val method_responses : t -> Invocation.t list
18
-
val created_ids : t -> (Id.t * Id.t) list option
19
-
val session_state : t -> string
20
-
21
-
val jsont : t Jsont.t
22
-
(** JSON codec for JMAP responses. *)
23
-
24
-
(** {1 Response Inspection} *)
25
-
26
-
val find_response : string -> t -> Invocation.t option
27
-
(** [find_response method_call_id response] finds the response for a method call. *)
28
-
29
-
val get_response : string -> t -> Invocation.t
30
-
(** [get_response method_call_id response] gets the response for a method call.
31
-
@raise Not_found if not found. *)
32
-
33
-
val is_error : Invocation.t -> bool
34
-
(** [is_error invocation] returns [true] if the invocation is an error response. *)
35
-
36
-
val get_error : Invocation.t -> Error.method_error option
37
-
(** [get_error invocation] returns the error if this is an error response. *)
-96
proto/session.ml
-96
proto/session.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
module Account = struct
7
-
type t = {
8
-
name : string;
9
-
is_personal : bool;
10
-
is_read_only : bool;
11
-
account_capabilities : (string * Jsont.json) list;
12
-
}
13
-
14
-
let name t = t.name
15
-
let is_personal t = t.is_personal
16
-
let is_read_only t = t.is_read_only
17
-
let account_capabilities t = t.account_capabilities
18
-
19
-
let make name is_personal is_read_only account_capabilities =
20
-
{ name; is_personal; is_read_only; account_capabilities }
21
-
22
-
let jsont =
23
-
let kind = "Account" in
24
-
Jsont.Object.map ~kind make
25
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
26
-
|> Jsont.Object.mem "isPersonal" Jsont.bool ~enc:is_personal
27
-
|> Jsont.Object.mem "isReadOnly" Jsont.bool ~enc:is_read_only
28
-
|> Jsont.Object.mem "accountCapabilities" (Json_map.of_string Jsont.json) ~enc:account_capabilities
29
-
|> Jsont.Object.finish
30
-
end
31
-
32
-
type t = {
33
-
capabilities : (string * Jsont.json) list;
34
-
accounts : (Id.t * Account.t) list;
35
-
primary_accounts : (string * Id.t) list;
36
-
username : string;
37
-
api_url : string;
38
-
download_url : string;
39
-
upload_url : string;
40
-
event_source_url : string;
41
-
state : string;
42
-
}
43
-
44
-
let capabilities t = t.capabilities
45
-
let accounts t = t.accounts
46
-
let primary_accounts t = t.primary_accounts
47
-
let username t = t.username
48
-
let api_url t = t.api_url
49
-
let download_url t = t.download_url
50
-
let upload_url t = t.upload_url
51
-
let event_source_url t = t.event_source_url
52
-
let state t = t.state
53
-
54
-
let make capabilities accounts primary_accounts username api_url
55
-
download_url upload_url event_source_url state =
56
-
{ capabilities; accounts; primary_accounts; username; api_url;
57
-
download_url; upload_url; event_source_url; state }
58
-
59
-
let jsont =
60
-
let kind = "Session" in
61
-
Jsont.Object.map ~kind make
62
-
|> Jsont.Object.mem "capabilities" (Json_map.of_string Jsont.json) ~enc:capabilities
63
-
|> Jsont.Object.mem "accounts" (Json_map.of_id Account.jsont) ~enc:accounts
64
-
|> Jsont.Object.mem "primaryAccounts" (Json_map.of_string Id.jsont) ~enc:primary_accounts
65
-
|> Jsont.Object.mem "username" Jsont.string ~enc:username
66
-
|> Jsont.Object.mem "apiUrl" Jsont.string ~enc:api_url
67
-
|> Jsont.Object.mem "downloadUrl" Jsont.string ~enc:download_url
68
-
|> Jsont.Object.mem "uploadUrl" Jsont.string ~enc:upload_url
69
-
|> Jsont.Object.mem "eventSourceUrl" Jsont.string ~enc:event_source_url
70
-
|> Jsont.Object.mem "state" Jsont.string ~enc:state
71
-
|> Jsont.Object.finish
72
-
73
-
let get_account id session =
74
-
List.assoc_opt id session.accounts
75
-
76
-
let primary_account_for capability session =
77
-
List.assoc_opt capability session.primary_accounts
78
-
79
-
let has_capability uri session =
80
-
List.exists (fun (k, _) -> k = uri) session.capabilities
81
-
82
-
let get_core_capability session =
83
-
match List.assoc_opt Capability.core session.capabilities with
84
-
| None -> None
85
-
| Some json ->
86
-
(match Jsont.Json.decode' Capability.Core.jsont json with
87
-
| Ok v -> Some v
88
-
| Error _ -> None)
89
-
90
-
let get_mail_capability session =
91
-
match List.assoc_opt Capability.mail session.capabilities with
92
-
| None -> None
93
-
| Some json ->
94
-
(match Jsont.Json.decode' Capability.Mail.jsont json with
95
-
| Ok v -> Some v
96
-
| Error _ -> None)
-84
proto/session.mli
-84
proto/session.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP session object as defined in RFC 8620 Section 2 *)
7
-
8
-
(** {1 Account} *)
9
-
10
-
(** An account available to the user. *)
11
-
module Account : sig
12
-
type t = {
13
-
name : string;
14
-
(** Human-readable name for the account. *)
15
-
is_personal : bool;
16
-
(** Whether this is a personal account. *)
17
-
is_read_only : bool;
18
-
(** Whether the account is read-only. *)
19
-
account_capabilities : (string * Jsont.json) list;
20
-
(** Capabilities available for this account. *)
21
-
}
22
-
23
-
val name : t -> string
24
-
val is_personal : t -> bool
25
-
val is_read_only : t -> bool
26
-
val account_capabilities : t -> (string * Jsont.json) list
27
-
28
-
val jsont : t Jsont.t
29
-
end
30
-
31
-
(** {1 Session} *)
32
-
33
-
(** The JMAP session resource. *)
34
-
type t = {
35
-
capabilities : (string * Jsont.json) list;
36
-
(** Server capabilities. Keys are capability URIs. *)
37
-
accounts : (Id.t * Account.t) list;
38
-
(** Available accounts keyed by account id. *)
39
-
primary_accounts : (string * Id.t) list;
40
-
(** Map of capability URI to the primary account id for that capability. *)
41
-
username : string;
42
-
(** The username associated with the credentials. *)
43
-
api_url : string;
44
-
(** URL to POST JMAP requests to. *)
45
-
download_url : string;
46
-
(** URL template for downloading blobs. *)
47
-
upload_url : string;
48
-
(** URL template for uploading blobs. *)
49
-
event_source_url : string;
50
-
(** URL for push event source. *)
51
-
state : string;
52
-
(** Opaque session state string. *)
53
-
}
54
-
55
-
val capabilities : t -> (string * Jsont.json) list
56
-
val accounts : t -> (Id.t * Account.t) list
57
-
val primary_accounts : t -> (string * Id.t) list
58
-
val username : t -> string
59
-
val api_url : t -> string
60
-
val download_url : t -> string
61
-
val upload_url : t -> string
62
-
val event_source_url : t -> string
63
-
val state : t -> string
64
-
65
-
val jsont : t Jsont.t
66
-
(** JSON codec for session objects. *)
67
-
68
-
(** {1 Session Helpers} *)
69
-
70
-
val get_account : Id.t -> t -> Account.t option
71
-
(** [get_account id session] returns the account with the given id. *)
72
-
73
-
val primary_account_for : string -> t -> Id.t option
74
-
(** [primary_account_for capability session] returns the primary account
75
-
for the given capability URI. *)
76
-
77
-
val has_capability : string -> t -> bool
78
-
(** [has_capability uri session] returns [true] if the server supports the capability. *)
79
-
80
-
val get_core_capability : t -> Capability.Core.t option
81
-
(** [get_core_capability session] returns the parsed core capability. *)
82
-
83
-
val get_mail_capability : t -> Capability.Mail.t option
84
-
(** [get_mail_capability session] returns the parsed mail capability. *)
-14
proto/unknown.ml
-14
proto/unknown.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = Jsont.json
7
-
8
-
let empty = Jsont.Object ([], Jsont.Meta.none)
9
-
10
-
let is_empty = function
11
-
| Jsont.Object ([], _) -> true
12
-
| _ -> false
13
-
14
-
let mems = Jsont.json_mems
-23
proto/unknown.mli
-23
proto/unknown.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Unknown field preservation for forward compatibility.
7
-
8
-
All JMAP objects preserve unknown fields to support future spec versions
9
-
and custom extensions. *)
10
-
11
-
type t = Jsont.json
12
-
(** Unknown or unrecognized JSON object members as a generic JSON value.
13
-
This is always an object containing the unknown fields. *)
14
-
15
-
val empty : t
16
-
(** [empty] is the empty set of unknown fields (an empty JSON object). *)
17
-
18
-
val is_empty : t -> bool
19
-
(** [is_empty u] returns [true] if there are no unknown fields. *)
20
-
21
-
val mems : (t, t, Jsont.mem list) Jsont.Object.Mems.map
22
-
(** [mems] is the jsont member map for preserving unknown fields.
23
-
Use with [Jsont.Object.keep_unknown]. *)
+1
-1
test/proto/dune
+1
-1
test/proto/dune
+47
-41
test/proto/test_proto.ml
+47
-41
test/proto/test_proto.ml
···
48
48
Alcotest.failf "%s: re-decode failed: %s" name (Jsont.Error.to_string e)
49
49
| Ok _ -> ()
50
50
51
+
(* Helpers for extracting values from optional fields in tests *)
52
+
let get_id opt = match opt with Some id -> Jmap.Proto.Id.to_string id | None -> Alcotest.fail "expected id"
53
+
let get_string opt = match opt with Some s -> s | None -> Alcotest.fail "expected string"
54
+
let get_int64 opt = match opt with Some n -> n | None -> Alcotest.fail "expected int64"
55
+
let get_bool opt = match opt with Some b -> b | None -> Alcotest.fail "expected bool"
56
+
51
57
(* ID tests *)
52
58
module Id_tests = struct
53
-
open Jmap_proto
59
+
open Jmap.Proto
54
60
55
61
let test_valid_simple () =
56
62
let json = "\"abc123\"" in
···
130
136
131
137
(* Int53 tests *)
132
138
module Int53_tests = struct
133
-
open Jmap_proto
139
+
open Jmap.Proto
134
140
135
141
let test_zero () =
136
142
match decode Int53.Signed.jsont "0" with
···
198
204
199
205
(* Date tests *)
200
206
module Date_tests = struct
201
-
open Jmap_proto
207
+
open Jmap.Proto
202
208
203
209
let test_utc_z () =
204
210
match decode Date.Utc.jsont "\"2024-01-15T10:30:00Z\"" with
···
236
242
237
243
(* Session tests *)
238
244
module Session_tests = struct
239
-
open Jmap_proto
245
+
open Jmap.Proto
240
246
241
247
let test_minimal () =
242
248
test_decode_success "minimal session" Session.jsont "session/valid/minimal.json" ()
···
285
291
286
292
(* Request tests *)
287
293
module Request_tests = struct
288
-
open Jmap_proto
294
+
open Jmap.Proto
289
295
290
296
let test_single_method () =
291
297
test_decode_success "single method" Request.jsont "request/valid/single_method.json" ()
···
322
328
323
329
(* Response tests *)
324
330
module Response_tests = struct
325
-
open Jmap_proto
331
+
open Jmap.Proto
326
332
327
333
let test_success () =
328
334
test_decode_success "success" Response.jsont "response/valid/success.json" ()
···
359
365
360
366
(* Invocation tests *)
361
367
module Invocation_tests = struct
362
-
open Jmap_proto
368
+
open Jmap.Proto
363
369
364
370
let test_get () =
365
371
test_decode_success "get" Invocation.jsont "invocation/valid/get.json" ()
···
396
402
397
403
(* Capability tests *)
398
404
module Capability_tests = struct
399
-
open Jmap_proto
405
+
open Jmap.Proto
400
406
401
407
let test_core () =
402
408
test_decode_success "core" Capability.Core.jsont "capability/valid/core.json" ()
···
435
441
436
442
(* Method args/response tests *)
437
443
module Method_tests = struct
438
-
open Jmap_proto
444
+
open Jmap.Proto
439
445
440
446
let test_get_args () =
441
447
test_decode_success "get_args" Method.get_args_jsont "method/valid/get_args.json" ()
···
491
497
492
498
(* Error tests *)
493
499
module Error_tests = struct
494
-
open Jmap_proto
500
+
open Jmap.Proto
495
501
496
502
let test_method_error () =
497
503
test_decode_success "method_error" Error.method_error_jsont "error/valid/method_error.json" ()
···
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
-
Alcotest.(check method_error_type_testable) "type" Error.Unknown_method err.type_
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
-
Alcotest.(check set_error_type_testable) "type" Error.Invalid_properties err.Error.type_;
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)
···
589
595
590
596
(* Mailbox tests *)
591
597
module Mailbox_tests = struct
592
-
open Jmap_mail
598
+
open Jmap.Proto
593
599
594
600
let role_testable =
595
601
Alcotest.testable
···
607
613
match decode Mailbox.jsont json with
608
614
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
609
615
| Ok mb ->
610
-
Alcotest.(check string) "id" "mb1" (Jmap_proto.Id.to_string (Mailbox.id mb));
611
-
Alcotest.(check string) "name" "Inbox" (Mailbox.name mb);
612
-
Alcotest.(check (option role_testable)) "role" (Some Mailbox.Inbox) (Mailbox.role mb);
613
-
Alcotest.(check int64) "totalEmails" 150L (Mailbox.total_emails mb);
614
-
Alcotest.(check int64) "unreadEmails" 5L (Mailbox.unread_emails mb)
616
+
Alcotest.(check string) "id" "mb1" (get_id (Mailbox.id mb));
617
+
Alcotest.(check string) "name" "Inbox" (get_string (Mailbox.name mb));
618
+
Alcotest.(check (option role_testable)) "role" (Some `Inbox) (Mailbox.role mb);
619
+
Alcotest.(check int64) "totalEmails" 150L (get_int64 (Mailbox.total_emails mb));
620
+
Alcotest.(check int64) "unreadEmails" 5L (get_int64 (Mailbox.unread_emails mb))
615
621
616
622
let test_roundtrip () =
617
623
test_roundtrip "simple roundtrip" Mailbox.jsont "mail/mailbox/valid/simple.json" ()
···
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
-
Alcotest.(check (option role_testable)) "role" (Some Mailbox.Archive) (Mailbox.role mb);
631
-
Alcotest.(check int64) "totalEmails" 1000L (Mailbox.total_emails mb)
636
+
Alcotest.(check (option role_testable)) "role" (Some `Archive) (Mailbox.role mb);
637
+
Alcotest.(check int64) "totalEmails" 1000L (get_int64 (Mailbox.total_emails mb))
632
638
633
639
let tests = [
634
640
"valid: simple", `Quick, test_simple;
···
643
649
644
650
(* Email tests *)
645
651
module Email_tests = struct
646
-
open Jmap_mail
652
+
open Jmap.Proto
647
653
648
654
let test_minimal () =
649
655
test_decode_success "minimal" Email.jsont "mail/email/valid/minimal.json" ()
···
659
665
match decode Email.jsont json with
660
666
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
661
667
| Ok email ->
662
-
Alcotest.(check string) "id" "e1" (Jmap_proto.Id.to_string (Email.id email));
663
-
Alcotest.(check string) "blobId" "blob1" (Jmap_proto.Id.to_string (Email.blob_id email));
664
-
Alcotest.(check int64) "size" 1024L (Email.size email)
668
+
Alcotest.(check string) "id" "e1" (get_id (Email.id email));
669
+
Alcotest.(check string) "blobId" "blob1" (get_id (Email.blob_id email));
670
+
Alcotest.(check int64) "size" 1024L (get_int64 (Email.size email))
665
671
666
672
let test_full_values () =
667
673
let json = read_file "mail/email/valid/full.json" in
···
669
675
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
670
676
| Ok email ->
671
677
Alcotest.(check (option string)) "subject" (Some "Re: Important meeting") (Email.subject email);
672
-
Alcotest.(check bool) "hasAttachment" true (Email.has_attachment email);
678
+
Alcotest.(check bool) "hasAttachment" true (get_bool (Email.has_attachment email));
673
679
(* Check from address *)
674
680
match Email.from email with
675
681
| None -> Alcotest.fail "expected from address"
···
702
708
match decode Email.jsont json with
703
709
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
704
710
| Ok email ->
705
-
let keywords = Email.keywords email in
711
+
let keywords = Option.value ~default:[] (Email.keywords email) in
706
712
Alcotest.(check int) "keywords count" 3 (List.length keywords);
707
713
Alcotest.(check bool) "$seen present" true (List.mem_assoc "$seen" keywords);
708
714
Alcotest.(check bool) "$flagged present" true (List.mem_assoc "$flagged" keywords)
···
712
718
match decode Email.jsont json with
713
719
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
714
720
| Ok email ->
715
-
let mailbox_ids = Email.mailbox_ids email in
721
+
let mailbox_ids = Option.value ~default:[] (Email.mailbox_ids email) in
716
722
Alcotest.(check int) "mailboxIds count" 3 (List.length mailbox_ids)
717
723
718
724
let tests = [
···
734
740
735
741
(* Thread tests *)
736
742
module Thread_tests = struct
737
-
open Jmap_mail
743
+
open Jmap.Proto
738
744
739
745
let test_simple () =
740
746
test_decode_success "simple" Thread.jsont "mail/thread/valid/simple.json" ()
···
747
753
match decode Thread.jsont json with
748
754
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
749
755
| Ok thread ->
750
-
Alcotest.(check string) "id" "t2" (Jmap_proto.Id.to_string (Thread.id thread));
751
-
Alcotest.(check int) "emailIds count" 5 (List.length (Thread.email_ids thread))
756
+
Alcotest.(check string) "id" "t2" (get_id (Thread.id thread));
757
+
Alcotest.(check int) "emailIds count" 5 (List.length (Option.value ~default:[] (Thread.email_ids thread)))
752
758
753
759
let tests = [
754
760
"valid: simple", `Quick, test_simple;
···
759
765
760
766
(* Identity tests *)
761
767
module Identity_tests = struct
762
-
open Jmap_mail
768
+
open Jmap.Proto
763
769
764
770
let test_simple () =
765
771
test_decode_success "simple" Identity.jsont "mail/identity/valid/simple.json" ()
···
769
775
match decode Identity.jsont json with
770
776
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
771
777
| Ok ident ->
772
-
Alcotest.(check string) "name" "Work Identity" (Identity.name ident);
773
-
Alcotest.(check string) "email" "john.doe@company.com" (Identity.email ident);
774
-
Alcotest.(check bool) "mayDelete" true (Identity.may_delete ident)
778
+
Alcotest.(check string) "name" "Work Identity" (get_string (Identity.name ident));
779
+
Alcotest.(check string) "email" "john.doe@company.com" (get_string (Identity.email ident));
780
+
Alcotest.(check bool) "mayDelete" true (get_bool (Identity.may_delete ident))
775
781
776
782
let tests = [
777
783
"valid: simple", `Quick, test_simple;
···
781
787
782
788
(* Email address tests *)
783
789
module Email_address_tests = struct
784
-
open Jmap_mail
790
+
open Jmap.Proto
785
791
786
792
let test_full () =
787
793
test_decode_success "full" Email_address.jsont "mail/email_address/valid/full.json" ()
···
815
821
816
822
(* Vacation tests *)
817
823
module Vacation_tests = struct
818
-
open Jmap_mail
824
+
open Jmap.Proto
819
825
820
826
let test_enabled () =
821
827
test_decode_success "enabled" Vacation.jsont "mail/vacation/valid/enabled.json" ()
···
849
855
850
856
(* Comparator tests *)
851
857
module Comparator_tests = struct
852
-
open Jmap_proto
858
+
open Jmap.Proto
853
859
854
860
let test_minimal () =
855
861
test_decode_success "minimal" Filter.comparator_jsont "filter/valid/comparator_minimal.json" ()
···
888
894
889
895
(* EmailBody tests *)
890
896
module EmailBody_tests = struct
891
-
open Jmap_mail
897
+
open Jmap.Proto
892
898
893
899
let test_text_part () =
894
900
test_decode_success "text part" Email_body.Part.jsont "mail/email_body/valid/text_part.json" ()
···
932
938
933
939
(* EmailSubmission tests *)
934
940
module EmailSubmission_tests = struct
935
-
open Jmap_mail
941
+
open Jmap.Proto
936
942
937
943
let test_simple () =
938
944
test_decode_success "simple" Submission.jsont "mail/submission/valid/simple.json" ()
···
948
954
match decode Submission.jsont json with
949
955
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
950
956
| Ok sub ->
951
-
Alcotest.(check string) "id" "sub1" (Jmap_proto.Id.to_string (Submission.id sub));
957
+
Alcotest.(check string) "id" "sub1" (get_id (Submission.id sub));
952
958
(* Check undoStatus is Pending *)
953
959
match Submission.undo_status sub with
954
-
| Submission.Pending -> ()
960
+
| Some `Pending -> ()
955
961
| _ -> Alcotest.fail "expected undoStatus to be pending"
956
962
957
963
let tests = [
+562
web/brr.html
+562
web/brr.html
···
1
+
<!DOCTYPE html>
2
+
<html lang="en">
3
+
<head>
4
+
<meta charset="utf-8">
5
+
<meta name="viewport" content="width=device-width, initial-scale=1.0">
6
+
<title>JMAP Email Client</title>
7
+
<style>
8
+
:root {
9
+
--bg-color: #1a1a2e;
10
+
--card-bg: #16213e;
11
+
--accent: #0f3460;
12
+
--highlight: #e94560;
13
+
--text: #eee;
14
+
--text-muted: #888;
15
+
--success: #4ade80;
16
+
--error: #f87171;
17
+
--warning: #fbbf24;
18
+
}
19
+
20
+
* {
21
+
box-sizing: border-box;
22
+
margin: 0;
23
+
padding: 0;
24
+
}
25
+
26
+
body {
27
+
font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, Oxygen, Ubuntu, sans-serif;
28
+
background: var(--bg-color);
29
+
color: var(--text);
30
+
min-height: 100vh;
31
+
padding: 20px;
32
+
}
33
+
34
+
.container {
35
+
max-width: 1200px;
36
+
margin: 0 auto;
37
+
}
38
+
39
+
header {
40
+
text-align: center;
41
+
margin-bottom: 30px;
42
+
}
43
+
44
+
h1 {
45
+
font-size: 2rem;
46
+
margin-bottom: 10px;
47
+
}
48
+
49
+
h1 span {
50
+
color: var(--highlight);
51
+
}
52
+
53
+
.subtitle {
54
+
color: var(--text-muted);
55
+
font-size: 0.9rem;
56
+
}
57
+
58
+
/* Top Section - Two Column Layout */
59
+
.top-section {
60
+
display: grid;
61
+
grid-template-columns: 1fr 1fr;
62
+
gap: 20px;
63
+
margin-bottom: 20px;
64
+
}
65
+
66
+
@media (max-width: 800px) {
67
+
.top-section {
68
+
grid-template-columns: 1fr;
69
+
}
70
+
}
71
+
72
+
/* Login Form */
73
+
.login-card {
74
+
background: var(--card-bg);
75
+
border-radius: 12px;
76
+
padding: 16px;
77
+
box-shadow: 0 4px 20px rgba(0,0,0,0.3);
78
+
}
79
+
80
+
.login-card h3 {
81
+
margin-bottom: 12px;
82
+
font-size: 0.9rem;
83
+
color: var(--text-muted);
84
+
text-transform: uppercase;
85
+
letter-spacing: 1px;
86
+
}
87
+
88
+
.form-row {
89
+
display: flex;
90
+
gap: 12px;
91
+
margin-bottom: 12px;
92
+
}
93
+
94
+
.form-group {
95
+
flex: 1;
96
+
margin-bottom: 12px;
97
+
}
98
+
99
+
.form-group:last-child {
100
+
margin-bottom: 0;
101
+
}
102
+
103
+
.form-group.small {
104
+
flex: 0.4;
105
+
}
106
+
107
+
label {
108
+
display: block;
109
+
margin-bottom: 4px;
110
+
font-weight: 500;
111
+
font-size: 0.75rem;
112
+
color: var(--text-muted);
113
+
}
114
+
115
+
input[type="text"],
116
+
input[type="password"] {
117
+
width: 100%;
118
+
padding: 8px 12px;
119
+
border: 2px solid var(--accent);
120
+
border-radius: 6px;
121
+
background: var(--bg-color);
122
+
color: var(--text);
123
+
font-size: 0.85rem;
124
+
transition: border-color 0.2s;
125
+
}
126
+
127
+
input:focus {
128
+
outline: none;
129
+
border-color: var(--highlight);
130
+
}
131
+
132
+
.btn-row {
133
+
display: flex;
134
+
gap: 8px;
135
+
}
136
+
137
+
.btn {
138
+
flex: 1;
139
+
padding: 10px;
140
+
border: none;
141
+
border-radius: 6px;
142
+
font-size: 0.85rem;
143
+
font-weight: 600;
144
+
cursor: pointer;
145
+
transition: transform 0.1s, opacity 0.2s;
146
+
}
147
+
148
+
.btn:hover {
149
+
transform: translateY(-1px);
150
+
}
151
+
152
+
.btn:active {
153
+
transform: translateY(0);
154
+
}
155
+
156
+
.btn:disabled {
157
+
opacity: 0.5;
158
+
cursor: not-allowed;
159
+
transform: none;
160
+
}
161
+
162
+
.btn-primary {
163
+
background: var(--highlight);
164
+
color: white;
165
+
}
166
+
167
+
.btn-secondary {
168
+
background: var(--accent);
169
+
color: var(--text);
170
+
}
171
+
172
+
/* Status/Log Panel */
173
+
.log-panel {
174
+
background: var(--card-bg);
175
+
border-radius: 12px;
176
+
padding: 20px;
177
+
margin-bottom: 30px;
178
+
max-height: 500px;
179
+
overflow-y: auto;
180
+
}
181
+
182
+
.log-panel h3 {
183
+
margin-bottom: 15px;
184
+
font-size: 0.9rem;
185
+
color: var(--text-muted);
186
+
text-transform: uppercase;
187
+
letter-spacing: 1px;
188
+
}
189
+
190
+
.log-entry {
191
+
font-family: 'SF Mono', Monaco, 'Courier New', monospace;
192
+
font-size: 0.85rem;
193
+
padding: 8px 0;
194
+
border-bottom: 1px solid var(--accent);
195
+
}
196
+
197
+
.log-entry:last-child {
198
+
border-bottom: none;
199
+
}
200
+
201
+
.log-entry-header {
202
+
display: flex;
203
+
align-items: center;
204
+
gap: 8px;
205
+
}
206
+
207
+
.log-info .log-entry-header { color: var(--text); }
208
+
.log-success .log-entry-header { color: var(--success); }
209
+
.log-error .log-entry-header { color: var(--error); }
210
+
.log-warning .log-entry-header { color: var(--warning); }
211
+
212
+
.log-time {
213
+
color: var(--text-muted);
214
+
font-size: 0.8rem;
215
+
flex-shrink: 0;
216
+
}
217
+
218
+
.log-message {
219
+
flex: 1;
220
+
}
221
+
222
+
.log-expand-btn {
223
+
background: var(--accent);
224
+
border: none;
225
+
color: var(--text-muted);
226
+
padding: 2px 8px;
227
+
border-radius: 4px;
228
+
font-size: 0.7rem;
229
+
cursor: pointer;
230
+
font-family: inherit;
231
+
transition: background 0.2s, color 0.2s;
232
+
flex-shrink: 0;
233
+
}
234
+
235
+
.log-expand-btn:hover {
236
+
background: var(--highlight);
237
+
color: white;
238
+
}
239
+
240
+
.log-expand-btn.expanded {
241
+
background: var(--highlight);
242
+
color: white;
243
+
}
244
+
245
+
/* JSON content within log entry */
246
+
.log-json {
247
+
display: none;
248
+
margin-top: 8px;
249
+
border-radius: 8px;
250
+
overflow: hidden;
251
+
}
252
+
253
+
.log-json.visible {
254
+
display: block;
255
+
}
256
+
257
+
.log-json-header {
258
+
padding: 6px 12px;
259
+
font-size: 0.75rem;
260
+
font-weight: 600;
261
+
display: flex;
262
+
justify-content: space-between;
263
+
align-items: center;
264
+
}
265
+
266
+
.log-json.request .log-json-header {
267
+
background: var(--accent);
268
+
color: var(--highlight);
269
+
}
270
+
271
+
.log-json.response .log-json-header {
272
+
background: #1a3a2e;
273
+
color: var(--success);
274
+
}
275
+
276
+
.log-json-body {
277
+
background: var(--bg-color);
278
+
padding: 12px;
279
+
font-size: 0.75rem;
280
+
line-height: 1.4;
281
+
white-space: pre-wrap;
282
+
word-break: break-all;
283
+
max-height: 300px;
284
+
overflow-y: auto;
285
+
color: var(--text-muted);
286
+
}
287
+
288
+
.log-json-body.collapsed {
289
+
max-height: 100px;
290
+
}
291
+
292
+
.json-toggle-size {
293
+
background: none;
294
+
border: none;
295
+
color: inherit;
296
+
cursor: pointer;
297
+
font-size: 0.7rem;
298
+
opacity: 0.7;
299
+
}
300
+
301
+
.json-toggle-size:hover {
302
+
opacity: 1;
303
+
}
304
+
305
+
/* Session Info */
306
+
.session-info {
307
+
background: var(--card-bg);
308
+
border-radius: 12px;
309
+
padding: 16px;
310
+
display: none;
311
+
box-shadow: 0 4px 20px rgba(0,0,0,0.3);
312
+
}
313
+
314
+
.session-info.visible {
315
+
display: block;
316
+
}
317
+
318
+
.session-info h3 {
319
+
margin-bottom: 12px;
320
+
font-size: 0.9rem;
321
+
color: var(--success);
322
+
text-transform: uppercase;
323
+
letter-spacing: 1px;
324
+
}
325
+
326
+
.session-detail {
327
+
display: flex;
328
+
margin-bottom: 6px;
329
+
font-size: 0.85rem;
330
+
}
331
+
332
+
.session-detail .label {
333
+
width: 100px;
334
+
color: var(--text-muted);
335
+
flex-shrink: 0;
336
+
}
337
+
338
+
.session-detail .value {
339
+
color: var(--text);
340
+
word-break: break-all;
341
+
font-family: 'SF Mono', Monaco, 'Courier New', monospace;
342
+
font-size: 0.8rem;
343
+
}
344
+
345
+
.search-box {
346
+
margin-top: 12px;
347
+
padding-top: 12px;
348
+
border-top: 1px solid var(--accent);
349
+
display: flex;
350
+
gap: 8px;
351
+
}
352
+
353
+
.search-box input {
354
+
flex: 1;
355
+
padding: 8px 12px;
356
+
border: 2px solid var(--accent);
357
+
border-radius: 6px;
358
+
background: var(--bg-color);
359
+
color: var(--text);
360
+
font-size: 0.85rem;
361
+
}
362
+
363
+
.search-box input:focus {
364
+
outline: none;
365
+
border-color: var(--highlight);
366
+
}
367
+
368
+
.btn-small {
369
+
flex: 0;
370
+
padding: 8px 16px;
371
+
white-space: nowrap;
372
+
}
373
+
374
+
/* Email List */
375
+
.email-list {
376
+
display: none;
377
+
}
378
+
379
+
.email-list.visible {
380
+
display: block;
381
+
}
382
+
383
+
.email-list h2 {
384
+
margin-bottom: 20px;
385
+
}
386
+
387
+
.email-item {
388
+
background: var(--card-bg);
389
+
border-radius: 8px;
390
+
padding: 16px 20px;
391
+
margin-bottom: 12px;
392
+
cursor: pointer;
393
+
transition: background 0.2s, transform 0.1s;
394
+
border-left: 4px solid transparent;
395
+
}
396
+
397
+
.email-item:hover {
398
+
background: var(--accent);
399
+
transform: translateX(4px);
400
+
}
401
+
402
+
.email-item.unread {
403
+
border-left-color: var(--highlight);
404
+
}
405
+
406
+
.email-header {
407
+
display: flex;
408
+
justify-content: space-between;
409
+
align-items: flex-start;
410
+
margin-bottom: 8px;
411
+
}
412
+
413
+
.email-from {
414
+
font-weight: 600;
415
+
font-size: 1rem;
416
+
}
417
+
418
+
.email-date {
419
+
color: var(--text-muted);
420
+
font-size: 0.85rem;
421
+
}
422
+
423
+
.email-subject {
424
+
font-size: 0.95rem;
425
+
color: var(--text);
426
+
margin-bottom: 6px;
427
+
}
428
+
429
+
.email-preview {
430
+
color: var(--text-muted);
431
+
font-size: 0.85rem;
432
+
white-space: nowrap;
433
+
overflow: hidden;
434
+
text-overflow: ellipsis;
435
+
}
436
+
437
+
.email-keywords {
438
+
margin-top: 8px;
439
+
}
440
+
441
+
.keyword-tag {
442
+
display: inline-block;
443
+
background: var(--accent);
444
+
color: var(--text-muted);
445
+
padding: 2px 8px;
446
+
border-radius: 4px;
447
+
font-size: 0.75rem;
448
+
margin-right: 6px;
449
+
}
450
+
451
+
.keyword-tag.flagged {
452
+
background: var(--warning);
453
+
color: var(--bg-color);
454
+
}
455
+
456
+
/* Loading spinner */
457
+
.spinner {
458
+
display: inline-block;
459
+
width: 20px;
460
+
height: 20px;
461
+
border: 2px solid var(--text-muted);
462
+
border-top-color: var(--highlight);
463
+
border-radius: 50%;
464
+
animation: spin 0.8s linear infinite;
465
+
margin-right: 10px;
466
+
vertical-align: middle;
467
+
}
468
+
469
+
@keyframes spin {
470
+
to { transform: rotate(360deg); }
471
+
}
472
+
473
+
/* Responsive */
474
+
@media (max-width: 600px) {
475
+
body {
476
+
padding: 10px;
477
+
}
478
+
479
+
.login-card {
480
+
padding: 20px;
481
+
}
482
+
483
+
h1 {
484
+
font-size: 1.5rem;
485
+
}
486
+
}
487
+
</style>
488
+
</head>
489
+
<body>
490
+
<div class="container">
491
+
<header>
492
+
<h1>JMAP <span>Email Client</span></h1>
493
+
<p class="subtitle">Built with OCaml and Brr</p>
494
+
</header>
495
+
496
+
<!-- Top Section: Login + Session Info -->
497
+
<div class="top-section">
498
+
<!-- Login Form -->
499
+
<div class="login-card" id="login-card">
500
+
<h3>Connection</h3>
501
+
<div class="form-group">
502
+
<label for="session-url">Session URL</label>
503
+
<input type="text" id="session-url"
504
+
value="https://api.fastmail.com/jmap/session"
505
+
placeholder="https://api.fastmail.com/jmap/session">
506
+
</div>
507
+
<div class="form-row">
508
+
<div class="form-group">
509
+
<label for="api-token">API Token</label>
510
+
<input type="password" id="api-token"
511
+
placeholder="Enter your JMAP API token">
512
+
</div>
513
+
</div>
514
+
<div class="btn-row">
515
+
<button class="btn btn-primary" id="connect-btn">Connect</button>
516
+
<button class="btn btn-secondary" id="disconnect-btn" style="display: none;">Disconnect</button>
517
+
</div>
518
+
</div>
519
+
520
+
<!-- Session Info -->
521
+
<div class="session-info" id="session-info">
522
+
<h3>Connected</h3>
523
+
<div class="session-detail">
524
+
<span class="label">Username:</span>
525
+
<span class="value" id="session-username">-</span>
526
+
</div>
527
+
<div class="session-detail">
528
+
<span class="label">API URL:</span>
529
+
<span class="value" id="session-api-url">-</span>
530
+
</div>
531
+
<div class="session-detail">
532
+
<span class="label">Account ID:</span>
533
+
<span class="value" id="session-account-id">-</span>
534
+
</div>
535
+
<div class="search-box">
536
+
<input type="text" id="email-search" placeholder="Search emails...">
537
+
<button class="btn btn-primary btn-small" id="search-btn">Search</button>
538
+
</div>
539
+
</div>
540
+
</div>
541
+
542
+
<!-- Log Panel with expandable JSON -->
543
+
<div class="log-panel" id="log-panel">
544
+
<h3>Activity Log</h3>
545
+
<div id="log-entries"></div>
546
+
</div>
547
+
548
+
<!-- Email List -->
549
+
<div class="email-list" id="email-list">
550
+
<h2>Recent Emails</h2>
551
+
<div id="emails"></div>
552
+
</div>
553
+
</div>
554
+
555
+
<script type="text/javascript" defer src="brr.js"></script>
556
+
<noscript>
557
+
<p style="text-align: center; padding: 50px; color: #888;">
558
+
Please enable JavaScript to use this application.
559
+
</p>
560
+
</noscript>
561
+
</body>
562
+
</html>
+539
web/brr_app.ml
+539
web/brr_app.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
JMAP Email Client - Browser Application
3
+
Built with OCaml, Brr, and jmap-brr
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Brr
7
+
open Fut.Syntax
8
+
9
+
(* ---- Shared timestamp utilities ---- *)
10
+
11
+
let get_time_str () =
12
+
let date = Jv.new' (Jv.get Jv.global "Date") [||] in
13
+
let h = Jv.to_int (Jv.call date "getHours" [||]) in
14
+
let m = Jv.to_int (Jv.call date "getMinutes" [||]) in
15
+
let s = Jv.to_int (Jv.call date "getSeconds" [||]) in
16
+
Printf.sprintf "%02d:%02d:%02d" h m s
17
+
18
+
(* ---- JSON Masking ---- *)
19
+
20
+
module JsonMask = struct
21
+
let sensitive_keys = [
22
+
"accountId"; "blobId"; "threadId"; "emailId"; "id";
23
+
"username"; "apiUrl"; "downloadUrl"; "uploadUrl"; "eventSourceUrl";
24
+
"state"; "oldState"; "newState"
25
+
]
26
+
27
+
let is_sensitive key =
28
+
List.exists (fun k -> String.lowercase_ascii k = String.lowercase_ascii key) sensitive_keys
29
+
30
+
let mask_value s =
31
+
let len = String.length s in
32
+
if len <= 4 then String.make len '*'
33
+
else
34
+
let visible = min 4 (len / 4) in
35
+
(String.sub s 0 visible) ^ String.make (len - visible) '*'
36
+
37
+
let rec mask_json (json : Jv.t) : Jv.t =
38
+
if Jv.is_null json || Jv.is_undefined json then json
39
+
else if Jv.is_array json then
40
+
let arr = Jv.to_list Fun.id json in
41
+
let masked = List.map mask_json arr in
42
+
Jv.of_list Fun.id masked
43
+
else if Jstr.equal (Jv.typeof json) (Jstr.v "object") && not (Jv.is_array json) then
44
+
let obj = Jv.obj [||] in
45
+
let keys = Jv.call (Jv.get Jv.global "Object") "keys" [|json|] in
46
+
let key_list = Jv.to_list Jv.to_string keys in
47
+
List.iter (fun key ->
48
+
let value = Jv.get json key in
49
+
let masked_value =
50
+
if is_sensitive key && Jstr.equal (Jv.typeof value) (Jstr.v "string") then
51
+
Jv.of_string (mask_value (Jv.to_string value))
52
+
else
53
+
mask_json value
54
+
in
55
+
Jv.set obj key masked_value
56
+
) key_list;
57
+
obj
58
+
else
59
+
json
60
+
61
+
let format_json json =
62
+
let json_obj = Jv.get Jv.global "JSON" in
63
+
Jv.to_string (Jv.call json_obj "stringify" [|json; Jv.null; Jv.of_int 2|])
64
+
65
+
let mask_and_format json_str =
66
+
try
67
+
let json_obj = Jv.get Jv.global "JSON" in
68
+
let parsed = Jv.call json_obj "parse" [|Jv.of_string json_str|] in
69
+
let masked = mask_json parsed in
70
+
format_json masked
71
+
with _ -> json_str
72
+
end
73
+
74
+
(* ---- Logging with expandable JSON ---- *)
75
+
76
+
module Log = struct
77
+
type level = Info | Success | Error | Warning
78
+
79
+
let log_entries_el () =
80
+
Document.find_el_by_id G.document (Jstr.v "log-entries")
81
+
82
+
(* Reference to the last created entry for attaching JSON *)
83
+
let last_entry : El.t option ref = ref None
84
+
85
+
let add level msg =
86
+
match log_entries_el () with
87
+
| None -> Console.(log [str msg])
88
+
| Some container ->
89
+
let time_str = get_time_str () in
90
+
let class_name = match level with
91
+
| Info -> "log-info"
92
+
| Success -> "log-success"
93
+
| Error -> "log-error"
94
+
| Warning -> "log-warning"
95
+
in
96
+
let header = El.div ~at:At.[class' (Jstr.v "log-entry-header")] [
97
+
El.span ~at:At.[class' (Jstr.v "log-time")] [El.txt' time_str];
98
+
El.span ~at:At.[class' (Jstr.v "log-message")] [El.txt' msg];
99
+
] in
100
+
let entry = El.div ~at:At.[class' (Jstr.v ("log-entry " ^ class_name))] [header] in
101
+
last_entry := Some entry;
102
+
El.append_children container [entry];
103
+
(* Scroll to bottom *)
104
+
let scroll_height = Jv.get (El.to_jv container) "scrollHeight" in
105
+
Jv.set (El.to_jv container) "scrollTop" scroll_height
106
+
107
+
let attach_json direction label json_str =
108
+
match !last_entry with
109
+
| None -> ()
110
+
| Some entry ->
111
+
let formatted = JsonMask.mask_and_format json_str in
112
+
let class_name = match direction with
113
+
| `Request -> "log-json request"
114
+
| `Response -> "log-json response"
115
+
in
116
+
let arrow = match direction with
117
+
| `Request -> ">>> "
118
+
| `Response -> "<<< "
119
+
in
120
+
(* Create the JSON container (hidden by default) *)
121
+
let json_body = El.pre ~at:At.[class' (Jstr.v "log-json-body collapsed")] [El.txt' formatted] in
122
+
let expand_size_btn = El.button ~at:At.[class' (Jstr.v "json-toggle-size")] [El.txt' "[expand]"] in
123
+
let json_div = El.div ~at:At.[class' (Jstr.v class_name)] [
124
+
El.div ~at:At.[class' (Jstr.v "log-json-header")] [
125
+
El.span [El.txt' (arrow ^ label)];
126
+
expand_size_btn;
127
+
];
128
+
json_body;
129
+
] in
130
+
(* Add expand button to header if not already there *)
131
+
let header = El.children entry |> List.hd in
132
+
let existing_btns = El.children header |> List.filter (fun el ->
133
+
match El.at (Jstr.v "class") el with
134
+
| Some cls -> Option.is_some (Jstr.find_sub ~sub:(Jstr.v "log-expand-btn") cls)
135
+
| None -> false
136
+
) in
137
+
if List.length existing_btns = 0 then begin
138
+
let expand_btn = El.button ~at:At.[class' (Jstr.v "log-expand-btn")] [El.txt' "JSON"] in
139
+
El.append_children header [expand_btn];
140
+
(* Toggle visibility on click *)
141
+
ignore @@ Ev.listen Ev.click (fun _ev ->
142
+
let json_els = El.children entry |> List.filter (fun el ->
143
+
match El.at (Jstr.v "class") el with
144
+
| Some cls -> Option.is_some (Jstr.find_sub ~sub:(Jstr.v "log-json") cls)
145
+
| None -> false
146
+
) in
147
+
let is_visible = List.exists (fun el ->
148
+
El.class' (Jstr.v "visible") el
149
+
) json_els in
150
+
List.iter (fun el ->
151
+
El.set_class (Jstr.v "visible") (not is_visible) el
152
+
) json_els;
153
+
El.set_class (Jstr.v "expanded") (not is_visible) expand_btn
154
+
) (El.as_target expand_btn)
155
+
end;
156
+
(* Toggle body size *)
157
+
ignore @@ Ev.listen Ev.click (fun _ev ->
158
+
let is_collapsed = El.class' (Jstr.v "collapsed") json_body in
159
+
El.set_class (Jstr.v "collapsed") (not is_collapsed) json_body;
160
+
El.set_children expand_size_btn [El.txt' (if is_collapsed then "[collapse]" else "[expand]")]
161
+
) (El.as_target expand_size_btn);
162
+
El.append_children entry [json_div];
163
+
(* Scroll to bottom *)
164
+
match log_entries_el () with
165
+
| Some container ->
166
+
let scroll_height = Jv.get (El.to_jv container) "scrollHeight" in
167
+
Jv.set (El.to_jv container) "scrollTop" scroll_height
168
+
| None -> ()
169
+
170
+
let info msg = add Info msg
171
+
let success msg = add Success msg
172
+
let error msg = add Error msg
173
+
let warning msg = add Warning msg
174
+
end
175
+
176
+
(* ---- JSON Protocol Logging (bridges to Log.attach_json) ---- *)
177
+
178
+
module JsonLog = struct
179
+
let request label json = Log.attach_json `Request label json
180
+
let response label json = Log.attach_json `Response label json
181
+
let clear () = () (* No longer needed *)
182
+
end
183
+
184
+
(* ---- DOM Helpers ---- *)
185
+
186
+
let get_el id =
187
+
match Document.find_el_by_id G.document (Jstr.v id) with
188
+
| Some el -> el
189
+
| None -> failwith (Printf.sprintf "Element not found: %s" id)
190
+
191
+
let get_input_value id =
192
+
let el = get_el id in
193
+
Jstr.to_string (El.prop El.Prop.value el)
194
+
195
+
let set_text id text =
196
+
let el = get_el id in
197
+
El.set_children el [El.txt' text]
198
+
199
+
let show_el id =
200
+
let el = get_el id in
201
+
El.set_class (Jstr.v "visible") true el
202
+
203
+
let hide_el id =
204
+
let el = get_el id in
205
+
El.set_class (Jstr.v "visible") false el
206
+
207
+
let set_button_loading id loading =
208
+
let el = get_el id in
209
+
El.set_at At.Name.disabled (if loading then Some (Jstr.v "") else None) el;
210
+
if loading then
211
+
El.set_children el [
212
+
El.span ~at:At.[class' (Jstr.v "spinner")] [];
213
+
El.txt' "Connecting..."
214
+
]
215
+
else
216
+
El.set_children el [El.txt' "Connect"]
217
+
218
+
(* ---- Email Display ---- *)
219
+
220
+
let format_date ptime =
221
+
let date, time = Ptime.to_date_time ptime in
222
+
let y, m, d = date in
223
+
let (h, min, _), _ = time in
224
+
Printf.sprintf "%04d-%02d-%02d %02d:%02d" y m d h min
225
+
226
+
let format_address (addr : Jmap.Proto.Email_address.t) =
227
+
match addr.name with
228
+
| Some name -> Printf.sprintf "%s <%s>" name addr.email
229
+
| None -> addr.email
230
+
231
+
let format_addresses = function
232
+
| None -> "Unknown"
233
+
| Some [] -> "Unknown"
234
+
| Some (addr :: _) -> format_address addr
235
+
236
+
let render_email (email : Jmap.Proto.Email.t) =
237
+
let keywords = Option.value ~default:[] email.keywords in
238
+
let is_unread = not (List.exists (fun (k, v) -> k = "$seen" && v) keywords) in
239
+
let is_flagged = List.exists (fun (k, v) -> k = "$flagged" && v) keywords in
240
+
241
+
let from_str = format_addresses email.from in
242
+
let subject = Option.value ~default:"(No Subject)" email.subject in
243
+
let date_str = match email.received_at with Some t -> format_date t | None -> "?" in
244
+
let preview = Option.value ~default:"" email.preview in
245
+
246
+
let keyword_tags =
247
+
if is_flagged then
248
+
[El.span ~at:At.[class' (Jstr.v "keyword-tag flagged")] [El.txt' "Flagged"]]
249
+
else
250
+
[]
251
+
in
252
+
253
+
let classes = "email-item" ^ (if is_unread then " unread" else "") in
254
+
255
+
El.div ~at:At.[class' (Jstr.v classes)] [
256
+
El.div ~at:At.[class' (Jstr.v "email-header")] [
257
+
El.span ~at:At.[class' (Jstr.v "email-from")] [El.txt' from_str];
258
+
El.span ~at:At.[class' (Jstr.v "email-date")] [El.txt' date_str];
259
+
];
260
+
El.div ~at:At.[class' (Jstr.v "email-subject")] [El.txt' subject];
261
+
El.div ~at:At.[class' (Jstr.v "email-preview")] [El.txt' preview];
262
+
El.div ~at:At.[class' (Jstr.v "email-keywords")] keyword_tags;
263
+
]
264
+
265
+
let display_emails emails =
266
+
let container = get_el "emails" in
267
+
let email_els = List.map render_email emails in
268
+
El.set_children container email_els;
269
+
show_el "email-list"
270
+
271
+
(* ---- State ---- *)
272
+
273
+
type state = {
274
+
mutable connection : Jmap_brr.connection option;
275
+
mutable account_id : Jmap.Proto.Id.t option;
276
+
}
277
+
278
+
let state = { connection = None; account_id = None }
279
+
280
+
(* ---- JMAP Operations ---- *)
281
+
282
+
let fetch_emails ?(search_text="") conn account_id =
283
+
let search_msg = if search_text = "" then "Fetching recent emails..."
284
+
else Printf.sprintf "Searching emails for '%s'..." search_text in
285
+
Log.info search_msg;
286
+
287
+
let capabilities = [
288
+
Jmap.Capability.core_uri;
289
+
Jmap.Capability.mail_uri
290
+
] in
291
+
292
+
(* First, get mailboxes to find the inbox *)
293
+
let request, mailbox_handle =
294
+
let open Jmap.Chain in
295
+
build ~capabilities (mailbox_get ~account_id ())
296
+
in
297
+
298
+
let* response = Jmap_brr.request conn request in
299
+
match response with
300
+
| Error e ->
301
+
Log.error (Printf.sprintf "Failed to get mailboxes: %s"
302
+
(Jstr.to_string (Jv.Error.message e)));
303
+
Fut.return ()
304
+
| Ok resp ->
305
+
match Jmap.Chain.parse mailbox_handle resp with
306
+
| Error e ->
307
+
Log.error (Printf.sprintf "Failed to parse mailboxes: %s"
308
+
(Jsont.Error.to_string e));
309
+
Fut.return ()
310
+
| Ok mailbox_resp ->
311
+
let mailboxes = mailbox_resp.list in
312
+
Log.info (Printf.sprintf "Found %d mailboxes" (List.length mailboxes));
313
+
314
+
(* Find inbox or use first mailbox *)
315
+
let inbox_id =
316
+
match List.find_opt (fun m ->
317
+
match m.Jmap.Proto.Mailbox.role with
318
+
| Some `Inbox -> true
319
+
| _ -> false
320
+
) mailboxes with
321
+
| Some m -> m.Jmap.Proto.Mailbox.id
322
+
| None ->
323
+
match mailboxes with
324
+
| m :: _ -> m.Jmap.Proto.Mailbox.id
325
+
| [] ->
326
+
Log.error "No mailboxes found";
327
+
failwith "No mailboxes"
328
+
in
329
+
let inbox_id = match inbox_id with
330
+
| Some id -> id
331
+
| None ->
332
+
Log.error "Inbox has no ID";
333
+
failwith "Inbox has no ID"
334
+
in
335
+
336
+
let query_msg = if search_text = "" then "Querying emails from inbox..."
337
+
else Printf.sprintf "Querying inbox for '%s'..." search_text in
338
+
Log.info query_msg;
339
+
340
+
(* Query for recent emails with optional text search *)
341
+
let text_filter = if search_text = "" then None else Some search_text in
342
+
let filter_condition : Jmap.Proto.Email.Filter_condition.t = {
343
+
in_mailbox = Some inbox_id;
344
+
in_mailbox_other_than = None;
345
+
before = None;
346
+
after = None;
347
+
min_size = None;
348
+
max_size = None;
349
+
all_in_thread_have_keyword = None;
350
+
some_in_thread_have_keyword = None;
351
+
none_in_thread_have_keyword = None;
352
+
has_keyword = None;
353
+
not_keyword = None;
354
+
has_attachment = None;
355
+
text = text_filter;
356
+
from = None;
357
+
to_ = None;
358
+
cc = None;
359
+
bcc = None;
360
+
subject = None;
361
+
body = None;
362
+
header = None;
363
+
} in
364
+
365
+
let request2, email_handle =
366
+
let open Jmap.Chain in
367
+
build ~capabilities begin
368
+
let* query = email_query ~account_id
369
+
~filter:(Jmap.Proto.Filter.Condition filter_condition)
370
+
~sort:[Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"]
371
+
~limit:20L
372
+
()
373
+
in
374
+
email_get ~account_id
375
+
~ids:(from_query query)
376
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
377
+
"size"; "receivedAt"; "from"; "subject"; "preview";
378
+
"hasAttachment"]
379
+
()
380
+
end
381
+
in
382
+
383
+
Log.info "Sending email query request...";
384
+
let* response2 = Jmap_brr.request conn request2 in
385
+
Log.info "Got email query response";
386
+
match response2 with
387
+
| Error e ->
388
+
Log.error (Printf.sprintf "Failed to query emails: %s"
389
+
(Jstr.to_string (Jv.Error.message e)));
390
+
Fut.return ()
391
+
| Ok resp2 ->
392
+
Log.info "Parsing email response...";
393
+
match Jmap.Chain.parse email_handle resp2 with
394
+
| Error e ->
395
+
Log.error (Printf.sprintf "Failed to parse emails: %s"
396
+
(Jsont.Error.to_string e));
397
+
Fut.return ()
398
+
| Ok email_resp ->
399
+
let emails = email_resp.list in
400
+
Log.success (Printf.sprintf "Loaded %d emails" (List.length emails));
401
+
(try
402
+
display_emails emails
403
+
with exn ->
404
+
Log.error (Printf.sprintf "Display error: %s" (Printexc.to_string exn)));
405
+
Fut.return ()
406
+
407
+
(* ---- Connection ---- *)
408
+
409
+
let connect () =
410
+
let session_url = get_input_value "session-url" in
411
+
let api_token = get_input_value "api-token" in
412
+
413
+
if String.length api_token = 0 then begin
414
+
Log.error "Please enter an API token";
415
+
Fut.return ()
416
+
end else begin
417
+
Log.info (Printf.sprintf "Connecting to %s..." session_url);
418
+
set_button_loading "connect-btn" true;
419
+
420
+
let* result = Jmap_brr.get_session
421
+
~url:(Jstr.v session_url)
422
+
~token:(Jstr.v api_token)
423
+
in
424
+
425
+
set_button_loading "connect-btn" false;
426
+
427
+
match result with
428
+
| Error e ->
429
+
let msg = Jstr.to_string (Jv.Error.message e) in
430
+
Log.error (Printf.sprintf "Connection failed: %s" msg);
431
+
Fut.return ()
432
+
| Ok conn ->
433
+
let session = Jmap_brr.session conn in
434
+
let username = Jmap.Proto.Session.username session in
435
+
let api_url = Jmap.Proto.Session.api_url session in
436
+
437
+
Log.success (Printf.sprintf "Connected as %s" username);
438
+
439
+
(* Find primary mail account *)
440
+
let account_id =
441
+
match Jmap.Proto.Session.primary_account_for
442
+
Jmap.Capability.mail_uri session with
443
+
| Some id -> id
444
+
| None ->
445
+
match Jmap.Proto.Session.accounts session with
446
+
| (id, _) :: _ -> id
447
+
| [] -> failwith "No accounts found"
448
+
in
449
+
450
+
state.connection <- Some conn;
451
+
state.account_id <- Some account_id;
452
+
453
+
(* Update UI *)
454
+
set_text "session-username" username;
455
+
set_text "session-api-url" api_url;
456
+
set_text "session-account-id" (Jmap.Proto.Id.to_string account_id);
457
+
show_el "session-info";
458
+
459
+
(* Show disconnect button *)
460
+
let connect_btn = get_el "connect-btn" in
461
+
let disconnect_btn = get_el "disconnect-btn" in
462
+
El.set_inline_style (Jstr.v "display") (Jstr.v "none") connect_btn;
463
+
El.set_inline_style (Jstr.v "display") (Jstr.v "block") disconnect_btn;
464
+
465
+
(* Fetch emails *)
466
+
fetch_emails conn account_id
467
+
end
468
+
469
+
let disconnect () =
470
+
state.connection <- None;
471
+
state.account_id <- None;
472
+
473
+
hide_el "session-info";
474
+
hide_el "email-list";
475
+
476
+
(* Reset buttons *)
477
+
let connect_btn = get_el "connect-btn" in
478
+
let disconnect_btn = get_el "disconnect-btn" in
479
+
El.set_inline_style (Jstr.v "display") (Jstr.v "block") connect_btn;
480
+
El.set_inline_style (Jstr.v "display") (Jstr.v "none") disconnect_btn;
481
+
482
+
Log.info "Disconnected"
483
+
484
+
let search_emails () =
485
+
match state.connection, state.account_id with
486
+
| Some conn, Some account_id ->
487
+
let search_text = get_input_value "email-search" in
488
+
ignore (fetch_emails ~search_text conn account_id)
489
+
| _ ->
490
+
Log.warning "Not connected"
491
+
492
+
(* ---- Main ---- *)
493
+
494
+
let setup_handlers () =
495
+
let connect_btn = get_el "connect-btn" in
496
+
let disconnect_btn = get_el "disconnect-btn" in
497
+
498
+
(* Connect button click *)
499
+
ignore @@ Ev.listen Ev.click (fun _ev ->
500
+
ignore (connect ())
501
+
) (El.as_target connect_btn);
502
+
503
+
(* Disconnect button click *)
504
+
ignore @@ Ev.listen Ev.click (fun _ev ->
505
+
disconnect ()
506
+
) (El.as_target disconnect_btn);
507
+
508
+
(* Enter key in token field *)
509
+
let token_input = get_el "api-token" in
510
+
ignore @@ Ev.listen Ev.keydown (fun ev ->
511
+
let kev = Ev.as_type ev in
512
+
if Jstr.equal (Ev.Keyboard.key kev) (Jstr.v "Enter") then
513
+
ignore (connect ())
514
+
) (El.as_target token_input);
515
+
516
+
(* Search button click *)
517
+
let search_btn = get_el "search-btn" in
518
+
ignore @@ Ev.listen Ev.click (fun _ev ->
519
+
search_emails ()
520
+
) (El.as_target search_btn);
521
+
522
+
(* Enter key in search field *)
523
+
let search_input = get_el "email-search" in
524
+
ignore @@ Ev.listen Ev.keydown (fun ev ->
525
+
let kev = Ev.as_type ev in
526
+
if Jstr.equal (Ev.Keyboard.key kev) (Jstr.v "Enter") then
527
+
search_emails ()
528
+
) (El.as_target search_input)
529
+
530
+
let main () =
531
+
(* Register JSON loggers *)
532
+
Jmap_brr.set_request_logger JsonLog.request;
533
+
Jmap_brr.set_response_logger JsonLog.response;
534
+
535
+
Log.info "JMAP Email Client initialized";
536
+
Log.info "Enter your JMAP server URL and API token to connect";
537
+
setup_handlers ()
538
+
539
+
let () = main ()
+15
web/dune
+15
web/dune