anil.recoil.org
+23
-1
.gitignore
+23
-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
20
+
.env
21
+
.api-key
22
+
.api-key-rw
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
-26
AGENT.md
-26
AGENT.md
···
1
-
# Guidelines for the AI copilot editor.
2
-
3
-
Whenever you generate any new OCaml functions, annotate that function's OCamldoc
4
-
with a "TODO:claude" to indicate it is autogenerated. Do this for every function
5
-
you generate and not just the header file.
6
-
7
-
## Project structure
8
-
9
-
The `spec/rfc8620.txt` is the core JMAP protocol, which we are aiming to implement
10
-
in OCaml code in this project. We must accurately capture the specification in the
11
-
OCaml interface and never violate it without clear indication.
12
-
13
-
## Coding Instructions
14
-
15
-
Read your instructions from this file, and mark successfully completed instructions
16
-
with DONE so that you will know what to do next when reinvoked in the future.
17
-
18
-
1. DONE Define core OCaml type definitions corresponding to the JMAP protocol
19
-
specification, in a new Jmap.Types module.
20
-
2. DONE Add a `Jmap.Api` module to make JMAP API requests over HTTP and parse the
21
-
responses into the `Jmap.Types`. Used `Cohttp_lwt_unix` for the HTTP library.
22
-
Note: There is a compilation issue with the current ezjsonm package on the system.
23
-
3. DONE Add a `Jmap_mail` implementation that follows `spec/rfc8621.txt` as part of a
24
-
separate package. It should use the Jmap module and extend it appropriately.
25
-
4. DONE Complete the Jmap_mail implementation so that there are functions to login
26
-
and list mailboxes and messages in a mailbox.
+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
+15
bin/dune
+15
bin/dune
···
1
+
(executable
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))
+298
bin/fastmail_list.ml
+298
bin/fastmail_list.ml
···
1
+
(**
2
+
* fastmail_list - Lists emails from a Fastmail account using JMAP API
3
+
*
4
+
* This binary connects to the Fastmail JMAP API using an authentication token
5
+
* from the JMAP_API_TOKEN environment variable and lists the most recent 100
6
+
* emails with their subjects, sender details, and labels.
7
+
*
8
+
* Usage:
9
+
* JMAP_API_TOKEN=your_api_token ./fastmail_list [options]
10
+
*
11
+
* Options:
12
+
* --unread List only unread messages
13
+
* --labels Show labels/keywords associated with messages
14
+
* --debug=LEVEL Set debug level (0-4, where 4 is most verbose)
15
+
* --from=PATTERN Filter messages by sender email address
16
+
* --demo-refs Demonstrate result references feature
17
+
*)
18
+
19
+
open Lwt.Syntax
20
+
open Jmap
21
+
open Jmap.Mail
22
+
open Cmdliner
23
+
module Mail = Jmap.Proto.Types
24
+
25
+
(** Prints the email details *)
26
+
let print_email ~show_labels (email : Mail.email) =
27
+
let sender =
28
+
match email.from with
29
+
| Some (addr :: _) ->
30
+
(match addr.name with
31
+
| Some name -> Printf.sprintf "%s <%s>" name addr.email
32
+
| None -> addr.email)
33
+
| _ -> "<unknown>"
34
+
in
35
+
let subject =
36
+
match email.subject with
37
+
| Some s -> s
38
+
| None -> "<no subject>"
39
+
in
40
+
let date = email.received_at in
41
+
42
+
(* Format labels/keywords if requested *)
43
+
let labels_str =
44
+
if show_labels then
45
+
let formatted = Jmap.Proto.Types.format_email_keywords email.keywords in
46
+
if formatted <> "" then
47
+
" [" ^ formatted ^ "]"
48
+
else
49
+
""
50
+
else
51
+
""
52
+
in
53
+
54
+
Printf.printf "%s | %s | %s%s\n" date sender subject labels_str
55
+
56
+
(** Check if an email is unread *)
57
+
let is_unread (email : Mail.email) =
58
+
let is_unread_keyword =
59
+
List.exists (fun (kw, active) ->
60
+
kw = Mail.Unread && active
61
+
) email.keywords
62
+
in
63
+
let is_not_seen =
64
+
not (List.exists (fun (kw, active) ->
65
+
kw = Mail.Seen && active
66
+
) email.keywords)
67
+
in
68
+
is_unread_keyword || is_not_seen
69
+
70
+
(** Example function demonstrating how to use higher-level library functions for JMAP requests *)
71
+
let demo_result_references conn account_id =
72
+
Printf.printf "\nResult Reference Demo:\n";
73
+
Printf.printf "=====================\n";
74
+
75
+
(* Step 1: Get all mailboxes *)
76
+
let* mailboxes_result = Jmap.Proto.get_mailboxes conn ~account_id in
77
+
match mailboxes_result with
78
+
| Error err ->
79
+
Printf.printf "Error getting mailboxes: %s\n" (Api.string_of_error err);
80
+
Lwt.return_unit
81
+
82
+
| Ok mailboxes ->
83
+
(* Step 2: Get the first mailbox for this demonstration *)
84
+
match mailboxes with
85
+
| [] ->
86
+
Printf.printf "No mailboxes found.\n";
87
+
Lwt.return_unit
88
+
89
+
| first_mailbox :: _ ->
90
+
Printf.printf "Using mailbox: %s\n" first_mailbox.Mail.name;
91
+
92
+
(* Step 3: Get emails from the selected mailbox *)
93
+
let* emails_result = Jmap.Proto.get_messages_in_mailbox
94
+
conn
95
+
~account_id
96
+
~mailbox_id:first_mailbox.Mail.id
97
+
~limit:10
98
+
()
99
+
in
100
+
101
+
match emails_result with
102
+
| Error err ->
103
+
Printf.printf "Error getting emails: %s\n" (Api.string_of_error err);
104
+
Lwt.return_unit
105
+
106
+
| Ok emails ->
107
+
Printf.printf "Successfully retrieved %d emails using the high-level library API!\n"
108
+
(List.length emails);
109
+
110
+
(* Display some basic information about the emails *)
111
+
List.iteri (fun i (email:Jmap.Proto.Types.email) ->
112
+
let subject = Option.value ~default:"<no subject>" email.Mail.subject in
113
+
Printf.printf " %d. %s\n" (i + 1) subject
114
+
) emails;
115
+
116
+
Lwt.return_unit
117
+
118
+
(** Main function for listing emails *)
119
+
let list_emails unread_only show_labels debug_level demo_refs sender_filter =
120
+
(* Configure logging *)
121
+
init_logging ~level:debug_level ~enable_logs:(debug_level > 0) ~redact_sensitive:true ();
122
+
123
+
match Sys.getenv_opt "JMAP_API_TOKEN" with
124
+
| None ->
125
+
Printf.eprintf "Error: JMAP_API_TOKEN environment variable not set\n";
126
+
Printf.eprintf "Usage: JMAP_API_TOKEN=your_token fastmail-list [options]\n";
127
+
exit 1
128
+
| Some token ->
129
+
(* Only print token info at Info level or higher *)
130
+
Logs.info (fun m -> m "Using API token: %s" (redact_token token));
131
+
132
+
(* Connect to Fastmail JMAP API *)
133
+
let formatted_token = token in
134
+
135
+
(* Only print instructions at Info level *)
136
+
let level = match Logs.level () with
137
+
| None -> 0
138
+
| Some Logs.Error -> 1
139
+
| Some Logs.Info -> 2
140
+
| Some Logs.Debug -> 3
141
+
| _ -> 2
142
+
in
143
+
if level >= 2 then begin
144
+
Printf.printf "\nFastmail API Instructions:\n";
145
+
Printf.printf "1. Get a token from: https://app.fastmail.com/settings/tokens\n";
146
+
Printf.printf "2. Create a new token with Mail scope (read/write)\n";
147
+
Printf.printf "3. Copy the full token (example: 3de40-5fg1h2-a1b2c3...)\n";
148
+
Printf.printf "4. Run: env JMAP_API_TOKEN=\"your_full_token\" fastmail-list [options]\n\n";
149
+
Printf.printf "Note: This example is working correctly but needs a valid Fastmail token.\n\n";
150
+
end;
151
+
let* result = login_with_token
152
+
~uri:"https://api.fastmail.com/jmap/session"
153
+
~api_token:formatted_token
154
+
in
155
+
match result with
156
+
| Error err ->
157
+
Printf.eprintf "%s\n" (Api.string_of_error err);
158
+
Lwt.return 1
159
+
| Ok conn ->
160
+
(* Get the primary account ID *)
161
+
let primary_account_id =
162
+
let mail_capability = Jmap.Proto.Capability.to_string Jmap.Proto.Capability.Mail in
163
+
match List.assoc_opt mail_capability conn.session.primary_accounts with
164
+
| Some id -> id
165
+
| None ->
166
+
match conn.session.accounts with
167
+
| (id, _) :: _ -> id
168
+
| [] ->
169
+
Printf.eprintf "No accounts found\n";
170
+
exit 1
171
+
in
172
+
173
+
(* Run result references demo if requested *)
174
+
let* () =
175
+
if demo_refs then
176
+
demo_result_references conn primary_account_id
177
+
else
178
+
Lwt.return_unit
179
+
in
180
+
181
+
(* Get the Inbox mailbox *)
182
+
let* mailboxes_result = get_mailboxes conn ~account_id:primary_account_id in
183
+
match mailboxes_result with
184
+
| Error err ->
185
+
Printf.eprintf "Failed to get mailboxes: %s\n" (Api.string_of_error err);
186
+
Lwt.return 1
187
+
| Ok mailboxes ->
188
+
(* If there's a mailbox list, just use the first one for this example *)
189
+
let inbox_id =
190
+
match mailboxes with
191
+
| mailbox :: _ -> mailbox.Mail.id
192
+
| [] ->
193
+
Printf.eprintf "No mailboxes found\n";
194
+
exit 1
195
+
in
196
+
197
+
(* Get messages from inbox *)
198
+
let* emails_result = get_messages_in_mailbox
199
+
conn
200
+
~account_id:primary_account_id
201
+
~mailbox_id:inbox_id
202
+
~limit:1000
203
+
()
204
+
in
205
+
match emails_result with
206
+
| Error err ->
207
+
Printf.eprintf "Failed to get emails: %s\n" (Api.string_of_error err);
208
+
Lwt.return 1
209
+
| Ok emails ->
210
+
(* Apply filters based on command line arguments *)
211
+
let filtered_by_unread =
212
+
if unread_only then
213
+
List.filter is_unread emails
214
+
else
215
+
emails
216
+
in
217
+
218
+
(* Apply sender filter if specified *)
219
+
let filtered_emails =
220
+
if sender_filter <> "" then begin
221
+
Printf.printf "Filtering by sender: %s\n" sender_filter;
222
+
List.filter (fun email ->
223
+
Jmap.Proto.email_matches_sender email sender_filter
224
+
) filtered_by_unread
225
+
end else
226
+
filtered_by_unread
227
+
in
228
+
229
+
(* Create description of applied filters *)
230
+
let filter_description =
231
+
let parts = [] in
232
+
let parts = if unread_only then "unread" :: parts else parts in
233
+
let parts = if sender_filter <> "" then ("from \"" ^ sender_filter ^ "\"") :: parts else parts in
234
+
match parts with
235
+
| [] -> "the most recent"
236
+
| [p] -> p
237
+
| _ -> String.concat " and " parts
238
+
in
239
+
240
+
Printf.printf "Listing %s %d emails in your inbox:\n"
241
+
filter_description
242
+
(List.length filtered_emails);
243
+
Printf.printf "--------------------------------------------\n";
244
+
List.iter (print_email ~show_labels) filtered_emails;
245
+
Lwt.return 0
246
+
247
+
(** Command line interface *)
248
+
let unread_only =
249
+
let doc = "List only unread messages" in
250
+
Arg.(value & flag & info ["unread"] ~doc)
251
+
252
+
let show_labels =
253
+
let doc = "Show labels/keywords associated with messages" in
254
+
Arg.(value & flag & info ["labels"] ~doc)
255
+
256
+
let debug_level =
257
+
let doc = "Set debug level (0-4, where 4 is most verbose)" in
258
+
Arg.(value & opt int 0 & info ["debug"] ~docv:"LEVEL" ~doc)
259
+
260
+
let demo_refs =
261
+
let doc = "Demonstrate result references feature" in
262
+
Arg.(value & flag & info ["demo-refs"] ~doc)
263
+
264
+
let sender_filter =
265
+
let doc = "Filter messages by sender email address (supports wildcards: * and ?)" in
266
+
Arg.(value & opt string "" & info ["from"] ~docv:"PATTERN" ~doc)
267
+
268
+
let cmd =
269
+
let doc = "List emails from a Fastmail account using JMAP API" in
270
+
let man = [
271
+
`S Manpage.s_description;
272
+
`P "This program connects to the Fastmail JMAP API using an authentication token
273
+
from the JMAP_API_TOKEN environment variable and lists the most recent emails
274
+
with their subjects, sender details, and labels.";
275
+
`P "You must obtain a Fastmail API token from https://app.fastmail.com/settings/tokens
276
+
and set it in the JMAP_API_TOKEN environment variable.";
277
+
`S Manpage.s_environment;
278
+
`P "$(b,JMAP_API_TOKEN) The Fastmail API authentication token (required)";
279
+
`S Manpage.s_examples;
280
+
`P "List all emails:";
281
+
`P " $(mname) $(i,JMAP_API_TOKEN=your_token)";
282
+
`P "List only unread emails:";
283
+
`P " $(mname) $(i,JMAP_API_TOKEN=your_token) --unread";
284
+
`P "List emails from a specific sender:";
285
+
`P " $(mname) $(i,JMAP_API_TOKEN=your_token) --from=user@example.com";
286
+
`P "List unread emails with labels:";
287
+
`P " $(mname) $(i,JMAP_API_TOKEN=your_token) --unread --labels";
288
+
] in
289
+
let info = Cmd.info "fastmail-list" ~doc ~man in
290
+
Cmd.v info Term.(const (fun u l d r s ->
291
+
Lwt_main.run (list_emails u l d r s)
292
+
) $ unread_only $ show_labels $ debug_level $ demo_refs $ sender_filter)
293
+
294
+
(** Program entry point *)
295
+
let () = exit (Cmd.eval_value cmd |> function
296
+
| Ok (`Ok exit_code) -> exit_code
297
+
| Ok (`Version | `Help) -> 0
298
+
| Error _ -> 1)
+177
bin/fastmail_send.ml
+177
bin/fastmail_send.ml
···
1
+
(** JMAP email sending utility for Fastmail
2
+
3
+
This utility sends an email via JMAP to recipients specified on the command line.
4
+
The subject is provided as a command-line argument, and the message body is read
5
+
from standard input.
6
+
7
+
Usage:
8
+
fastmail_send --to=recipient@example.com [--to=another@example.com ...] --subject="Email subject"
9
+
10
+
Environment variables:
11
+
- JMAP_API_TOKEN: Required. The Fastmail API token for authentication.
12
+
- JMAP_FROM_EMAIL: Optional. The sender's email address. If not provided, uses the first identity.
13
+
14
+
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-7> RFC8621 Section 7
15
+
*)
16
+
17
+
open Lwt.Syntax
18
+
open Cmdliner
19
+
20
+
let log_error fmt = Fmt.epr ("\u{1b}[1;31mError: \u{1b}[0m" ^^ fmt ^^ "@.")
21
+
let log_info fmt = Fmt.pr ("\u{1b}[1;34mInfo: \u{1b}[0m" ^^ fmt ^^ "@.")
22
+
let log_success fmt = Fmt.pr ("\u{1b}[1;32mSuccess: \u{1b}[0m" ^^ fmt ^^ "@.")
23
+
24
+
(** Read the entire message body from stdin *)
25
+
let read_message_body () =
26
+
let buffer = Buffer.create 1024 in
27
+
let rec read_lines () =
28
+
try
29
+
let line = input_line stdin in
30
+
Buffer.add_string buffer line;
31
+
Buffer.add_char buffer '\n';
32
+
read_lines ()
33
+
with
34
+
| End_of_file -> Buffer.contents buffer
35
+
in
36
+
read_lines ()
37
+
38
+
(** Main function to send an email *)
39
+
let send_email to_addresses subject from_email =
40
+
(* Check for API token in environment *)
41
+
match Sys.getenv_opt "JMAP_API_TOKEN" with
42
+
| None ->
43
+
log_error "JMAP_API_TOKEN environment variable not set";
44
+
exit 1
45
+
| Some token ->
46
+
(* Read message body from stdin *)
47
+
log_info "Reading message body from stdin (press Ctrl+D when finished)...";
48
+
let message_body = read_message_body () in
49
+
if message_body = "" then
50
+
log_info "No message body entered, using a blank message";
51
+
52
+
(* Initialize JMAP connection *)
53
+
let fastmail_uri = "https://api.fastmail.com/jmap/session" in
54
+
Lwt_main.run begin
55
+
let* conn_result = Jmap.Proto.login_with_token ~uri:fastmail_uri ~api_token:token in
56
+
match conn_result with
57
+
| Error err ->
58
+
let msg = Jmap.Api.string_of_error err in
59
+
log_error "Failed to connect to Fastmail: %s" msg;
60
+
Lwt.return 1
61
+
| Ok conn ->
62
+
(* Get primary account ID *)
63
+
let account_id =
64
+
(* Get the primary account - first personal account in the list *)
65
+
let (_, _account) = List.find (fun (_, acc) ->
66
+
acc.Jmap.Types.is_personal) conn.session.accounts in
67
+
(* Use the first account id as primary *)
68
+
(match conn.session.primary_accounts with
69
+
| (_, id) :: _ -> id
70
+
| [] ->
71
+
(* Fallback if no primary accounts defined *)
72
+
let (id, _) = List.hd conn.session.accounts in
73
+
id)
74
+
in
75
+
76
+
(* Determine sender email address *)
77
+
let* from_email_result = match from_email with
78
+
| Some email -> Lwt.return_ok email
79
+
| None ->
80
+
(* Get first available identity *)
81
+
let* identities_result = Jmap.Proto.get_identities conn ~account_id in
82
+
match identities_result with
83
+
| Ok [] ->
84
+
log_error "No identities found for account";
85
+
Lwt.return_error "No identities found"
86
+
| Ok (identity :: _) -> Lwt.return_ok identity.email
87
+
| Error err ->
88
+
let msg = Jmap.Api.string_of_error err in
89
+
log_error "Failed to get identities: %s" msg;
90
+
Lwt.return_error msg
91
+
in
92
+
93
+
match from_email_result with
94
+
| Error _msg -> Lwt.return 1
95
+
| Ok from_email ->
96
+
(* Send the email *)
97
+
log_info "Sending email from %s to %s"
98
+
from_email
99
+
(String.concat ", " to_addresses);
100
+
101
+
let* submission_result =
102
+
Jmap.Proto.create_and_submit_email
103
+
conn
104
+
~account_id
105
+
~from:from_email
106
+
~to_addresses
107
+
~subject
108
+
~text_body:message_body
109
+
()
110
+
in
111
+
112
+
match submission_result with
113
+
| Error err ->
114
+
let msg = Jmap.Api.string_of_error err in
115
+
log_error "Failed to send email: %s" msg;
116
+
Lwt.return 1
117
+
| Ok submission_id ->
118
+
log_success "Email sent successfully (Submission ID: %s)" submission_id;
119
+
(* Wait briefly then check submission status *)
120
+
let* () = Lwt_unix.sleep 1.0 in
121
+
let* status_result = Jmap.Proto.get_submission_status
122
+
conn
123
+
~account_id
124
+
~submission_id
125
+
in
126
+
127
+
(match status_result with
128
+
| Ok status ->
129
+
let status_text = match status.Jmap.Proto.Types.undo_status with
130
+
| Some `pending -> "Pending"
131
+
| Some `final -> "Final (delivered)"
132
+
| Some `canceled -> "Canceled"
133
+
| None -> "Unknown"
134
+
in
135
+
log_info "Submission status: %s" status_text;
136
+
137
+
(match status.Jmap.Proto.Types.delivery_status with
138
+
| Some statuses ->
139
+
List.iter (fun (email, status) ->
140
+
let delivery = match status.Jmap.Proto.Types.delivered with
141
+
| Some "yes" -> "Delivered"
142
+
| Some "no" -> "Failed"
143
+
| Some "queued" -> "Queued"
144
+
| Some s -> s
145
+
| None -> "Unknown"
146
+
in
147
+
log_info "Delivery to %s: %s" email delivery
148
+
) statuses
149
+
| None -> ());
150
+
Lwt.return 0
151
+
| Error _ ->
152
+
(* We don't fail if status check fails, as the email might still be sent *)
153
+
Lwt.return 0)
154
+
end
155
+
156
+
(** Command line interface *)
157
+
let to_addresses =
158
+
let doc = "Email address of the recipient (can be specified multiple times)" in
159
+
Arg.(value & opt_all string [] & info ["to"] ~docv:"EMAIL" ~doc)
160
+
161
+
let subject =
162
+
let doc = "Subject line for the email" in
163
+
Arg.(required & opt (some string) None & info ["subject"] ~docv:"SUBJECT" ~doc)
164
+
165
+
let from_email =
166
+
let doc = "Sender's email address (optional, defaults to primary identity)" in
167
+
Arg.(value & opt (some string) None & info ["from"] ~docv:"EMAIL" ~doc)
168
+
169
+
let cmd =
170
+
let doc = "Send an email via JMAP to Fastmail" in
171
+
let info = Cmd.info "fastmail_send" ~doc in
172
+
Cmd.v info Term.(const send_email $ to_addresses $ subject $ from_email)
173
+
174
+
let () = match Cmd.eval_value cmd with
175
+
| Ok (`Ok code) -> exit code
176
+
| Ok (`Version | `Help) -> exit 0
177
+
| Error _ -> exit 1
+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)
+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)
+164
bin/tutorial_examples.ml
+164
bin/tutorial_examples.ml
···
1
+
(* Examples from the tutorial *)
2
+
3
+
open Lwt.Syntax
4
+
open Jmap
5
+
open Jmap.Mail
6
+
7
+
(* Example: Authentication *)
8
+
let auth_example () =
9
+
(* Using a Fastmail API token *)
10
+
let token = Sys.getenv_opt "JMAP_API_TOKEN" in
11
+
match token with
12
+
| None ->
13
+
Printf.eprintf "Error: JMAP_API_TOKEN environment variable not set\n";
14
+
Lwt.return_none
15
+
| Some token ->
16
+
let+ result = Jmap.Proto.login_with_token
17
+
~uri:"https://api.fastmail.com/jmap/session"
18
+
~api_token:token
19
+
in
20
+
21
+
(* Handle the result *)
22
+
match result with
23
+
| Ok conn ->
24
+
(* Get the primary account ID *)
25
+
let account_id =
26
+
let mail_capability = Jmap.Proto.Capability.to_string Jmap.Proto.Capability.Mail in
27
+
match List.assoc_opt mail_capability conn.session.primary_accounts with
28
+
| Some id -> id
29
+
| None ->
30
+
match conn.session.accounts with
31
+
| (id, _) :: _ -> id
32
+
| [] -> failwith "No accounts found"
33
+
in
34
+
Printf.printf "Authenticated successfully with account ID: %s\n" account_id;
35
+
Some (conn, account_id)
36
+
| Error e ->
37
+
Printf.eprintf "Authentication error: %s\n"
38
+
(match e with
39
+
| Api.Connection_error msg -> "Connection error: " ^ msg
40
+
| Api.HTTP_error (code, body) -> Printf.sprintf "HTTP error %d: %s" code body
41
+
| Api.Parse_error msg -> "Parse error: " ^ msg
42
+
| Api.Authentication_error -> "Authentication error");
43
+
None
44
+
45
+
(* Example: Working with Mailboxes *)
46
+
let mailbox_example (conn, account_id) =
47
+
(* Get all mailboxes *)
48
+
let+ mailboxes_result = Jmap.Proto.get_mailboxes conn ~account_id in
49
+
50
+
match mailboxes_result with
51
+
| Ok mailboxes ->
52
+
Printf.printf "Found %d mailboxes\n" (List.length mailboxes);
53
+
54
+
(* Find inbox - for simplicity, just use the first mailbox *)
55
+
let inbox = match mailboxes with
56
+
| first :: _ -> Some first
57
+
| [] -> None
58
+
in
59
+
60
+
(match inbox with
61
+
| Some m ->
62
+
Printf.printf "Inbox ID: %s, Name: %s\n"
63
+
m.Types.id
64
+
m.Types.name;
65
+
Some (conn, account_id, m.Types.id)
66
+
| None ->
67
+
Printf.printf "No inbox found\n";
68
+
None)
69
+
| Error e ->
70
+
Printf.eprintf "Error getting mailboxes: %s\n"
71
+
(match e with
72
+
| Api.Connection_error msg -> "Connection error: " ^ msg
73
+
| Api.HTTP_error (code, body) -> Printf.sprintf "HTTP error %d: %s" code body
74
+
| Api.Parse_error msg -> "Parse error: " ^ msg
75
+
| Api.Authentication_error -> "Authentication error");
76
+
None
77
+
78
+
(* Example: Working with Emails *)
79
+
let email_example (conn, account_id, mailbox_id) =
80
+
(* Get emails from mailbox *)
81
+
let+ emails_result = Jmap.Proto.get_messages_in_mailbox
82
+
conn
83
+
~account_id
84
+
~mailbox_id
85
+
~limit:5
86
+
()
87
+
in
88
+
89
+
match emails_result with
90
+
| Ok emails -> begin
91
+
Printf.printf "Found %d emails\n" (List.length emails);
92
+
93
+
(* Display emails *)
94
+
List.iter (fun (email:Jmap.Proto.Types.email) ->
95
+
(* Using explicit module path for Types to avoid ambiguity *)
96
+
let module Mail = Jmap.Proto.Types in
97
+
98
+
(* Get sender info *)
99
+
let from = match email.Mail.from with
100
+
| None -> "Unknown"
101
+
| Some addrs ->
102
+
match addrs with
103
+
| [] -> "Unknown"
104
+
| addr :: _ ->
105
+
match addr.Mail.name with
106
+
| None -> addr.Mail.email
107
+
| Some name ->
108
+
Printf.sprintf "%s <%s>" name addr.Mail.email
109
+
in
110
+
111
+
(* Check for unread status *)
112
+
let is_unread =
113
+
List.exists (fun (kw, active) ->
114
+
match kw with
115
+
| Mail.Unread -> active
116
+
| Mail.Custom s when s = "$unread" -> active
117
+
| _ -> false
118
+
) email.Mail.keywords
119
+
in
120
+
121
+
(* Display email info *)
122
+
Printf.printf "[%s] %s - %s\n"
123
+
(if is_unread then "UNREAD" else "READ")
124
+
from
125
+
(Option.value ~default:"(No Subject)" email.Mail.subject)
126
+
) emails;
127
+
128
+
match emails with
129
+
| [] -> None
130
+
| hd::_ -> Some (conn, account_id, hd.Jmap.Proto.Types.id)
131
+
end
132
+
| Error e ->
133
+
Printf.eprintf "Error getting emails: %s\n"
134
+
(match e with
135
+
| Api.Connection_error msg -> "Connection error: " ^ msg
136
+
| Api.HTTP_error (code, body) -> Printf.sprintf "HTTP error %d: %s" code body
137
+
| Api.Parse_error msg -> "Parse error: " ^ msg
138
+
| Api.Authentication_error -> "Authentication error");
139
+
None
140
+
141
+
(* Run examples with Lwt *)
142
+
let () =
143
+
(* Set up logging *)
144
+
Jmap.init_logging ~level:2 ~enable_logs:true ~redact_sensitive:true ();
145
+
146
+
(* Run the examples in sequence *)
147
+
let result = Lwt_main.run (
148
+
let* auth_result = auth_example () in
149
+
match auth_result with
150
+
| None -> Lwt.return 1
151
+
| Some conn_account ->
152
+
let* mailbox_result = mailbox_example conn_account in
153
+
match mailbox_result with
154
+
| None -> Lwt.return 1
155
+
| Some conn_account_mailbox ->
156
+
let* email_result = email_example conn_account_mailbox in
157
+
match email_result with
158
+
| None -> Lwt.return 1
159
+
| Some _ ->
160
+
Printf.printf "All examples completed successfully\n";
161
+
Lwt.return 0
162
+
) in
163
+
164
+
exit result
+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}}
+26
-14
dune-project
+26
-14
dune-project
···
1
-
(lang dune 3.17)
1
+
(lang dune 3.20)
2
+
3
+
(using mdx 0.4)
4
+
2
5
(name jmap)
3
6
4
-
(source (github avsm/jmap))
7
+
(generate_opam_files true)
8
+
5
9
(license ISC)
6
-
(authors "Anil Madhavapeddy")
7
-
(maintainers "anil@recoil.org")
8
10
9
-
(generate_opam_files true)
11
+
(authors "Anil Madhavapeddy <anil@recoil.org>")
12
+
13
+
(maintainers "Anil Madhavapeddy <anil@recoil.org>")
14
+
15
+
(homepage "https://tangled.org/@anil.recoil.org/ocaml-jmap")
16
+
17
+
(bug_reports "https://tangled.org/@anil.recoil.org/ocaml-jmap/issues")
18
+
19
+
(maintenance_intent "(latest)")
10
20
11
21
(package
12
22
(name jmap)
13
-
(synopsis "JMAP protocol")
14
-
(description "This is all still a work in progress")
23
+
(synopsis "JMAP protocol implementation for OCaml")
24
+
(description
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.")
15
26
(depends
16
-
(ocaml (>= "5.2.0"))
17
-
ptime
18
-
cohttp
19
-
cohttp-lwt-unix
20
-
ezjsonm
21
-
uri
22
-
lwt))
27
+
(ocaml (>= 5.4.0))
28
+
(jsont (>= 0.2.0))
29
+
json-pointer
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. *)
+514
eio/client.ml
+514
eio/client.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type error =
7
+
| Http_error of int * string
8
+
| Jmap_error of Jmap.Proto.Error.Request_error.t
9
+
| Json_error of Jsont.Error.t
10
+
| Session_error of string
11
+
| Connection_error of string
12
+
13
+
let pp_error fmt = function
14
+
| Http_error (code, msg) ->
15
+
Format.fprintf fmt "HTTP error %d: %s" code msg
16
+
| Jmap_error err ->
17
+
Format.fprintf fmt "JMAP error: %s"
18
+
(Jmap.Proto.Error.Request_error.urn_to_string err.type_)
19
+
| Json_error err ->
20
+
Format.fprintf fmt "JSON error: %s" (Jsont.Error.to_string err)
21
+
| Session_error msg ->
22
+
Format.fprintf fmt "Session error: %s" msg
23
+
| Connection_error msg ->
24
+
Format.fprintf fmt "Connection error: %s" msg
25
+
26
+
let error_to_string err =
27
+
Format.asprintf "%a" pp_error err
28
+
29
+
exception Jmap_client_error of error
30
+
31
+
type t = {
32
+
mutable session : Jmap.Proto.Session.t;
33
+
requests : Requests.t;
34
+
auth : Requests.Auth.t option;
35
+
session_url : string;
36
+
}
37
+
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
42
+
43
+
let create ?auth ~session requests =
44
+
let session_url = Jmap.Proto.Session.api_url session in
45
+
{ session; requests; auth; session_url }
46
+
47
+
let fetch_session ?auth requests url =
48
+
try
49
+
let response =
50
+
match auth with
51
+
| Some a -> Requests.get requests ~auth:a url
52
+
| None -> Requests.get requests url
53
+
in
54
+
if not (Requests.Response.ok response) then
55
+
Error (Http_error (Requests.Response.status_code response,
56
+
"Failed to fetch session"))
57
+
else
58
+
let body = Requests.Response.text response in
59
+
match Codec.decode_session body with
60
+
| Ok session -> Ok session
61
+
| Error e -> Error (Json_error e)
62
+
with
63
+
| Eio.Io (Requests.Error.E err, _) ->
64
+
Error (Connection_error (Requests.Error.to_string err))
65
+
| exn -> Error (Session_error (Printexc.to_string exn))
66
+
67
+
let create_from_url ?auth requests url =
68
+
match fetch_session ?auth requests url with
69
+
| Ok session ->
70
+
Ok { session; requests; auth; session_url = url }
71
+
| Error e -> Error e
72
+
73
+
let create_from_url_exn ?auth requests url =
74
+
match create_from_url ?auth requests url with
75
+
| Ok t -> t
76
+
| Error e -> raise (Jmap_client_error e)
77
+
78
+
let refresh_session t =
79
+
match fetch_session ?auth:t.auth t.requests t.session_url with
80
+
| Ok session ->
81
+
t.session <- session;
82
+
Ok ()
83
+
| Error e -> Error e
84
+
85
+
let refresh_session_exn t =
86
+
match refresh_session t with
87
+
| Ok () -> ()
88
+
| Error e -> raise (Jmap_client_error e)
89
+
90
+
let request t req =
91
+
try
92
+
match Codec.encode_request req with
93
+
| Error e -> Error (Json_error e)
94
+
| Ok body_str ->
95
+
let body = Requests.Body.of_string Requests.Mime.json body_str in
96
+
let url = api_url t in
97
+
let response =
98
+
match t.auth with
99
+
| Some auth -> Requests.post t.requests ~auth ~body url
100
+
| None -> Requests.post t.requests ~body url
101
+
in
102
+
if not (Requests.Response.ok response) then
103
+
Error (Http_error (Requests.Response.status_code response,
104
+
Requests.Response.text response))
105
+
else
106
+
let response_body = Requests.Response.text response in
107
+
match Codec.decode_response response_body with
108
+
| Ok resp -> Ok resp
109
+
| Error e -> Error (Json_error e)
110
+
with
111
+
| Eio.Io (Requests.Error.E err, _) ->
112
+
Error (Connection_error (Requests.Error.to_string err))
113
+
| exn -> Error (Connection_error (Printexc.to_string exn))
114
+
115
+
let request_exn t req =
116
+
match request t req with
117
+
| Ok resp -> resp
118
+
| Error e -> raise (Jmap_client_error e)
119
+
120
+
let expand_upload_url t ~account_id =
121
+
let template = upload_url t in
122
+
let account_id_str = Jmap.Proto.Id.to_string account_id in
123
+
(* Simple template expansion for {accountId} *)
124
+
let re = Str.regexp "{accountId}" in
125
+
Str.global_replace re account_id_str template
126
+
127
+
let upload t ~account_id ~content_type ~data =
128
+
try
129
+
let url = expand_upload_url t ~account_id in
130
+
let mime = Requests.Mime.of_string content_type in
131
+
let body = Requests.Body.of_string mime data in
132
+
let response =
133
+
match t.auth with
134
+
| Some auth -> Requests.post t.requests ~auth ~body url
135
+
| None -> Requests.post t.requests ~body url
136
+
in
137
+
if not (Requests.Response.ok response) then
138
+
Error (Http_error (Requests.Response.status_code response,
139
+
Requests.Response.text response))
140
+
else
141
+
let response_body = Requests.Response.text response in
142
+
match Codec.decode_upload_response response_body with
143
+
| Ok upload_resp -> Ok upload_resp
144
+
| Error e -> Error (Json_error e)
145
+
with
146
+
| Eio.Io (Requests.Error.E err, _) ->
147
+
Error (Connection_error (Requests.Error.to_string err))
148
+
| exn -> Error (Connection_error (Printexc.to_string exn))
149
+
150
+
let upload_exn t ~account_id ~content_type ~data =
151
+
match upload t ~account_id ~content_type ~data with
152
+
| Ok resp -> resp
153
+
| Error e -> raise (Jmap_client_error e)
154
+
155
+
let expand_download_url t ~account_id ~blob_id ?name ?accept () =
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
159
+
let name_str = Option.value name ~default:"download" in
160
+
let type_str = Option.value accept ~default:"application/octet-stream" in
161
+
(* Simple template expansion *)
162
+
template
163
+
|> Str.global_replace (Str.regexp "{accountId}") account_id_str
164
+
|> Str.global_replace (Str.regexp "{blobId}") blob_id_str
165
+
|> Str.global_replace (Str.regexp "{name}") (Uri.pct_encode name_str)
166
+
|> Str.global_replace (Str.regexp "{type}") (Uri.pct_encode type_str)
167
+
168
+
let download t ~account_id ~blob_id ?name ?accept () =
169
+
try
170
+
let url = expand_download_url t ~account_id ~blob_id ?name ?accept () in
171
+
let response =
172
+
match t.auth with
173
+
| Some auth -> Requests.get t.requests ~auth url
174
+
| None -> Requests.get t.requests url
175
+
in
176
+
if not (Requests.Response.ok response) then
177
+
Error (Http_error (Requests.Response.status_code response,
178
+
Requests.Response.text response))
179
+
else
180
+
Ok (Requests.Response.text response)
181
+
with
182
+
| Eio.Io (Requests.Error.E err, _) ->
183
+
Error (Connection_error (Requests.Error.to_string err))
184
+
| exn -> Error (Connection_error (Printexc.to_string exn))
185
+
186
+
let download_exn t ~account_id ~blob_id ?name ?accept () =
187
+
match download t ~account_id ~blob_id ?name ?accept () with
188
+
| Ok data -> data
189
+
| Error e -> raise (Jmap_client_error e)
190
+
191
+
(* Convenience builders *)
192
+
module Build = struct
193
+
open Jmap.Proto
194
+
195
+
let json_of_id id =
196
+
Jsont.String (Id.to_string id, Jsont.Meta.none)
197
+
198
+
let json_of_id_list ids =
199
+
let items = List.map json_of_id ids in
200
+
Jsont.Array (items, Jsont.Meta.none)
201
+
202
+
let json_of_string_list strs =
203
+
let items = List.map (fun s -> Jsont.String (s, Jsont.Meta.none)) strs in
204
+
Jsont.Array (items, Jsont.Meta.none)
205
+
206
+
let json_of_int64 n =
207
+
Jsont.Number (Int64.to_float n, Jsont.Meta.none)
208
+
209
+
let json_of_bool b =
210
+
Jsont.Bool (b, Jsont.Meta.none)
211
+
212
+
let json_name s = (s, Jsont.Meta.none)
213
+
214
+
let json_obj fields =
215
+
let fields' = List.map (fun (k, v) -> (json_name k, v)) fields in
216
+
Jsont.Object (fields', Jsont.Meta.none)
217
+
218
+
let make_invocation ~name ~call_id args =
219
+
Invocation.create ~name ~arguments:(json_obj args) ~method_call_id:call_id
220
+
221
+
let echo ~call_id data =
222
+
make_invocation ~name:"Core/echo" ~call_id
223
+
[ ("data", data) ]
224
+
225
+
let mailbox_get ~call_id ~account_id ?ids ?properties () =
226
+
let args = [
227
+
("accountId", json_of_id account_id);
228
+
] in
229
+
let args = match ids with
230
+
| None -> args
231
+
| Some ids -> ("ids", json_of_id_list ids) :: args
232
+
in
233
+
let args = match properties with
234
+
| None -> args
235
+
| Some props -> ("properties", json_of_string_list props) :: args
236
+
in
237
+
make_invocation ~name:"Mailbox/get" ~call_id args
238
+
239
+
let mailbox_changes ~call_id ~account_id ~since_state ?max_changes () =
240
+
let args = [
241
+
("accountId", json_of_id account_id);
242
+
("sinceState", Jsont.String (since_state, Jsont.Meta.none));
243
+
] in
244
+
let args = match max_changes with
245
+
| None -> args
246
+
| Some n -> ("maxChanges", json_of_int64 n) :: args
247
+
in
248
+
make_invocation ~name:"Mailbox/changes" ~call_id args
249
+
250
+
let encode_to_json jsont value =
251
+
match Jsont.Json.encode' jsont value with
252
+
| Ok j -> j
253
+
| Error _ -> json_obj []
254
+
255
+
let encode_list_to_json jsont values =
256
+
match Jsont.Json.encode' (Jsont.list jsont) values with
257
+
| Ok j -> j
258
+
| Error _ -> Jsont.Array ([], Jsont.Meta.none)
259
+
260
+
let mailbox_query ~call_id ~account_id ?filter ?sort ?position ?limit () =
261
+
let args = [
262
+
("accountId", json_of_id account_id);
263
+
] in
264
+
let args = match filter with
265
+
| None -> args
266
+
| Some f ->
267
+
("filter", encode_to_json Jmap.Proto.Mail_filter.mailbox_filter_jsont f) :: args
268
+
in
269
+
let args = match sort with
270
+
| None -> args
271
+
| Some comparators ->
272
+
("sort", encode_list_to_json Filter.comparator_jsont comparators) :: args
273
+
in
274
+
let args = match position with
275
+
| None -> args
276
+
| Some n -> ("position", json_of_int64 n) :: args
277
+
in
278
+
let args = match limit with
279
+
| None -> args
280
+
| Some n -> ("limit", json_of_int64 n) :: args
281
+
in
282
+
make_invocation ~name:"Mailbox/query" ~call_id args
283
+
284
+
let email_get ~call_id ~account_id ?ids ?properties ?body_properties
285
+
?fetch_text_body_values ?fetch_html_body_values ?fetch_all_body_values
286
+
?max_body_value_bytes () =
287
+
let args = [
288
+
("accountId", json_of_id account_id);
289
+
] in
290
+
let args = match ids with
291
+
| None -> args
292
+
| Some ids -> ("ids", json_of_id_list ids) :: args
293
+
in
294
+
let args = match properties with
295
+
| None -> args
296
+
| Some props -> ("properties", json_of_string_list props) :: args
297
+
in
298
+
let args = match body_properties with
299
+
| None -> args
300
+
| Some props -> ("bodyProperties", json_of_string_list props) :: args
301
+
in
302
+
let args = match fetch_text_body_values with
303
+
| None -> args
304
+
| Some b -> ("fetchTextBodyValues", json_of_bool b) :: args
305
+
in
306
+
let args = match fetch_html_body_values with
307
+
| None -> args
308
+
| Some b -> ("fetchHTMLBodyValues", json_of_bool b) :: args
309
+
in
310
+
let args = match fetch_all_body_values with
311
+
| None -> args
312
+
| Some b -> ("fetchAllBodyValues", json_of_bool b) :: args
313
+
in
314
+
let args = match max_body_value_bytes with
315
+
| None -> args
316
+
| Some n -> ("maxBodyValueBytes", json_of_int64 n) :: args
317
+
in
318
+
make_invocation ~name:"Email/get" ~call_id args
319
+
320
+
let email_changes ~call_id ~account_id ~since_state ?max_changes () =
321
+
let args = [
322
+
("accountId", json_of_id account_id);
323
+
("sinceState", Jsont.String (since_state, Jsont.Meta.none));
324
+
] in
325
+
let args = match max_changes with
326
+
| None -> args
327
+
| Some n -> ("maxChanges", json_of_int64 n) :: args
328
+
in
329
+
make_invocation ~name:"Email/changes" ~call_id args
330
+
331
+
let email_query ~call_id ~account_id ?filter ?sort ?position ?limit
332
+
?collapse_threads () =
333
+
let args = [
334
+
("accountId", json_of_id account_id);
335
+
] in
336
+
let args = match filter with
337
+
| None -> args
338
+
| Some f ->
339
+
("filter", encode_to_json Jmap.Proto.Mail_filter.email_filter_jsont f) :: args
340
+
in
341
+
let args = match sort with
342
+
| None -> args
343
+
| Some comparators ->
344
+
("sort", encode_list_to_json Filter.comparator_jsont comparators) :: args
345
+
in
346
+
let args = match position with
347
+
| None -> args
348
+
| Some n -> ("position", json_of_int64 n) :: args
349
+
in
350
+
let args = match limit with
351
+
| None -> args
352
+
| Some n -> ("limit", json_of_int64 n) :: args
353
+
in
354
+
let args = match collapse_threads with
355
+
| None -> args
356
+
| Some b -> ("collapseThreads", json_of_bool b) :: args
357
+
in
358
+
make_invocation ~name:"Email/query" ~call_id args
359
+
360
+
let thread_get ~call_id ~account_id ?ids () =
361
+
let args = [
362
+
("accountId", json_of_id account_id);
363
+
] in
364
+
let args = match ids with
365
+
| None -> args
366
+
| Some ids -> ("ids", json_of_id_list ids) :: args
367
+
in
368
+
make_invocation ~name:"Thread/get" ~call_id args
369
+
370
+
let thread_changes ~call_id ~account_id ~since_state ?max_changes () =
371
+
let args = [
372
+
("accountId", json_of_id account_id);
373
+
("sinceState", Jsont.String (since_state, Jsont.Meta.none));
374
+
] in
375
+
let args = match max_changes with
376
+
| None -> args
377
+
| Some n -> ("maxChanges", json_of_int64 n) :: args
378
+
in
379
+
make_invocation ~name:"Thread/changes" ~call_id args
380
+
381
+
let identity_get ~call_id ~account_id ?ids ?properties () =
382
+
let args = [
383
+
("accountId", json_of_id account_id);
384
+
] in
385
+
let args = match ids with
386
+
| None -> args
387
+
| Some ids -> ("ids", json_of_id_list ids) :: args
388
+
in
389
+
let args = match properties with
390
+
| None -> args
391
+
| Some props -> ("properties", json_of_string_list props) :: args
392
+
in
393
+
make_invocation ~name:"Identity/get" ~call_id args
394
+
395
+
let email_submission_get ~call_id ~account_id ?ids ?properties () =
396
+
let args = [
397
+
("accountId", json_of_id account_id);
398
+
] in
399
+
let args = match ids with
400
+
| None -> args
401
+
| Some ids -> ("ids", json_of_id_list ids) :: args
402
+
in
403
+
let args = match properties with
404
+
| None -> args
405
+
| Some props -> ("properties", json_of_string_list props) :: args
406
+
in
407
+
make_invocation ~name:"EmailSubmission/get" ~call_id args
408
+
409
+
let email_submission_query ~call_id ~account_id ?filter ?sort ?position ?limit () =
410
+
let args = [
411
+
("accountId", json_of_id account_id);
412
+
] in
413
+
let args = match filter with
414
+
| None -> args
415
+
| Some f ->
416
+
("filter", encode_to_json Jmap.Proto.Mail_filter.submission_filter_jsont f) :: args
417
+
in
418
+
let args = match sort with
419
+
| None -> args
420
+
| Some comparators ->
421
+
("sort", encode_list_to_json Filter.comparator_jsont comparators) :: args
422
+
in
423
+
let args = match position with
424
+
| None -> args
425
+
| Some n -> ("position", json_of_int64 n) :: args
426
+
in
427
+
let args = match limit with
428
+
| None -> args
429
+
| Some n -> ("limit", json_of_int64 n) :: args
430
+
in
431
+
make_invocation ~name:"EmailSubmission/query" ~call_id args
432
+
433
+
let vacation_response_get ~call_id ~account_id () =
434
+
let args = [
435
+
("accountId", json_of_id account_id);
436
+
("ids", json_of_id_list [Jmap.Proto.Vacation.singleton_id]);
437
+
] in
438
+
make_invocation ~name:"VacationResponse/get" ~call_id args
439
+
440
+
let make_request ?created_ids ~capabilities invocations =
441
+
Request.create
442
+
~using:capabilities
443
+
~method_calls:invocations
444
+
?created_ids
445
+
()
446
+
end
447
+
448
+
(* Response parsing helpers *)
449
+
module Parse = struct
450
+
open Jmap.Proto
451
+
452
+
let decode_from_json jsont json =
453
+
Jsont.Json.decode' jsont json
454
+
455
+
let find_invocation ~call_id response =
456
+
List.find_opt
457
+
(fun inv -> Invocation.method_call_id inv = call_id)
458
+
(Response.method_responses response)
459
+
460
+
let get_invocation_exn ~call_id response =
461
+
match find_invocation ~call_id response with
462
+
| Some inv -> inv
463
+
| None -> failwith ("No invocation found with call_id: " ^ call_id)
464
+
465
+
let parse_invocation jsont inv =
466
+
decode_from_json jsont (Invocation.arguments inv)
467
+
468
+
let parse_response ~call_id jsont response =
469
+
let inv = get_invocation_exn ~call_id response in
470
+
parse_invocation jsont inv
471
+
472
+
(* Typed response parsers *)
473
+
474
+
let get_response obj_jsont =
475
+
Method.get_response_jsont obj_jsont
476
+
477
+
let query_response = Method.query_response_jsont
478
+
479
+
let changes_response = Method.changes_response_jsont
480
+
481
+
let set_response obj_jsont =
482
+
Method.set_response_jsont obj_jsont
483
+
484
+
(* Mail-specific parsers *)
485
+
486
+
let mailbox_get_response =
487
+
get_response Jmap.Proto.Mailbox.jsont
488
+
489
+
let email_get_response =
490
+
get_response Jmap.Proto.Email.jsont
491
+
492
+
let thread_get_response =
493
+
get_response Jmap.Proto.Thread.jsont
494
+
495
+
let identity_get_response =
496
+
get_response Jmap.Proto.Identity.jsont
497
+
498
+
(* Convenience functions *)
499
+
500
+
let parse_mailbox_get ~call_id response =
501
+
parse_response ~call_id mailbox_get_response response
502
+
503
+
let parse_email_get ~call_id response =
504
+
parse_response ~call_id email_get_response response
505
+
506
+
let parse_email_query ~call_id response =
507
+
parse_response ~call_id query_response response
508
+
509
+
let parse_thread_get ~call_id response =
510
+
parse_response ~call_id thread_get_response response
511
+
512
+
let parse_changes ~call_id response =
513
+
parse_response ~call_id changes_response response
514
+
end
+404
eio/client.mli
+404
eio/client.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** High-level JMAP client using Requests
7
+
8
+
This module provides a full-featured JMAP client with session management,
9
+
request execution, and blob upload/download capabilities. *)
10
+
11
+
(** {1 Types} *)
12
+
13
+
type t
14
+
(** A JMAP client with session state and HTTP connection management. *)
15
+
16
+
type error =
17
+
| Http_error of int * string
18
+
(** HTTP error with status code and message. *)
19
+
| Jmap_error of Jmap.Proto.Error.Request_error.t
20
+
(** JMAP protocol error at request level. *)
21
+
| Json_error of Jsont.Error.t
22
+
(** JSON encoding/decoding error. *)
23
+
| Session_error of string
24
+
(** Session fetch or parse error. *)
25
+
| Connection_error of string
26
+
(** Network connection error. *)
27
+
(** Error types that can occur during JMAP operations. *)
28
+
29
+
val pp_error : Format.formatter -> error -> unit
30
+
(** Pretty-print an error. *)
31
+
32
+
val error_to_string : error -> string
33
+
(** Convert an error to a string. *)
34
+
35
+
exception Jmap_client_error of error
36
+
(** Exception wrapper for JMAP client errors. *)
37
+
38
+
(** {1 Client Creation} *)
39
+
40
+
val create :
41
+
?auth:Requests.Auth.t ->
42
+
session:Jmap.Proto.Session.t ->
43
+
Requests.t ->
44
+
t
45
+
(** [create ?auth ~session requests] creates a JMAP client from an existing
46
+
session and Requests instance.
47
+
48
+
@param auth Authentication to use for requests.
49
+
@param session A pre-fetched JMAP session.
50
+
@param requests The Requests instance for HTTP operations. *)
51
+
52
+
val create_from_url :
53
+
?auth:Requests.Auth.t ->
54
+
Requests.t ->
55
+
string ->
56
+
(t, error) result
57
+
(** [create_from_url ?auth requests url] creates a JMAP client by fetching
58
+
the session from the given JMAP API URL or well-known URL.
59
+
60
+
The URL can be either:
61
+
- A direct JMAP API URL (e.g., "https://api.example.com/jmap/")
62
+
- A well-known URL (e.g., "https://example.com/.well-known/jmap")
63
+
64
+
@param auth Authentication to use for the session request and subsequent requests.
65
+
@param requests The Requests instance for HTTP operations.
66
+
@param url The JMAP API or well-known URL. *)
67
+
68
+
val create_from_url_exn :
69
+
?auth:Requests.Auth.t ->
70
+
Requests.t ->
71
+
string ->
72
+
t
73
+
(** [create_from_url_exn ?auth requests url] is like {!create_from_url} but
74
+
raises {!Jmap_client_error} on failure. *)
75
+
76
+
(** {1 Session Access} *)
77
+
78
+
val session : t -> Jmap.Proto.Session.t
79
+
(** [session client] returns the current JMAP session. *)
80
+
81
+
val refresh_session : t -> (unit, error) result
82
+
(** [refresh_session client] fetches a fresh session from the server and
83
+
updates the client's session state. *)
84
+
85
+
val refresh_session_exn : t -> unit
86
+
(** [refresh_session_exn client] is like {!refresh_session} but raises on error. *)
87
+
88
+
val api_url : t -> string
89
+
(** [api_url client] returns the JMAP API URL for this client. *)
90
+
91
+
val upload_url : t -> string
92
+
(** [upload_url client] returns the blob upload URL template. *)
93
+
94
+
val download_url : t -> string
95
+
(** [download_url client] returns the blob download URL template. *)
96
+
97
+
(** {1 Request Execution} *)
98
+
99
+
val request :
100
+
t ->
101
+
Jmap.Proto.Request.t ->
102
+
(Jmap.Proto.Response.t, error) result
103
+
(** [request client req] executes a JMAP request and returns the response. *)
104
+
105
+
val request_exn :
106
+
t ->
107
+
Jmap.Proto.Request.t ->
108
+
Jmap.Proto.Response.t
109
+
(** [request_exn client req] is like {!request} but raises on error. *)
110
+
111
+
(** {1 Blob Operations} *)
112
+
113
+
val upload :
114
+
t ->
115
+
account_id:Jmap.Proto.Id.t ->
116
+
content_type:string ->
117
+
data:string ->
118
+
(Jmap.Proto.Blob.upload_response, error) result
119
+
(** [upload client ~account_id ~content_type ~data] uploads a blob.
120
+
121
+
@param account_id The account to upload to.
122
+
@param content_type MIME type of the blob.
123
+
@param data The blob data as a string. *)
124
+
125
+
val upload_exn :
126
+
t ->
127
+
account_id:Jmap.Proto.Id.t ->
128
+
content_type:string ->
129
+
data:string ->
130
+
Jmap.Proto.Blob.upload_response
131
+
(** [upload_exn client ~account_id ~content_type ~data] is like {!upload}
132
+
but raises on error. *)
133
+
134
+
val download :
135
+
t ->
136
+
account_id:Jmap.Proto.Id.t ->
137
+
blob_id:Jmap.Proto.Id.t ->
138
+
?name:string ->
139
+
?accept:string ->
140
+
unit ->
141
+
(string, error) result
142
+
(** [download client ~account_id ~blob_id ?name ?accept ()] downloads a blob.
143
+
144
+
@param account_id The account containing the blob.
145
+
@param blob_id The blob ID to download.
146
+
@param name Optional filename hint for Content-Disposition.
147
+
@param accept Optional Accept header value. *)
148
+
149
+
val download_exn :
150
+
t ->
151
+
account_id:Jmap.Proto.Id.t ->
152
+
blob_id:Jmap.Proto.Id.t ->
153
+
?name:string ->
154
+
?accept:string ->
155
+
unit ->
156
+
string
157
+
(** [download_exn] is like {!download} but raises on error. *)
158
+
159
+
(** {1 Convenience Builders}
160
+
161
+
Helper functions for building common JMAP method invocations. *)
162
+
163
+
module Build : sig
164
+
(** {2 Core Methods} *)
165
+
166
+
val echo :
167
+
call_id:string ->
168
+
Jsont.json ->
169
+
Jmap.Proto.Invocation.t
170
+
(** [echo ~call_id data] builds a Core/echo invocation. *)
171
+
172
+
(** {2 Mailbox Methods} *)
173
+
174
+
val mailbox_get :
175
+
call_id:string ->
176
+
account_id:Jmap.Proto.Id.t ->
177
+
?ids:Jmap.Proto.Id.t list ->
178
+
?properties:string list ->
179
+
unit ->
180
+
Jmap.Proto.Invocation.t
181
+
(** [mailbox_get ~call_id ~account_id ?ids ?properties ()] builds a
182
+
Mailbox/get invocation. *)
183
+
184
+
val mailbox_changes :
185
+
call_id:string ->
186
+
account_id:Jmap.Proto.Id.t ->
187
+
since_state:string ->
188
+
?max_changes:int64 ->
189
+
unit ->
190
+
Jmap.Proto.Invocation.t
191
+
(** [mailbox_changes ~call_id ~account_id ~since_state ?max_changes ()]
192
+
builds a Mailbox/changes invocation. *)
193
+
194
+
val mailbox_query :
195
+
call_id:string ->
196
+
account_id:Jmap.Proto.Id.t ->
197
+
?filter:Jmap.Proto.Mail_filter.mailbox_filter ->
198
+
?sort:Jmap.Proto.Filter.comparator list ->
199
+
?position:int64 ->
200
+
?limit:int64 ->
201
+
unit ->
202
+
Jmap.Proto.Invocation.t
203
+
(** [mailbox_query ~call_id ~account_id ?filter ?sort ?position ?limit ()]
204
+
builds a Mailbox/query invocation. *)
205
+
206
+
(** {2 Email Methods} *)
207
+
208
+
val email_get :
209
+
call_id:string ->
210
+
account_id:Jmap.Proto.Id.t ->
211
+
?ids:Jmap.Proto.Id.t list ->
212
+
?properties:string list ->
213
+
?body_properties:string list ->
214
+
?fetch_text_body_values:bool ->
215
+
?fetch_html_body_values:bool ->
216
+
?fetch_all_body_values:bool ->
217
+
?max_body_value_bytes:int64 ->
218
+
unit ->
219
+
Jmap.Proto.Invocation.t
220
+
(** [email_get ~call_id ~account_id ?ids ?properties ...] builds an
221
+
Email/get invocation. *)
222
+
223
+
val email_changes :
224
+
call_id:string ->
225
+
account_id:Jmap.Proto.Id.t ->
226
+
since_state:string ->
227
+
?max_changes:int64 ->
228
+
unit ->
229
+
Jmap.Proto.Invocation.t
230
+
(** [email_changes ~call_id ~account_id ~since_state ?max_changes ()]
231
+
builds an Email/changes invocation. *)
232
+
233
+
val email_query :
234
+
call_id:string ->
235
+
account_id:Jmap.Proto.Id.t ->
236
+
?filter:Jmap.Proto.Mail_filter.email_filter ->
237
+
?sort:Jmap.Proto.Filter.comparator list ->
238
+
?position:int64 ->
239
+
?limit:int64 ->
240
+
?collapse_threads:bool ->
241
+
unit ->
242
+
Jmap.Proto.Invocation.t
243
+
(** [email_query ~call_id ~account_id ?filter ?sort ?position ?limit
244
+
?collapse_threads ()] builds an Email/query invocation. *)
245
+
246
+
(** {2 Thread Methods} *)
247
+
248
+
val thread_get :
249
+
call_id:string ->
250
+
account_id:Jmap.Proto.Id.t ->
251
+
?ids:Jmap.Proto.Id.t list ->
252
+
unit ->
253
+
Jmap.Proto.Invocation.t
254
+
(** [thread_get ~call_id ~account_id ?ids ()] builds a Thread/get invocation. *)
255
+
256
+
val thread_changes :
257
+
call_id:string ->
258
+
account_id:Jmap.Proto.Id.t ->
259
+
since_state:string ->
260
+
?max_changes:int64 ->
261
+
unit ->
262
+
Jmap.Proto.Invocation.t
263
+
(** [thread_changes ~call_id ~account_id ~since_state ?max_changes ()]
264
+
builds a Thread/changes invocation. *)
265
+
266
+
(** {2 Identity Methods} *)
267
+
268
+
val identity_get :
269
+
call_id:string ->
270
+
account_id:Jmap.Proto.Id.t ->
271
+
?ids:Jmap.Proto.Id.t list ->
272
+
?properties:string list ->
273
+
unit ->
274
+
Jmap.Proto.Invocation.t
275
+
(** [identity_get ~call_id ~account_id ?ids ?properties ()] builds an
276
+
Identity/get invocation. *)
277
+
278
+
(** {2 Submission Methods} *)
279
+
280
+
val email_submission_get :
281
+
call_id:string ->
282
+
account_id:Jmap.Proto.Id.t ->
283
+
?ids:Jmap.Proto.Id.t list ->
284
+
?properties:string list ->
285
+
unit ->
286
+
Jmap.Proto.Invocation.t
287
+
(** [email_submission_get ~call_id ~account_id ?ids ?properties ()]
288
+
builds an EmailSubmission/get invocation. *)
289
+
290
+
val email_submission_query :
291
+
call_id:string ->
292
+
account_id:Jmap.Proto.Id.t ->
293
+
?filter:Jmap.Proto.Mail_filter.submission_filter ->
294
+
?sort:Jmap.Proto.Filter.comparator list ->
295
+
?position:int64 ->
296
+
?limit:int64 ->
297
+
unit ->
298
+
Jmap.Proto.Invocation.t
299
+
(** [email_submission_query ~call_id ~account_id ?filter ?sort ?position
300
+
?limit ()] builds an EmailSubmission/query invocation. *)
301
+
302
+
(** {2 Vacation Response Methods} *)
303
+
304
+
val vacation_response_get :
305
+
call_id:string ->
306
+
account_id:Jmap.Proto.Id.t ->
307
+
unit ->
308
+
Jmap.Proto.Invocation.t
309
+
(** [vacation_response_get ~call_id ~account_id ()] builds a
310
+
VacationResponse/get invocation. The singleton ID is automatically used. *)
311
+
312
+
(** {2 Request Building} *)
313
+
314
+
val make_request :
315
+
?created_ids:(Jmap.Proto.Id.t * Jmap.Proto.Id.t) list ->
316
+
capabilities:string list ->
317
+
Jmap.Proto.Invocation.t list ->
318
+
Jmap.Proto.Request.t
319
+
(** [make_request ?created_ids ~capabilities invocations] builds a JMAP request.
320
+
321
+
@param created_ids Optional client-created ID mappings.
322
+
@param capabilities List of capability URIs to use.
323
+
@param invocations List of method invocations. *)
324
+
end
325
+
326
+
(** {1 Response Parsing}
327
+
328
+
Helper functions for parsing typed responses from JMAP invocations. *)
329
+
330
+
module Parse : sig
331
+
val find_invocation :
332
+
call_id:string ->
333
+
Jmap.Proto.Response.t ->
334
+
Jmap.Proto.Invocation.t option
335
+
(** [find_invocation ~call_id response] finds an invocation by call ID. *)
336
+
337
+
val get_invocation_exn :
338
+
call_id:string ->
339
+
Jmap.Proto.Response.t ->
340
+
Jmap.Proto.Invocation.t
341
+
(** [get_invocation_exn ~call_id response] finds an invocation by call ID.
342
+
@raise Failure if not found. *)
343
+
344
+
val parse_invocation :
345
+
'a Jsont.t ->
346
+
Jmap.Proto.Invocation.t ->
347
+
('a, Jsont.Error.t) result
348
+
(** [parse_invocation jsont inv] decodes the invocation's arguments. *)
349
+
350
+
val parse_response :
351
+
call_id:string ->
352
+
'a Jsont.t ->
353
+
Jmap.Proto.Response.t ->
354
+
('a, Jsont.Error.t) result
355
+
(** [parse_response ~call_id jsont response] finds and parses an invocation. *)
356
+
357
+
(** {2 Typed Response Codecs} *)
358
+
359
+
val get_response : 'a Jsont.t -> 'a Jmap.Proto.Method.get_response Jsont.t
360
+
(** [get_response obj_jsont] creates a Foo/get response codec. *)
361
+
362
+
val query_response : Jmap.Proto.Method.query_response Jsont.t
363
+
(** Codec for Foo/query responses. *)
364
+
365
+
val changes_response : Jmap.Proto.Method.changes_response Jsont.t
366
+
(** Codec for Foo/changes responses. *)
367
+
368
+
val set_response : 'a Jsont.t -> 'a Jmap.Proto.Method.set_response Jsont.t
369
+
(** [set_response obj_jsont] creates a Foo/set response codec. *)
370
+
371
+
(** {2 Mail-specific Codecs} *)
372
+
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
+
378
+
(** {2 Convenience Parsers} *)
379
+
380
+
val parse_mailbox_get :
381
+
call_id:string ->
382
+
Jmap.Proto.Response.t ->
383
+
(Jmap.Proto.Mailbox.t Jmap.Proto.Method.get_response, Jsont.Error.t) result
384
+
385
+
val parse_email_get :
386
+
call_id:string ->
387
+
Jmap.Proto.Response.t ->
388
+
(Jmap.Proto.Email.t Jmap.Proto.Method.get_response, Jsont.Error.t) result
389
+
390
+
val parse_email_query :
391
+
call_id:string ->
392
+
Jmap.Proto.Response.t ->
393
+
(Jmap.Proto.Method.query_response, Jsont.Error.t) result
394
+
395
+
val parse_thread_get :
396
+
call_id:string ->
397
+
Jmap.Proto.Response.t ->
398
+
(Jmap.Proto.Thread.t Jmap.Proto.Method.get_response, Jsont.Error.t) result
399
+
400
+
val parse_changes :
401
+
call_id:string ->
402
+
Jmap.Proto.Response.t ->
403
+
(Jmap.Proto.Method.changes_response, Jsont.Error.t) result
404
+
end
+42
eio/codec.ml
+42
eio/codec.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let encode ?format jsont value =
7
+
Jsont_bytesrw.encode_string' ?format jsont value
8
+
9
+
let decode ?locs jsont json =
10
+
Jsont_bytesrw.decode_string' ?locs jsont json
11
+
12
+
let encode_request ?format request =
13
+
encode ?format Jmap.Proto.Request.jsont request
14
+
15
+
let encode_request_exn ?format request =
16
+
match encode_request ?format request with
17
+
| Ok s -> s
18
+
| Error e -> failwith (Jsont.Error.to_string e)
19
+
20
+
let decode_response ?locs json =
21
+
decode ?locs Jmap.Proto.Response.jsont json
22
+
23
+
let decode_response_exn ?locs json =
24
+
match decode_response ?locs json with
25
+
| Ok r -> r
26
+
| Error e -> failwith (Jsont.Error.to_string e)
27
+
28
+
let decode_session ?locs json =
29
+
decode ?locs Jmap.Proto.Session.jsont json
30
+
31
+
let decode_session_exn ?locs json =
32
+
match decode_session ?locs json with
33
+
| Ok s -> s
34
+
| Error e -> failwith (Jsont.Error.to_string e)
35
+
36
+
let decode_upload_response ?locs json =
37
+
decode ?locs Jmap.Proto.Blob.upload_response_jsont json
38
+
39
+
let decode_upload_response_exn ?locs json =
40
+
match decode_upload_response ?locs json with
41
+
| Ok r -> r
42
+
| Error e -> failwith (Jsont.Error.to_string e)
+92
eio/codec.mli
+92
eio/codec.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP JSON codec for Eio
7
+
8
+
Low-level encoding and decoding of JMAP messages using jsont and bytesrw. *)
9
+
10
+
(** {1 Request Encoding} *)
11
+
12
+
val encode_request :
13
+
?format:Jsont.format ->
14
+
Jmap.Proto.Request.t ->
15
+
(string, Jsont.Error.t) result
16
+
(** [encode_request ?format request] encodes a JMAP request to a JSON string.
17
+
18
+
@param format The JSON formatting style. Defaults to {!Jsont.Minify}. *)
19
+
20
+
val encode_request_exn :
21
+
?format:Jsont.format ->
22
+
Jmap.Proto.Request.t ->
23
+
string
24
+
(** [encode_request_exn ?format request] is like {!encode_request} but raises
25
+
on encoding errors. *)
26
+
27
+
(** {1 Response Decoding} *)
28
+
29
+
val decode_response :
30
+
?locs:bool ->
31
+
string ->
32
+
(Jmap.Proto.Response.t, Jsont.Error.t) result
33
+
(** [decode_response ?locs json] decodes a JMAP response from a JSON string.
34
+
35
+
@param locs If [true], location information is preserved for error messages.
36
+
Defaults to [false]. *)
37
+
38
+
val decode_response_exn :
39
+
?locs:bool ->
40
+
string ->
41
+
Jmap.Proto.Response.t
42
+
(** [decode_response_exn ?locs json] is like {!decode_response} but raises
43
+
on decoding errors. *)
44
+
45
+
(** {1 Session Decoding} *)
46
+
47
+
val decode_session :
48
+
?locs:bool ->
49
+
string ->
50
+
(Jmap.Proto.Session.t, Jsont.Error.t) result
51
+
(** [decode_session ?locs json] decodes a JMAP session from a JSON string.
52
+
53
+
@param locs If [true], location information is preserved for error messages.
54
+
Defaults to [false]. *)
55
+
56
+
val decode_session_exn :
57
+
?locs:bool ->
58
+
string ->
59
+
Jmap.Proto.Session.t
60
+
(** [decode_session_exn ?locs json] is like {!decode_session} but raises
61
+
on decoding errors. *)
62
+
63
+
(** {1 Blob Upload Response Decoding} *)
64
+
65
+
val decode_upload_response :
66
+
?locs:bool ->
67
+
string ->
68
+
(Jmap.Proto.Blob.upload_response, Jsont.Error.t) result
69
+
(** [decode_upload_response ?locs json] decodes a blob upload response. *)
70
+
71
+
val decode_upload_response_exn :
72
+
?locs:bool ->
73
+
string ->
74
+
Jmap.Proto.Blob.upload_response
75
+
(** [decode_upload_response_exn ?locs json] is like {!decode_upload_response}
76
+
but raises on decoding errors. *)
77
+
78
+
(** {1 Generic Encoding/Decoding} *)
79
+
80
+
val encode :
81
+
?format:Jsont.format ->
82
+
'a Jsont.t ->
83
+
'a ->
84
+
(string, Jsont.Error.t) result
85
+
(** [encode ?format jsont value] encodes any value using its jsont codec. *)
86
+
87
+
val decode :
88
+
?locs:bool ->
89
+
'a Jsont.t ->
90
+
string ->
91
+
('a, Jsont.Error.t) result
92
+
(** [decode ?locs jsont json] decodes any value using its jsont codec. *)
+6
eio/dune
+6
eio/dune
+9
eio/jmap_eio.ml
+9
eio/jmap_eio.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module Codec = Codec
7
+
module Client = Client
8
+
module Cli = Cli
9
+
module Chain = Jmap.Chain
+83
eio/jmap_eio.mli
+83
eio/jmap_eio.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP client library for Eio
7
+
8
+
This library provides a complete JMAP (RFC 8620/8621) client implementation
9
+
for OCaml using Eio for effects-based concurrency and Requests for HTTP.
10
+
11
+
{2 Overview}
12
+
13
+
The library consists of two layers:
14
+
15
+
- {!Codec}: Low-level JSON encoding/decoding for JMAP messages
16
+
- {!Client}: High-level JMAP client with session management
17
+
18
+
{2 Quick Start}
19
+
20
+
{[
21
+
open Eio_main
22
+
23
+
let () = run @@ fun env ->
24
+
Eio.Switch.run @@ fun sw ->
25
+
26
+
(* Create HTTP client *)
27
+
let requests = Requests.create ~sw env in
28
+
29
+
(* Create JMAP client from well-known URL *)
30
+
let client = Jmap_eio.Client.create_from_url_exn
31
+
~auth:(Requests.Auth.bearer "your-token")
32
+
requests
33
+
"https://api.example.com/.well-known/jmap" in
34
+
35
+
(* Get session info *)
36
+
let session = Jmap_eio.Client.session client in
37
+
Printf.printf "API URL: %s\n" (Jmap.Proto.Session.api_url session);
38
+
39
+
(* Build and execute a request *)
40
+
let account_id = (* get from session *) ... in
41
+
let req = Jmap_eio.Client.Build.(
42
+
make_request
43
+
~capabilities:[Jmap.Proto.Capability.core_uri;
44
+
Jmap.Proto.Capability.mail_uri]
45
+
[mailbox_get ~call_id:"0" ~account_id ()]
46
+
) in
47
+
let response = Jmap_eio.Client.request_exn client req in
48
+
49
+
(* Process response *)
50
+
List.iter (fun inv ->
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)
55
+
]}
56
+
57
+
{2 Capabilities}
58
+
59
+
JMAP uses capability URIs to indicate supported features:
60
+
61
+
- [urn:ietf:params:jmap:core] - Core JMAP
62
+
- [urn:ietf:params:jmap:mail] - Email, Mailbox, Thread
63
+
- [urn:ietf:params:jmap:submission] - EmailSubmission
64
+
- [urn:ietf:params:jmap:vacationresponse] - VacationResponse
65
+
66
+
These are available as constants in {!Jmap.Proto.Capability}.
67
+
*)
68
+
69
+
(** Low-level JSON codec for JMAP messages. *)
70
+
module Codec = Codec
71
+
72
+
(** High-level JMAP client with session management. *)
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
+17
-15
jmap.opam
+17
-15
jmap.opam
···
1
1
# This file is generated by dune, edit dune-project instead
2
2
opam-version: "2.0"
3
-
synopsis: "JMAP protocol"
4
-
description: "This is all still a work in progress"
5
-
maintainer: ["anil@recoil.org"]
6
-
authors: ["Anil Madhavapeddy"]
3
+
synopsis: "JMAP protocol implementation for OCaml"
4
+
description:
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
+
maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
7
+
authors: ["Anil Madhavapeddy <anil@recoil.org>"]
7
8
license: "ISC"
8
-
homepage: "https://github.com/avsm/jmap"
9
-
bug-reports: "https://github.com/avsm/jmap/issues"
9
+
homepage: "https://tangled.org/@anil.recoil.org/ocaml-jmap"
10
+
bug-reports: "https://tangled.org/@anil.recoil.org/ocaml-jmap/issues"
10
11
depends: [
11
-
"dune" {>= "3.17"}
12
-
"ocaml" {>= "5.2.0"}
13
-
"ptime"
14
-
"cohttp"
15
-
"cohttp-lwt-unix"
16
-
"ezjsonm"
17
-
"uri"
18
-
"lwt"
12
+
"dune" {>= "3.20"}
13
+
"ocaml" {>= "5.4.0"}
14
+
"jsont" {>= "0.2.0"}
15
+
"json-pointer"
16
+
"ptime" {>= "1.0.0"}
17
+
"eio" {with-test}
18
+
"requests" {with-test}
19
+
"brr" {with-test}
19
20
"odoc" {with-doc}
20
21
]
22
+
depopts: ["eio" "requests" "brr"]
21
23
build: [
22
24
["dune" "subst"] {dev}
23
25
[
···
32
34
"@doc" {with-doc}
33
35
]
34
36
]
35
-
dev-repo: "git+https://github.com/avsm/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
+39
-9
lib/dune
+39
-9
lib/dune
···
1
-
(library
2
-
(name jmap)
3
-
(public_name jmap)
4
-
(modules jmap)
5
-
(libraries str ezjsonm ptime cohttp cohttp-lwt-unix uri lwt))
1
+
(include_subdirs unqualified)
6
2
7
3
(library
8
-
(name jmap_mail)
9
-
(public_name jmap.mail)
10
-
(modules jmap_mail)
11
-
(libraries jmap))
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))
-567
lib/jmap.ml
-567
lib/jmap.ml
···
1
-
(**
2
-
* JMAP protocol implementation based on RFC8620
3
-
* https://datatracker.ietf.org/doc/html/rfc8620
4
-
*)
5
-
6
-
module Types = struct
7
-
(** Id string as per Section 1.2 *)
8
-
type id = string
9
-
10
-
(** Int bounded within the range -2^53+1 to 2^53-1 as per Section 1.3 *)
11
-
type int_t = int
12
-
13
-
(** UnsignedInt bounded within the range 0 to 2^53-1 as per Section 1.3 *)
14
-
type unsigned_int = int
15
-
16
-
(** Date string in RFC3339 format as per Section 1.4 *)
17
-
type date = string
18
-
19
-
(** UTCDate is a Date with 'Z' time zone as per Section 1.4 *)
20
-
type utc_date = string
21
-
22
-
(** Error object as per Section 3.6.2 *)
23
-
type error = {
24
-
type_: string;
25
-
description: string option;
26
-
}
27
-
28
-
(** Set error object as per Section 5.3 *)
29
-
type set_error = {
30
-
type_: string;
31
-
description: string option;
32
-
properties: string list option;
33
-
(* Additional properties for specific error types *)
34
-
existing_id: id option; (* For alreadyExists error *)
35
-
}
36
-
37
-
(** Invocation object as per Section 3.2 *)
38
-
type 'a invocation = {
39
-
name: string;
40
-
arguments: 'a;
41
-
method_call_id: string;
42
-
}
43
-
44
-
(** ResultReference object as per Section 3.7 *)
45
-
type result_reference = {
46
-
result_of: string;
47
-
name: string;
48
-
path: string;
49
-
}
50
-
51
-
(** FilterOperator, FilterCondition and Filter as per Section 5.5 *)
52
-
type filter_operator = {
53
-
operator: string; (* "AND", "OR", "NOT" *)
54
-
conditions: filter list;
55
-
}
56
-
and filter_condition = (string * Ezjsonm.value) list
57
-
and filter =
58
-
| Operator of filter_operator
59
-
| Condition of filter_condition
60
-
61
-
(** Comparator object for sorting as per Section 5.5 *)
62
-
type comparator = {
63
-
property: string;
64
-
is_ascending: bool option; (* Optional, defaults to true *)
65
-
collation: string option; (* Optional, server-dependent default *)
66
-
}
67
-
68
-
(** PatchObject as per Section 5.3 *)
69
-
type patch_object = (string * Ezjsonm.value) list
70
-
71
-
(** AddedItem structure as per Section 5.6 *)
72
-
type added_item = {
73
-
id: id;
74
-
index: unsigned_int;
75
-
}
76
-
77
-
(** Account object as per Section 1.6.2 *)
78
-
type account = {
79
-
name: string;
80
-
is_personal: bool;
81
-
is_read_only: bool;
82
-
account_capabilities: (string * Ezjsonm.value) list;
83
-
}
84
-
85
-
(** Core capability object as per Section 2 *)
86
-
type core_capability = {
87
-
max_size_upload: unsigned_int;
88
-
max_concurrent_upload: unsigned_int;
89
-
max_size_request: unsigned_int;
90
-
max_concurrent_requests: unsigned_int;
91
-
max_calls_in_request: unsigned_int;
92
-
max_objects_in_get: unsigned_int;
93
-
max_objects_in_set: unsigned_int;
94
-
collation_algorithms: string list;
95
-
}
96
-
97
-
(** PushSubscription keys object as per Section 7.2 *)
98
-
type push_keys = {
99
-
p256dh: string;
100
-
auth: string;
101
-
}
102
-
103
-
(** Session object as per Section 2 *)
104
-
type session = {
105
-
capabilities: (string * Ezjsonm.value) list;
106
-
accounts: (id * account) list;
107
-
primary_accounts: (string * id) list;
108
-
username: string;
109
-
api_url: string;
110
-
download_url: string;
111
-
upload_url: string;
112
-
event_source_url: string option;
113
-
state: string;
114
-
}
115
-
116
-
(** TypeState for state changes as per Section 7.1 *)
117
-
type type_state = (string * string) list
118
-
119
-
(** StateChange object as per Section 7.1 *)
120
-
type state_change = {
121
-
changed: (id * type_state) list;
122
-
}
123
-
124
-
(** PushVerification object as per Section 7.2.2 *)
125
-
type push_verification = {
126
-
push_subscription_id: id;
127
-
verification_code: string;
128
-
}
129
-
130
-
(** PushSubscription object as per Section 7.2 *)
131
-
type push_subscription = {
132
-
id: id;
133
-
device_client_id: string;
134
-
url: string;
135
-
keys: push_keys option;
136
-
verification_code: string option;
137
-
expires: utc_date option;
138
-
types: string list option;
139
-
}
140
-
141
-
(** Request object as per Section 3.3 *)
142
-
type request = {
143
-
using: string list;
144
-
method_calls: Ezjsonm.value invocation list;
145
-
created_ids: (id * id) list option;
146
-
}
147
-
148
-
(** Response object as per Section 3.4 *)
149
-
type response = {
150
-
method_responses: Ezjsonm.value invocation list;
151
-
created_ids: (id * id) list option;
152
-
session_state: string;
153
-
}
154
-
155
-
(** Standard method arguments and responses *)
156
-
157
-
(** Arguments for Foo/get method as per Section 5.1 *)
158
-
type 'a get_arguments = {
159
-
account_id: id;
160
-
ids: id list option;
161
-
properties: string list option;
162
-
}
163
-
164
-
(** Response for Foo/get method as per Section 5.1 *)
165
-
type 'a get_response = {
166
-
account_id: id;
167
-
state: string;
168
-
list: 'a list;
169
-
not_found: id list;
170
-
}
171
-
172
-
(** Arguments for Foo/changes method as per Section 5.2 *)
173
-
type changes_arguments = {
174
-
account_id: id;
175
-
since_state: string;
176
-
max_changes: unsigned_int option;
177
-
}
178
-
179
-
(** Response for Foo/changes method as per Section 5.2 *)
180
-
type changes_response = {
181
-
account_id: id;
182
-
old_state: string;
183
-
new_state: string;
184
-
has_more_changes: bool;
185
-
created: id list;
186
-
updated: id list;
187
-
destroyed: id list;
188
-
}
189
-
190
-
(** Arguments for Foo/set method as per Section 5.3 *)
191
-
type 'a set_arguments = {
192
-
account_id: id;
193
-
if_in_state: string option;
194
-
create: (id * 'a) list option;
195
-
update: (id * patch_object) list option;
196
-
destroy: id list option;
197
-
}
198
-
199
-
(** Response for Foo/set method as per Section 5.3 *)
200
-
type 'a set_response = {
201
-
account_id: id;
202
-
old_state: string option;
203
-
new_state: string;
204
-
created: (id * 'a) list option;
205
-
updated: (id * 'a option) list option;
206
-
destroyed: id list option;
207
-
not_created: (id * set_error) list option;
208
-
not_updated: (id * set_error) list option;
209
-
not_destroyed: (id * set_error) list option;
210
-
}
211
-
212
-
(** Arguments for Foo/copy method as per Section 5.4 *)
213
-
type 'a copy_arguments = {
214
-
from_account_id: id;
215
-
if_from_in_state: string option;
216
-
account_id: id;
217
-
if_in_state: string option;
218
-
create: (id * 'a) list;
219
-
on_success_destroy_original: bool option;
220
-
destroy_from_if_in_state: string option;
221
-
}
222
-
223
-
(** Response for Foo/copy method as per Section 5.4 *)
224
-
type 'a copy_response = {
225
-
from_account_id: id;
226
-
account_id: id;
227
-
old_state: string option;
228
-
new_state: string;
229
-
created: (id * 'a) list option;
230
-
not_created: (id * set_error) list option;
231
-
}
232
-
233
-
(** Arguments for Foo/query method as per Section 5.5 *)
234
-
type query_arguments = {
235
-
account_id: id;
236
-
filter: filter option;
237
-
sort: comparator list option;
238
-
position: int_t option;
239
-
anchor: id option;
240
-
anchor_offset: int_t option;
241
-
limit: unsigned_int option;
242
-
calculate_total: bool option;
243
-
}
244
-
245
-
(** Response for Foo/query method as per Section 5.5 *)
246
-
type query_response = {
247
-
account_id: id;
248
-
query_state: string;
249
-
can_calculate_changes: bool;
250
-
position: unsigned_int;
251
-
ids: id list;
252
-
total: unsigned_int option;
253
-
limit: unsigned_int option;
254
-
}
255
-
256
-
(** Arguments for Foo/queryChanges method as per Section 5.6 *)
257
-
type query_changes_arguments = {
258
-
account_id: id;
259
-
filter: filter option;
260
-
sort: comparator list option;
261
-
since_query_state: string;
262
-
max_changes: unsigned_int option;
263
-
up_to_id: id option;
264
-
calculate_total: bool option;
265
-
}
266
-
267
-
(** Response for Foo/queryChanges method as per Section 5.6 *)
268
-
type query_changes_response = {
269
-
account_id: id;
270
-
old_query_state: string;
271
-
new_query_state: string;
272
-
total: unsigned_int option;
273
-
removed: id list;
274
-
added: added_item list option;
275
-
}
276
-
277
-
(** Arguments for Blob/copy method as per Section 6.3 *)
278
-
type blob_copy_arguments = {
279
-
from_account_id: id;
280
-
account_id: id;
281
-
blob_ids: id list;
282
-
}
283
-
284
-
(** Response for Blob/copy method as per Section 6.3 *)
285
-
type blob_copy_response = {
286
-
from_account_id: id;
287
-
account_id: id;
288
-
copied: (id * id) list option;
289
-
not_copied: (id * set_error) list option;
290
-
}
291
-
292
-
(** Upload response as per Section 6.1 *)
293
-
type upload_response = {
294
-
account_id: id;
295
-
blob_id: id;
296
-
type_: string;
297
-
size: unsigned_int;
298
-
}
299
-
300
-
(** Problem details object as per RFC7807 and Section 3.6.1 *)
301
-
type problem_details = {
302
-
type_: string;
303
-
status: int option;
304
-
detail: string option;
305
-
limit: string option; (* For "limit" error *)
306
-
}
307
-
end
308
-
309
-
module Api = struct
310
-
open Lwt.Syntax
311
-
open Types
312
-
313
-
(** Error that may occur during API requests *)
314
-
type error =
315
-
| Connection_error of string
316
-
| HTTP_error of int * string
317
-
| Parse_error of string
318
-
| Authentication_error
319
-
320
-
(** Result type for API operations *)
321
-
type 'a result = ('a, error) Stdlib.result
322
-
323
-
(** Configuration for a JMAP API client *)
324
-
type config = {
325
-
api_uri: Uri.t;
326
-
username: string;
327
-
authentication_token: string;
328
-
}
329
-
330
-
(** Convert Ezjsonm.value to string *)
331
-
let json_to_string json =
332
-
Ezjsonm.value_to_string ~minify:false json
333
-
334
-
(** Parse response string as JSON value *)
335
-
let parse_json_string str =
336
-
try Ok (Ezjsonm.from_string str)
337
-
with e -> Error (Parse_error (Printexc.to_string e))
338
-
339
-
(** Parse JSON response as a JMAP response object *)
340
-
let parse_response json =
341
-
try
342
-
let method_responses =
343
-
match Ezjsonm.find json ["methodResponses"] with
344
-
| `A items ->
345
-
List.map (fun json ->
346
-
match json with
347
-
| `A [`String name; args; `String method_call_id] ->
348
-
{ name; arguments = args; method_call_id }
349
-
| _ -> raise (Invalid_argument "Invalid invocation format in response")
350
-
) items
351
-
| _ -> raise (Invalid_argument "methodResponses is not an array")
352
-
in
353
-
let created_ids_opt =
354
-
try
355
-
let obj = Ezjsonm.find json ["createdIds"] in
356
-
match obj with
357
-
| `O items -> Some (List.map (fun (k, v) ->
358
-
match v with
359
-
| `String id -> (k, id)
360
-
| _ -> raise (Invalid_argument "createdIds value is not a string")
361
-
) items)
362
-
| _ -> None
363
-
with Not_found -> None
364
-
in
365
-
let session_state =
366
-
match Ezjsonm.find json ["sessionState"] with
367
-
| `String s -> s
368
-
| _ -> raise (Invalid_argument "sessionState is not a string")
369
-
in
370
-
Ok { method_responses; created_ids = created_ids_opt; session_state }
371
-
with
372
-
| Not_found -> Error (Parse_error "Required field not found in response")
373
-
| Invalid_argument msg -> Error (Parse_error msg)
374
-
| e -> Error (Parse_error (Printexc.to_string e))
375
-
376
-
(** Serialize a JMAP request object to JSON *)
377
-
let serialize_request req =
378
-
let method_calls_json =
379
-
`A (List.map (fun (inv : 'a invocation) ->
380
-
`A [`String inv.name; inv.arguments; `String inv.method_call_id]
381
-
) req.method_calls)
382
-
in
383
-
let using_json = `A (List.map (fun s -> `String s) req.using) in
384
-
let json = `O [
385
-
("using", using_json);
386
-
("methodCalls", method_calls_json)
387
-
] in
388
-
let json = match req.created_ids with
389
-
| Some ids ->
390
-
let created_ids_json = `O (List.map (fun (k, v) -> (k, `String v)) ids) in
391
-
Ezjsonm.update json ["createdIds"] (Some created_ids_json)
392
-
| None -> json
393
-
in
394
-
json_to_string json
395
-
396
-
(** Make a raw HTTP request *)
397
-
let make_http_request ~headers ~body uri =
398
-
let open Cohttp in
399
-
let open Cohttp_lwt_unix in
400
-
let headers = Header.add_list (Header.init ()) headers in
401
-
Lwt.catch
402
-
(fun () ->
403
-
let* resp, body = Client.post ~headers ~body:(Cohttp_lwt.Body.of_string body) uri in
404
-
let* body_str = Cohttp_lwt.Body.to_string body in
405
-
let status = Response.status resp |> Code.code_of_status in
406
-
if status >= 200 && status < 300 then
407
-
Lwt.return (Ok body_str)
408
-
else
409
-
Lwt.return (Error (HTTP_error (status, body_str))))
410
-
(fun e -> Lwt.return (Error (Connection_error (Printexc.to_string e))))
411
-
412
-
(** Make a raw JMAP API request
413
-
414
-
TODO:claude *)
415
-
let make_request config req =
416
-
let body = serialize_request req in
417
-
let headers = [
418
-
("Content-Type", "application/json");
419
-
("Content-Length", string_of_int (String.length body));
420
-
("Authorization", "Basic " ^ Base64.encode_string (config.username ^ ":" ^ config.authentication_token))
421
-
] in
422
-
let* result = make_http_request ~headers ~body config.api_uri in
423
-
match result with
424
-
| Ok response_body ->
425
-
(match parse_json_string response_body with
426
-
| Ok json -> Lwt.return (parse_response json)
427
-
| Error e -> Lwt.return (Error e))
428
-
| Error e -> Lwt.return (Error e)
429
-
430
-
(** Parse a JSON object as a Session object *)
431
-
let parse_session_object json =
432
-
try
433
-
let capabilities =
434
-
match Ezjsonm.find json ["capabilities"] with
435
-
| `O items -> items
436
-
| _ -> raise (Invalid_argument "capabilities is not an object")
437
-
in
438
-
439
-
let accounts =
440
-
match Ezjsonm.find json ["accounts"] with
441
-
| `O items -> List.map (fun (id, json) ->
442
-
match json with
443
-
| `O _ ->
444
-
let name = Ezjsonm.get_string (Ezjsonm.find json ["name"]) in
445
-
let is_personal = Ezjsonm.get_bool (Ezjsonm.find json ["isPersonal"]) in
446
-
let is_read_only = Ezjsonm.get_bool (Ezjsonm.find json ["isReadOnly"]) in
447
-
let account_capabilities =
448
-
match Ezjsonm.find json ["accountCapabilities"] with
449
-
| `O items -> items
450
-
| _ -> raise (Invalid_argument "accountCapabilities is not an object")
451
-
in
452
-
(id, { name; is_personal; is_read_only; account_capabilities })
453
-
| _ -> raise (Invalid_argument "account value is not an object")
454
-
) items
455
-
| _ -> raise (Invalid_argument "accounts is not an object")
456
-
in
457
-
458
-
let primary_accounts =
459
-
match Ezjsonm.find_opt json ["primaryAccounts"] with
460
-
| Some (`O items) -> List.map (fun (k, v) ->
461
-
match v with
462
-
| `String id -> (k, id)
463
-
| _ -> raise (Invalid_argument "primaryAccounts value is not a string")
464
-
) items
465
-
| Some _ -> raise (Invalid_argument "primaryAccounts is not an object")
466
-
| None -> []
467
-
in
468
-
469
-
let username = Ezjsonm.get_string (Ezjsonm.find json ["username"]) in
470
-
let api_url = Ezjsonm.get_string (Ezjsonm.find json ["apiUrl"]) in
471
-
let download_url = Ezjsonm.get_string (Ezjsonm.find json ["downloadUrl"]) in
472
-
let upload_url = Ezjsonm.get_string (Ezjsonm.find json ["uploadUrl"]) in
473
-
let event_source_url =
474
-
try Some (Ezjsonm.get_string (Ezjsonm.find json ["eventSourceUrl"]))
475
-
with Not_found -> None
476
-
in
477
-
let state = Ezjsonm.get_string (Ezjsonm.find json ["state"]) in
478
-
479
-
Ok { capabilities; accounts; primary_accounts; username;
480
-
api_url; download_url; upload_url; event_source_url; state }
481
-
with
482
-
| Not_found -> Error (Parse_error "Required field not found in session object")
483
-
| Invalid_argument msg -> Error (Parse_error msg)
484
-
| e -> Error (Parse_error (Printexc.to_string e))
485
-
486
-
(** Fetch a Session object from a JMAP server
487
-
488
-
TODO:claude *)
489
-
let get_session uri ?username ?authentication_token () =
490
-
let headers =
491
-
match (username, authentication_token) with
492
-
| (Some u, Some t) -> [
493
-
("Content-Type", "application/json");
494
-
("Authorization", "Basic " ^ Base64.encode_string (u ^ ":" ^ t))
495
-
]
496
-
| _ -> [("Content-Type", "application/json")]
497
-
in
498
-
499
-
let* result = make_http_request ~headers ~body:"" uri in
500
-
match result with
501
-
| Ok response_body ->
502
-
(match parse_json_string response_body with
503
-
| Ok json -> Lwt.return (parse_session_object json)
504
-
| Error e -> Lwt.return (Error e))
505
-
| Error e -> Lwt.return (Error e)
506
-
507
-
(** Upload a binary blob to the server
508
-
509
-
TODO:claude *)
510
-
let upload_blob config ~account_id ~content_type data =
511
-
let upload_url_template = config.api_uri |> Uri.to_string in
512
-
(* Replace {accountId} with the actual account ID *)
513
-
let upload_url = Str.global_replace (Str.regexp "{accountId}") account_id upload_url_template in
514
-
let upload_uri = Uri.of_string upload_url in
515
-
516
-
let headers = [
517
-
("Content-Type", content_type);
518
-
("Content-Length", string_of_int (String.length data));
519
-
("Authorization", "Basic " ^ Base64.encode_string (config.username ^ ":" ^ config.authentication_token))
520
-
] in
521
-
522
-
let* result = make_http_request ~headers ~body:data upload_uri in
523
-
match result with
524
-
| Ok response_body ->
525
-
(match parse_json_string response_body with
526
-
| Ok json ->
527
-
(try
528
-
let account_id = Ezjsonm.get_string (Ezjsonm.find json ["accountId"]) in
529
-
let blob_id = Ezjsonm.get_string (Ezjsonm.find json ["blobId"]) in
530
-
let type_ = Ezjsonm.get_string (Ezjsonm.find json ["type"]) in
531
-
let size = Ezjsonm.get_int (Ezjsonm.find json ["size"]) in
532
-
Lwt.return (Ok { account_id; blob_id; type_; size })
533
-
with
534
-
| Not_found -> Lwt.return (Error (Parse_error "Required field not found in upload response"))
535
-
| e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
536
-
| Error e -> Lwt.return (Error e))
537
-
| Error e -> Lwt.return (Error e)
538
-
539
-
(** Download a binary blob from the server
540
-
541
-
TODO:claude *)
542
-
let download_blob config ~account_id ~blob_id ?type_ ?name () =
543
-
let download_url_template = config.api_uri |> Uri.to_string in
544
-
545
-
(* Replace template variables with actual values *)
546
-
let url = Str.global_replace (Str.regexp "{accountId}") account_id download_url_template in
547
-
let url = Str.global_replace (Str.regexp "{blobId}") blob_id url in
548
-
549
-
let url = match type_ with
550
-
| Some t -> Str.global_replace (Str.regexp "{type}") (Uri.pct_encode t) url
551
-
| None -> Str.global_replace (Str.regexp "{type}") "" url
552
-
in
553
-
554
-
let url = match name with
555
-
| Some n -> Str.global_replace (Str.regexp "{name}") (Uri.pct_encode n) url
556
-
| None -> Str.global_replace (Str.regexp "{name}") "file" url
557
-
in
558
-
559
-
let download_uri = Uri.of_string url in
560
-
561
-
let headers = [
562
-
("Authorization", "Basic " ^ Base64.encode_string (config.username ^ ":" ^ config.authentication_token))
563
-
] in
564
-
565
-
let* result = make_http_request ~headers ~body:"" download_uri in
566
-
Lwt.return result
567
-
end
-364
lib/jmap.mli
-364
lib/jmap.mli
···
1
-
(**
2
-
* JMAP protocol implementation based on RFC8620
3
-
* https://datatracker.ietf.org/doc/html/rfc8620
4
-
*)
5
-
6
-
(** {1 Types} *)
7
-
8
-
module Types : sig
9
-
(** Id string as per Section 1.2 *)
10
-
type id = string
11
-
12
-
(** Int bounded within the range -2^53+1 to 2^53-1 as per Section 1.3 *)
13
-
type int_t = int
14
-
15
-
(** UnsignedInt bounded within the range 0 to 2^53-1 as per Section 1.3 *)
16
-
type unsigned_int = int
17
-
18
-
(** Date string in RFC3339 format as per Section 1.4 *)
19
-
type date = string
20
-
21
-
(** UTCDate is a Date with 'Z' time zone as per Section 1.4 *)
22
-
type utc_date = string
23
-
24
-
(** Error object as per Section 3.6.2 *)
25
-
type error = {
26
-
type_: string;
27
-
description: string option;
28
-
}
29
-
30
-
(** Set error object as per Section 5.3 *)
31
-
type set_error = {
32
-
type_: string;
33
-
description: string option;
34
-
properties: string list option;
35
-
(* Additional properties for specific error types *)
36
-
existing_id: id option; (* For alreadyExists error *)
37
-
}
38
-
39
-
(** Invocation object as per Section 3.2 *)
40
-
type 'a invocation = {
41
-
name: string;
42
-
arguments: 'a;
43
-
method_call_id: string;
44
-
}
45
-
46
-
(** ResultReference object as per Section 3.7 *)
47
-
type result_reference = {
48
-
result_of: string;
49
-
name: string;
50
-
path: string;
51
-
}
52
-
53
-
(** FilterOperator, FilterCondition and Filter as per Section 5.5 *)
54
-
type filter_operator = {
55
-
operator: string; (* "AND", "OR", "NOT" *)
56
-
conditions: filter list;
57
-
}
58
-
and filter_condition = (string * Ezjsonm.value) list
59
-
and filter =
60
-
| Operator of filter_operator
61
-
| Condition of filter_condition
62
-
63
-
(** Comparator object for sorting as per Section 5.5 *)
64
-
type comparator = {
65
-
property: string;
66
-
is_ascending: bool option; (* Optional, defaults to true *)
67
-
collation: string option; (* Optional, server-dependent default *)
68
-
}
69
-
70
-
(** PatchObject as per Section 5.3 *)
71
-
type patch_object = (string * Ezjsonm.value) list
72
-
73
-
(** AddedItem structure as per Section 5.6 *)
74
-
type added_item = {
75
-
id: id;
76
-
index: unsigned_int;
77
-
}
78
-
79
-
(** Account object as per Section 1.6.2 *)
80
-
type account = {
81
-
name: string;
82
-
is_personal: bool;
83
-
is_read_only: bool;
84
-
account_capabilities: (string * Ezjsonm.value) list;
85
-
}
86
-
87
-
(** Core capability object as per Section 2 *)
88
-
type core_capability = {
89
-
max_size_upload: unsigned_int;
90
-
max_concurrent_upload: unsigned_int;
91
-
max_size_request: unsigned_int;
92
-
max_concurrent_requests: unsigned_int;
93
-
max_calls_in_request: unsigned_int;
94
-
max_objects_in_get: unsigned_int;
95
-
max_objects_in_set: unsigned_int;
96
-
collation_algorithms: string list;
97
-
}
98
-
99
-
(** PushSubscription keys object as per Section 7.2 *)
100
-
type push_keys = {
101
-
p256dh: string;
102
-
auth: string;
103
-
}
104
-
105
-
(** Session object as per Section 2 *)
106
-
type session = {
107
-
capabilities: (string * Ezjsonm.value) list;
108
-
accounts: (id * account) list;
109
-
primary_accounts: (string * id) list;
110
-
username: string;
111
-
api_url: string;
112
-
download_url: string;
113
-
upload_url: string;
114
-
event_source_url: string option;
115
-
state: string;
116
-
}
117
-
118
-
(** TypeState for state changes as per Section 7.1 *)
119
-
type type_state = (string * string) list
120
-
121
-
(** StateChange object as per Section 7.1 *)
122
-
type state_change = {
123
-
changed: (id * type_state) list;
124
-
}
125
-
126
-
(** PushVerification object as per Section 7.2.2 *)
127
-
type push_verification = {
128
-
push_subscription_id: id;
129
-
verification_code: string;
130
-
}
131
-
132
-
(** PushSubscription object as per Section 7.2 *)
133
-
type push_subscription = {
134
-
id: id;
135
-
device_client_id: string;
136
-
url: string;
137
-
keys: push_keys option;
138
-
verification_code: string option;
139
-
expires: utc_date option;
140
-
types: string list option;
141
-
}
142
-
143
-
(** Request object as per Section 3.3 *)
144
-
type request = {
145
-
using: string list;
146
-
method_calls: Ezjsonm.value invocation list;
147
-
created_ids: (id * id) list option;
148
-
}
149
-
150
-
(** Response object as per Section 3.4 *)
151
-
type response = {
152
-
method_responses: Ezjsonm.value invocation list;
153
-
created_ids: (id * id) list option;
154
-
session_state: string;
155
-
}
156
-
157
-
(** Standard method arguments and responses *)
158
-
159
-
(** Arguments for Foo/get method as per Section 5.1 *)
160
-
type 'a get_arguments = {
161
-
account_id: id;
162
-
ids: id list option;
163
-
properties: string list option;
164
-
}
165
-
166
-
(** Response for Foo/get method as per Section 5.1 *)
167
-
type 'a get_response = {
168
-
account_id: id;
169
-
state: string;
170
-
list: 'a list;
171
-
not_found: id list;
172
-
}
173
-
174
-
(** Arguments for Foo/changes method as per Section 5.2 *)
175
-
type changes_arguments = {
176
-
account_id: id;
177
-
since_state: string;
178
-
max_changes: unsigned_int option;
179
-
}
180
-
181
-
(** Response for Foo/changes method as per Section 5.2 *)
182
-
type changes_response = {
183
-
account_id: id;
184
-
old_state: string;
185
-
new_state: string;
186
-
has_more_changes: bool;
187
-
created: id list;
188
-
updated: id list;
189
-
destroyed: id list;
190
-
}
191
-
192
-
(** Arguments for Foo/set method as per Section 5.3 *)
193
-
type 'a set_arguments = {
194
-
account_id: id;
195
-
if_in_state: string option;
196
-
create: (id * 'a) list option;
197
-
update: (id * patch_object) list option;
198
-
destroy: id list option;
199
-
}
200
-
201
-
(** Response for Foo/set method as per Section 5.3 *)
202
-
type 'a set_response = {
203
-
account_id: id;
204
-
old_state: string option;
205
-
new_state: string;
206
-
created: (id * 'a) list option;
207
-
updated: (id * 'a option) list option;
208
-
destroyed: id list option;
209
-
not_created: (id * set_error) list option;
210
-
not_updated: (id * set_error) list option;
211
-
not_destroyed: (id * set_error) list option;
212
-
}
213
-
214
-
(** Arguments for Foo/copy method as per Section 5.4 *)
215
-
type 'a copy_arguments = {
216
-
from_account_id: id;
217
-
if_from_in_state: string option;
218
-
account_id: id;
219
-
if_in_state: string option;
220
-
create: (id * 'a) list;
221
-
on_success_destroy_original: bool option;
222
-
destroy_from_if_in_state: string option;
223
-
}
224
-
225
-
(** Response for Foo/copy method as per Section 5.4 *)
226
-
type 'a copy_response = {
227
-
from_account_id: id;
228
-
account_id: id;
229
-
old_state: string option;
230
-
new_state: string;
231
-
created: (id * 'a) list option;
232
-
not_created: (id * set_error) list option;
233
-
}
234
-
235
-
(** Arguments for Foo/query method as per Section 5.5 *)
236
-
type query_arguments = {
237
-
account_id: id;
238
-
filter: filter option;
239
-
sort: comparator list option;
240
-
position: int_t option;
241
-
anchor: id option;
242
-
anchor_offset: int_t option;
243
-
limit: unsigned_int option;
244
-
calculate_total: bool option;
245
-
}
246
-
247
-
(** Response for Foo/query method as per Section 5.5 *)
248
-
type query_response = {
249
-
account_id: id;
250
-
query_state: string;
251
-
can_calculate_changes: bool;
252
-
position: unsigned_int;
253
-
ids: id list;
254
-
total: unsigned_int option;
255
-
limit: unsigned_int option;
256
-
}
257
-
258
-
(** Arguments for Foo/queryChanges method as per Section 5.6 *)
259
-
type query_changes_arguments = {
260
-
account_id: id;
261
-
filter: filter option;
262
-
sort: comparator list option;
263
-
since_query_state: string;
264
-
max_changes: unsigned_int option;
265
-
up_to_id: id option;
266
-
calculate_total: bool option;
267
-
}
268
-
269
-
(** Response for Foo/queryChanges method as per Section 5.6 *)
270
-
type query_changes_response = {
271
-
account_id: id;
272
-
old_query_state: string;
273
-
new_query_state: string;
274
-
total: unsigned_int option;
275
-
removed: id list;
276
-
added: added_item list option;
277
-
}
278
-
279
-
(** Arguments for Blob/copy method as per Section 6.3 *)
280
-
type blob_copy_arguments = {
281
-
from_account_id: id;
282
-
account_id: id;
283
-
blob_ids: id list;
284
-
}
285
-
286
-
(** Response for Blob/copy method as per Section 6.3 *)
287
-
type blob_copy_response = {
288
-
from_account_id: id;
289
-
account_id: id;
290
-
copied: (id * id) list option;
291
-
not_copied: (id * set_error) list option;
292
-
}
293
-
294
-
(** Upload response as per Section 6.1 *)
295
-
type upload_response = {
296
-
account_id: id;
297
-
blob_id: id;
298
-
type_: string;
299
-
size: unsigned_int;
300
-
}
301
-
302
-
(** Problem details object as per RFC7807 and Section 3.6.1 *)
303
-
type problem_details = {
304
-
type_: string;
305
-
status: int option;
306
-
detail: string option;
307
-
limit: string option; (* For "limit" error *)
308
-
}
309
-
end
310
-
311
-
(** {1 API Client} *)
312
-
313
-
(** Module for making JMAP API requests over HTTP.
314
-
Provides functionality to interact with JMAP servers according to RFC8620. *)
315
-
module Api : sig
316
-
(** Error that may occur during API requests *)
317
-
type error =
318
-
| Connection_error of string
319
-
| HTTP_error of int * string
320
-
| Parse_error of string
321
-
| Authentication_error
322
-
323
-
(** Result type for API operations *)
324
-
type 'a result = ('a, error) Stdlib.result
325
-
326
-
(** Configuration for a JMAP API client *)
327
-
type config = {
328
-
api_uri: Uri.t;
329
-
username: string;
330
-
authentication_token: string;
331
-
}
332
-
333
-
(** Make a raw JMAP API request *)
334
-
val make_request :
335
-
config ->
336
-
Types.request ->
337
-
Types.response result Lwt.t
338
-
339
-
(** Fetch a Session object from a JMAP server *)
340
-
val get_session :
341
-
Uri.t ->
342
-
?username:string ->
343
-
?authentication_token:string ->
344
-
unit ->
345
-
Types.session result Lwt.t
346
-
347
-
(** Upload a binary blob to the server *)
348
-
val upload_blob :
349
-
config ->
350
-
account_id:Types.id ->
351
-
content_type:string ->
352
-
string ->
353
-
Types.upload_response result Lwt.t
354
-
355
-
(** Download a binary blob from the server *)
356
-
val download_blob :
357
-
config ->
358
-
account_id:Types.id ->
359
-
blob_id:Types.id ->
360
-
?type_:string ->
361
-
?name:string ->
362
-
unit ->
363
-
string result Lwt.t
364
-
end
-1294
lib/jmap_mail.ml
-1294
lib/jmap_mail.ml
···
1
-
(** Implementation of the JMAP Mail extension, as defined in RFC8621 *)
2
-
3
-
module Types = struct
4
-
open Jmap.Types
5
-
6
-
(** {1 Mail capabilities} *)
7
-
8
-
(** Capability URI for JMAP Mail*)
9
-
let capability_mail = "urn:ietf:params:jmap:mail"
10
-
11
-
(** Capability URI for JMAP Submission *)
12
-
let capability_submission = "urn:ietf:params:jmap:submission"
13
-
14
-
(** Capability URI for JMAP Vacation Response *)
15
-
let capability_vacation_response = "urn:ietf:params:jmap:vacationresponse"
16
-
17
-
(** {1:mailbox Mailbox objects} *)
18
-
19
-
(** A role for a mailbox. See RFC8621 Section 2. *)
20
-
type mailbox_role =
21
-
| All (** All mail *)
22
-
| Archive (** Archived mail *)
23
-
| Drafts (** Draft messages *)
24
-
| Flagged (** Starred/flagged mail *)
25
-
| Important (** Important mail *)
26
-
| Inbox (** Inbox *)
27
-
| Junk (** Spam/Junk mail *)
28
-
| Sent (** Sent mail *)
29
-
| Trash (** Deleted/Trash mail *)
30
-
| Unknown of string (** Server-specific roles *)
31
-
32
-
(** A mailbox (folder) in a mail account. See RFC8621 Section 2. *)
33
-
type mailbox = {
34
-
id : id;
35
-
name : string;
36
-
parent_id : id option;
37
-
role : mailbox_role option;
38
-
sort_order : unsigned_int;
39
-
total_emails : unsigned_int;
40
-
unread_emails : unsigned_int;
41
-
total_threads : unsigned_int;
42
-
unread_threads : unsigned_int;
43
-
is_subscribed : bool;
44
-
my_rights : mailbox_rights;
45
-
}
46
-
47
-
(** Rights for a mailbox. See RFC8621 Section 2. *)
48
-
and mailbox_rights = {
49
-
may_read_items : bool;
50
-
may_add_items : bool;
51
-
may_remove_items : bool;
52
-
may_set_seen : bool;
53
-
may_set_keywords : bool;
54
-
may_create_child : bool;
55
-
may_rename : bool;
56
-
may_delete : bool;
57
-
may_submit : bool;
58
-
}
59
-
60
-
(** Filter condition for mailbox queries. See RFC8621 Section 2.3. *)
61
-
type mailbox_filter_condition = {
62
-
parent_id : id option;
63
-
name : string option;
64
-
role : string option;
65
-
has_any_role : bool option;
66
-
is_subscribed : bool option;
67
-
}
68
-
69
-
type mailbox_query_filter = [
70
-
| `And of mailbox_query_filter list
71
-
| `Or of mailbox_query_filter list
72
-
| `Not of mailbox_query_filter
73
-
| `Condition of mailbox_filter_condition
74
-
]
75
-
76
-
(** Mailbox/get request arguments. See RFC8621 Section 2.1. *)
77
-
type mailbox_get_arguments = {
78
-
account_id : id;
79
-
ids : id list option;
80
-
properties : string list option;
81
-
}
82
-
83
-
(** Mailbox/get response. See RFC8621 Section 2.1. *)
84
-
type mailbox_get_response = {
85
-
account_id : id;
86
-
state : string;
87
-
list : mailbox list;
88
-
not_found : id list;
89
-
}
90
-
91
-
(** Mailbox/changes request arguments. See RFC8621 Section 2.2. *)
92
-
type mailbox_changes_arguments = {
93
-
account_id : id;
94
-
since_state : string;
95
-
max_changes : unsigned_int option;
96
-
}
97
-
98
-
(** Mailbox/changes response. See RFC8621 Section 2.2. *)
99
-
type mailbox_changes_response = {
100
-
account_id : id;
101
-
old_state : string;
102
-
new_state : string;
103
-
has_more_changes : bool;
104
-
created : id list;
105
-
updated : id list;
106
-
destroyed : id list;
107
-
}
108
-
109
-
(** Mailbox/query request arguments. See RFC8621 Section 2.3. *)
110
-
type mailbox_query_arguments = {
111
-
account_id : id;
112
-
filter : mailbox_query_filter option;
113
-
sort : [ `name | `role | `sort_order ] list option;
114
-
limit : unsigned_int option;
115
-
}
116
-
117
-
(** Mailbox/query response. See RFC8621 Section 2.3. *)
118
-
type mailbox_query_response = {
119
-
account_id : id;
120
-
query_state : string;
121
-
can_calculate_changes : bool;
122
-
position : unsigned_int;
123
-
ids : id list;
124
-
total : unsigned_int option;
125
-
}
126
-
127
-
(** Mailbox/queryChanges request arguments. See RFC8621 Section 2.4. *)
128
-
type mailbox_query_changes_arguments = {
129
-
account_id : id;
130
-
filter : mailbox_query_filter option;
131
-
sort : [ `name | `role | `sort_order ] list option;
132
-
since_query_state : string;
133
-
max_changes : unsigned_int option;
134
-
up_to_id : id option;
135
-
}
136
-
137
-
(** Mailbox/queryChanges response. See RFC8621 Section 2.4. *)
138
-
type mailbox_query_changes_response = {
139
-
account_id : id;
140
-
old_query_state : string;
141
-
new_query_state : string;
142
-
total : unsigned_int option;
143
-
removed : id list;
144
-
added : mailbox_query_changes_added list;
145
-
}
146
-
147
-
and mailbox_query_changes_added = {
148
-
id : id;
149
-
index : unsigned_int;
150
-
}
151
-
152
-
(** Mailbox/set request arguments. See RFC8621 Section 2.5. *)
153
-
type mailbox_set_arguments = {
154
-
account_id : id;
155
-
if_in_state : string option;
156
-
create : (id * mailbox_creation) list option;
157
-
update : (id * mailbox_update) list option;
158
-
destroy : id list option;
159
-
}
160
-
161
-
and mailbox_creation = {
162
-
name : string;
163
-
parent_id : id option;
164
-
role : string option;
165
-
sort_order : unsigned_int option;
166
-
is_subscribed : bool option;
167
-
}
168
-
169
-
and mailbox_update = {
170
-
name : string option;
171
-
parent_id : id option;
172
-
role : string option;
173
-
sort_order : unsigned_int option;
174
-
is_subscribed : bool option;
175
-
}
176
-
177
-
(** Mailbox/set response. See RFC8621 Section 2.5. *)
178
-
type mailbox_set_response = {
179
-
account_id : id;
180
-
old_state : string option;
181
-
new_state : string;
182
-
created : (id * mailbox) list option;
183
-
updated : id list option;
184
-
destroyed : id list option;
185
-
not_created : (id * set_error) list option;
186
-
not_updated : (id * set_error) list option;
187
-
not_destroyed : (id * set_error) list option;
188
-
}
189
-
190
-
(** {1:thread Thread objects} *)
191
-
192
-
(** A thread in a mail account. See RFC8621 Section 3. *)
193
-
type thread = {
194
-
id : id;
195
-
email_ids : id list;
196
-
}
197
-
198
-
(** Thread/get request arguments. See RFC8621 Section 3.1. *)
199
-
type thread_get_arguments = {
200
-
account_id : id;
201
-
ids : id list option;
202
-
properties : string list option;
203
-
}
204
-
205
-
(** Thread/get response. See RFC8621 Section 3.1. *)
206
-
type thread_get_response = {
207
-
account_id : id;
208
-
state : string;
209
-
list : thread list;
210
-
not_found : id list;
211
-
}
212
-
213
-
(** Thread/changes request arguments. See RFC8621 Section 3.2. *)
214
-
type thread_changes_arguments = {
215
-
account_id : id;
216
-
since_state : string;
217
-
max_changes : unsigned_int option;
218
-
}
219
-
220
-
(** Thread/changes response. See RFC8621 Section 3.2. *)
221
-
type thread_changes_response = {
222
-
account_id : id;
223
-
old_state : string;
224
-
new_state : string;
225
-
has_more_changes : bool;
226
-
created : id list;
227
-
updated : id list;
228
-
destroyed : id list;
229
-
}
230
-
231
-
(** {1:email Email objects} *)
232
-
233
-
(** Addressing (mailbox) information. See RFC8621 Section 4.1.1. *)
234
-
type email_address = {
235
-
name : string option;
236
-
email : string;
237
-
parameters : (string * string) list;
238
-
}
239
-
240
-
(** Message header field. See RFC8621 Section 4.1.2. *)
241
-
type header = {
242
-
name : string;
243
-
value : string;
244
-
}
245
-
246
-
(** Email keyword (flag). See RFC8621 Section 4.3. *)
247
-
type keyword =
248
-
| Flagged
249
-
| Answered
250
-
| Draft
251
-
| Forwarded
252
-
| Phishing
253
-
| Junk
254
-
| NotJunk
255
-
| Seen
256
-
| Unread
257
-
| Custom of string
258
-
259
-
(** Email message. See RFC8621 Section 4. *)
260
-
type email = {
261
-
id : id;
262
-
blob_id : id;
263
-
thread_id : id;
264
-
mailbox_ids : (id * bool) list;
265
-
keywords : (keyword * bool) list;
266
-
size : unsigned_int;
267
-
received_at : utc_date;
268
-
message_id : string list;
269
-
in_reply_to : string list option;
270
-
references : string list option;
271
-
sender : email_address list option;
272
-
from : email_address list option;
273
-
to_ : email_address list option;
274
-
cc : email_address list option;
275
-
bcc : email_address list option;
276
-
reply_to : email_address list option;
277
-
subject : string option;
278
-
sent_at : utc_date option;
279
-
has_attachment : bool option;
280
-
preview : string option;
281
-
body_values : (string * string) list option;
282
-
text_body : email_body_part list option;
283
-
html_body : email_body_part list option;
284
-
attachments : email_body_part list option;
285
-
headers : header list option;
286
-
}
287
-
288
-
(** Email body part. See RFC8621 Section 4.1.4. *)
289
-
and email_body_part = {
290
-
part_id : string option;
291
-
blob_id : id option;
292
-
size : unsigned_int option;
293
-
headers : header list option;
294
-
name : string option;
295
-
type_ : string option;
296
-
charset : string option;
297
-
disposition : string option;
298
-
cid : string option;
299
-
language : string list option;
300
-
location : string option;
301
-
sub_parts : email_body_part list option;
302
-
header_parameter_name : string option;
303
-
header_parameter_value : string option;
304
-
}
305
-
306
-
(** Email query filter condition. See RFC8621 Section 4.4. *)
307
-
type email_filter_condition = {
308
-
in_mailbox : id option;
309
-
in_mailbox_other_than : id list option;
310
-
min_size : unsigned_int option;
311
-
max_size : unsigned_int option;
312
-
before : utc_date option;
313
-
after : utc_date option;
314
-
header : (string * string) option;
315
-
from : string option;
316
-
to_ : string option;
317
-
cc : string option;
318
-
bcc : string option;
319
-
subject : string option;
320
-
body : string option;
321
-
has_keyword : string option;
322
-
not_keyword : string option;
323
-
has_attachment : bool option;
324
-
text : string option;
325
-
}
326
-
327
-
type email_query_filter = [
328
-
| `And of email_query_filter list
329
-
| `Or of email_query_filter list
330
-
| `Not of email_query_filter
331
-
| `Condition of email_filter_condition
332
-
]
333
-
334
-
(** Email/get request arguments. See RFC8621 Section 4.5. *)
335
-
type email_get_arguments = {
336
-
account_id : id;
337
-
ids : id list option;
338
-
properties : string list option;
339
-
body_properties : string list option;
340
-
fetch_text_body_values : bool option;
341
-
fetch_html_body_values : bool option;
342
-
fetch_all_body_values : bool option;
343
-
max_body_value_bytes : unsigned_int option;
344
-
}
345
-
346
-
(** Email/get response. See RFC8621 Section 4.5. *)
347
-
type email_get_response = {
348
-
account_id : id;
349
-
state : string;
350
-
list : email list;
351
-
not_found : id list;
352
-
}
353
-
354
-
(** Email/changes request arguments. See RFC8621 Section 4.6. *)
355
-
type email_changes_arguments = {
356
-
account_id : id;
357
-
since_state : string;
358
-
max_changes : unsigned_int option;
359
-
}
360
-
361
-
(** Email/changes response. See RFC8621 Section 4.6. *)
362
-
type email_changes_response = {
363
-
account_id : id;
364
-
old_state : string;
365
-
new_state : string;
366
-
has_more_changes : bool;
367
-
created : id list;
368
-
updated : id list;
369
-
destroyed : id list;
370
-
}
371
-
372
-
(** Email/query request arguments. See RFC8621 Section 4.4. *)
373
-
type email_query_arguments = {
374
-
account_id : id;
375
-
filter : email_query_filter option;
376
-
sort : comparator list option;
377
-
collapse_threads : bool option;
378
-
position : unsigned_int option;
379
-
anchor : id option;
380
-
anchor_offset : int_t option;
381
-
limit : unsigned_int option;
382
-
calculate_total : bool option;
383
-
}
384
-
385
-
(** Email/query response. See RFC8621 Section 4.4. *)
386
-
type email_query_response = {
387
-
account_id : id;
388
-
query_state : string;
389
-
can_calculate_changes : bool;
390
-
position : unsigned_int;
391
-
ids : id list;
392
-
total : unsigned_int option;
393
-
thread_ids : id list option;
394
-
}
395
-
396
-
(** Email/queryChanges request arguments. See RFC8621 Section 4.7. *)
397
-
type email_query_changes_arguments = {
398
-
account_id : id;
399
-
filter : email_query_filter option;
400
-
sort : comparator list option;
401
-
collapse_threads : bool option;
402
-
since_query_state : string;
403
-
max_changes : unsigned_int option;
404
-
up_to_id : id option;
405
-
}
406
-
407
-
(** Email/queryChanges response. See RFC8621 Section 4.7. *)
408
-
type email_query_changes_response = {
409
-
account_id : id;
410
-
old_query_state : string;
411
-
new_query_state : string;
412
-
total : unsigned_int option;
413
-
removed : id list;
414
-
added : email_query_changes_added list;
415
-
}
416
-
417
-
and email_query_changes_added = {
418
-
id : id;
419
-
index : unsigned_int;
420
-
}
421
-
422
-
(** Email/set request arguments. See RFC8621 Section 4.8. *)
423
-
type email_set_arguments = {
424
-
account_id : id;
425
-
if_in_state : string option;
426
-
create : (id * email_creation) list option;
427
-
update : (id * email_update) list option;
428
-
destroy : id list option;
429
-
}
430
-
431
-
and email_creation = {
432
-
mailbox_ids : (id * bool) list;
433
-
keywords : (keyword * bool) list option;
434
-
received_at : utc_date option;
435
-
message_id : string list option;
436
-
in_reply_to : string list option;
437
-
references : string list option;
438
-
sender : email_address list option;
439
-
from : email_address list option;
440
-
to_ : email_address list option;
441
-
cc : email_address list option;
442
-
bcc : email_address list option;
443
-
reply_to : email_address list option;
444
-
subject : string option;
445
-
body_values : (string * string) list option;
446
-
text_body : email_body_part list option;
447
-
html_body : email_body_part list option;
448
-
attachments : email_body_part list option;
449
-
headers : header list option;
450
-
}
451
-
452
-
and email_update = {
453
-
keywords : (keyword * bool) list option;
454
-
mailbox_ids : (id * bool) list option;
455
-
}
456
-
457
-
(** Email/set response. See RFC8621 Section 4.8. *)
458
-
type email_set_response = {
459
-
account_id : id;
460
-
old_state : string option;
461
-
new_state : string;
462
-
created : (id * email) list option;
463
-
updated : id list option;
464
-
destroyed : id list option;
465
-
not_created : (id * set_error) list option;
466
-
not_updated : (id * set_error) list option;
467
-
not_destroyed : (id * set_error) list option;
468
-
}
469
-
470
-
(** Email/copy request arguments. See RFC8621 Section 4.9. *)
471
-
type email_copy_arguments = {
472
-
from_account_id : id;
473
-
account_id : id;
474
-
create : (id * email_creation) list;
475
-
on_success_destroy_original : bool option;
476
-
}
477
-
478
-
(** Email/copy response. See RFC8621 Section 4.9. *)
479
-
type email_copy_response = {
480
-
from_account_id : id;
481
-
account_id : id;
482
-
created : (id * email) list option;
483
-
not_created : (id * set_error) list option;
484
-
}
485
-
486
-
(** Email/import request arguments. See RFC8621 Section 4.10. *)
487
-
type email_import_arguments = {
488
-
account_id : id;
489
-
emails : (id * email_import) list;
490
-
}
491
-
492
-
and email_import = {
493
-
blob_id : id;
494
-
mailbox_ids : (id * bool) list;
495
-
keywords : (keyword * bool) list option;
496
-
received_at : utc_date option;
497
-
}
498
-
499
-
(** Email/import response. See RFC8621 Section 4.10. *)
500
-
type email_import_response = {
501
-
account_id : id;
502
-
created : (id * email) list option;
503
-
not_created : (id * set_error) list option;
504
-
}
505
-
506
-
(** {1:search_snippet Search snippets} *)
507
-
508
-
(** SearchSnippet/get request arguments. See RFC8621 Section 4.11. *)
509
-
type search_snippet_get_arguments = {
510
-
account_id : id;
511
-
email_ids : id list;
512
-
filter : email_filter_condition;
513
-
}
514
-
515
-
(** SearchSnippet/get response. See RFC8621 Section 4.11. *)
516
-
type search_snippet_get_response = {
517
-
account_id : id;
518
-
list : (id * search_snippet) list;
519
-
not_found : id list;
520
-
}
521
-
522
-
and search_snippet = {
523
-
subject : string option;
524
-
preview : string option;
525
-
}
526
-
527
-
(** {1:submission EmailSubmission objects} *)
528
-
529
-
(** EmailSubmission address. See RFC8621 Section 5.1. *)
530
-
type submission_address = {
531
-
email : string;
532
-
parameters : (string * string) list option;
533
-
}
534
-
535
-
(** Email submission object. See RFC8621 Section 5.1. *)
536
-
type email_submission = {
537
-
id : id;
538
-
identity_id : id;
539
-
email_id : id;
540
-
thread_id : id;
541
-
envelope : envelope option;
542
-
send_at : utc_date option;
543
-
undo_status : [
544
-
| `pending
545
-
| `final
546
-
| `canceled
547
-
] option;
548
-
delivery_status : (string * submission_status) list option;
549
-
dsn_blob_ids : (string * id) list option;
550
-
mdn_blob_ids : (string * id) list option;
551
-
}
552
-
553
-
(** Envelope for mail submission. See RFC8621 Section 5.1. *)
554
-
and envelope = {
555
-
mail_from : submission_address;
556
-
rcpt_to : submission_address list;
557
-
}
558
-
559
-
(** Delivery status for submitted email. See RFC8621 Section 5.1. *)
560
-
and submission_status = {
561
-
smtp_reply : string;
562
-
delivered : string option;
563
-
}
564
-
565
-
(** EmailSubmission/get request arguments. See RFC8621 Section 5.3. *)
566
-
type email_submission_get_arguments = {
567
-
account_id : id;
568
-
ids : id list option;
569
-
properties : string list option;
570
-
}
571
-
572
-
(** EmailSubmission/get response. See RFC8621 Section 5.3. *)
573
-
type email_submission_get_response = {
574
-
account_id : id;
575
-
state : string;
576
-
list : email_submission list;
577
-
not_found : id list;
578
-
}
579
-
580
-
(** EmailSubmission/changes request arguments. See RFC8621 Section 5.4. *)
581
-
type email_submission_changes_arguments = {
582
-
account_id : id;
583
-
since_state : string;
584
-
max_changes : unsigned_int option;
585
-
}
586
-
587
-
(** EmailSubmission/changes response. See RFC8621 Section 5.4. *)
588
-
type email_submission_changes_response = {
589
-
account_id : id;
590
-
old_state : string;
591
-
new_state : string;
592
-
has_more_changes : bool;
593
-
created : id list;
594
-
updated : id list;
595
-
destroyed : id list;
596
-
}
597
-
598
-
(** EmailSubmission/query filter condition. See RFC8621 Section 5.5. *)
599
-
type email_submission_filter_condition = {
600
-
identity_id : id option;
601
-
email_id : id option;
602
-
thread_id : id option;
603
-
before : utc_date option;
604
-
after : utc_date option;
605
-
subject : string option;
606
-
}
607
-
608
-
type email_submission_query_filter = [
609
-
| `And of email_submission_query_filter list
610
-
| `Or of email_submission_query_filter list
611
-
| `Not of email_submission_query_filter
612
-
| `Condition of email_submission_filter_condition
613
-
]
614
-
615
-
(** EmailSubmission/query request arguments. See RFC8621 Section 5.5. *)
616
-
type email_submission_query_arguments = {
617
-
account_id : id;
618
-
filter : email_submission_query_filter option;
619
-
sort : comparator list option;
620
-
position : unsigned_int option;
621
-
anchor : id option;
622
-
anchor_offset : int_t option;
623
-
limit : unsigned_int option;
624
-
calculate_total : bool option;
625
-
}
626
-
627
-
(** EmailSubmission/query response. See RFC8621 Section 5.5. *)
628
-
type email_submission_query_response = {
629
-
account_id : id;
630
-
query_state : string;
631
-
can_calculate_changes : bool;
632
-
position : unsigned_int;
633
-
ids : id list;
634
-
total : unsigned_int option;
635
-
}
636
-
637
-
(** EmailSubmission/set request arguments. See RFC8621 Section 5.6. *)
638
-
type email_submission_set_arguments = {
639
-
account_id : id;
640
-
if_in_state : string option;
641
-
create : (id * email_submission_creation) list option;
642
-
update : (id * email_submission_update) list option;
643
-
destroy : id list option;
644
-
on_success_update_email : (id * email_update) list option;
645
-
}
646
-
647
-
and email_submission_creation = {
648
-
email_id : id;
649
-
identity_id : id;
650
-
envelope : envelope option;
651
-
send_at : utc_date option;
652
-
}
653
-
654
-
and email_submission_update = {
655
-
email_id : id option;
656
-
identity_id : id option;
657
-
envelope : envelope option;
658
-
undo_status : [`canceled] option;
659
-
}
660
-
661
-
(** EmailSubmission/set response. See RFC8621 Section 5.6. *)
662
-
type email_submission_set_response = {
663
-
account_id : id;
664
-
old_state : string option;
665
-
new_state : string;
666
-
created : (id * email_submission) list option;
667
-
updated : id list option;
668
-
destroyed : id list option;
669
-
not_created : (id * set_error) list option;
670
-
not_updated : (id * set_error) list option;
671
-
not_destroyed : (id * set_error) list option;
672
-
}
673
-
674
-
(** {1:identity Identity objects} *)
675
-
676
-
(** Identity for sending mail. See RFC8621 Section 6. *)
677
-
type identity = {
678
-
id : id;
679
-
name : string;
680
-
email : string;
681
-
reply_to : email_address list option;
682
-
bcc : email_address list option;
683
-
text_signature : string option;
684
-
html_signature : string option;
685
-
may_delete : bool;
686
-
}
687
-
688
-
(** Identity/get request arguments. See RFC8621 Section 6.1. *)
689
-
type identity_get_arguments = {
690
-
account_id : id;
691
-
ids : id list option;
692
-
properties : string list option;
693
-
}
694
-
695
-
(** Identity/get response. See RFC8621 Section 6.1. *)
696
-
type identity_get_response = {
697
-
account_id : id;
698
-
state : string;
699
-
list : identity list;
700
-
not_found : id list;
701
-
}
702
-
703
-
(** Identity/changes request arguments. See RFC8621 Section 6.2. *)
704
-
type identity_changes_arguments = {
705
-
account_id : id;
706
-
since_state : string;
707
-
max_changes : unsigned_int option;
708
-
}
709
-
710
-
(** Identity/changes response. See RFC8621 Section 6.2. *)
711
-
type identity_changes_response = {
712
-
account_id : id;
713
-
old_state : string;
714
-
new_state : string;
715
-
has_more_changes : bool;
716
-
created : id list;
717
-
updated : id list;
718
-
destroyed : id list;
719
-
}
720
-
721
-
(** Identity/set request arguments. See RFC8621 Section 6.3. *)
722
-
type identity_set_arguments = {
723
-
account_id : id;
724
-
if_in_state : string option;
725
-
create : (id * identity_creation) list option;
726
-
update : (id * identity_update) list option;
727
-
destroy : id list option;
728
-
}
729
-
730
-
and identity_creation = {
731
-
name : string;
732
-
email : string;
733
-
reply_to : email_address list option;
734
-
bcc : email_address list option;
735
-
text_signature : string option;
736
-
html_signature : string option;
737
-
}
738
-
739
-
and identity_update = {
740
-
name : string option;
741
-
email : string option;
742
-
reply_to : email_address list option;
743
-
bcc : email_address list option;
744
-
text_signature : string option;
745
-
html_signature : string option;
746
-
}
747
-
748
-
(** Identity/set response. See RFC8621 Section 6.3. *)
749
-
type identity_set_response = {
750
-
account_id : id;
751
-
old_state : string option;
752
-
new_state : string;
753
-
created : (id * identity) list option;
754
-
updated : id list option;
755
-
destroyed : id list option;
756
-
not_created : (id * set_error) list option;
757
-
not_updated : (id * set_error) list option;
758
-
not_destroyed : (id * set_error) list option;
759
-
}
760
-
761
-
(** {1:vacation_response VacationResponse objects} *)
762
-
763
-
(** Vacation auto-reply setting. See RFC8621 Section 7. *)
764
-
type vacation_response = {
765
-
id : id;
766
-
is_enabled : bool;
767
-
from_date : utc_date option;
768
-
to_date : utc_date option;
769
-
subject : string option;
770
-
text_body : string option;
771
-
html_body : string option;
772
-
}
773
-
774
-
(** VacationResponse/get request arguments. See RFC8621 Section 7.2. *)
775
-
type vacation_response_get_arguments = {
776
-
account_id : id;
777
-
ids : id list option;
778
-
properties : string list option;
779
-
}
780
-
781
-
(** VacationResponse/get response. See RFC8621 Section 7.2. *)
782
-
type vacation_response_get_response = {
783
-
account_id : id;
784
-
state : string;
785
-
list : vacation_response list;
786
-
not_found : id list;
787
-
}
788
-
789
-
(** VacationResponse/set request arguments. See RFC8621 Section 7.3. *)
790
-
type vacation_response_set_arguments = {
791
-
account_id : id;
792
-
if_in_state : string option;
793
-
update : (id * vacation_response_update) list;
794
-
}
795
-
796
-
and vacation_response_update = {
797
-
is_enabled : bool option;
798
-
from_date : utc_date option;
799
-
to_date : utc_date option;
800
-
subject : string option;
801
-
text_body : string option;
802
-
html_body : string option;
803
-
}
804
-
805
-
(** VacationResponse/set response. See RFC8621 Section 7.3. *)
806
-
type vacation_response_set_response = {
807
-
account_id : id;
808
-
old_state : string option;
809
-
new_state : string;
810
-
updated : id list option;
811
-
not_updated : (id * set_error) list option;
812
-
}
813
-
end
814
-
815
-
(** {1 JSON serialization} *)
816
-
817
-
module Json = struct
818
-
open Types
819
-
820
-
(** {2 Helper functions for serialization} *)
821
-
822
-
let string_of_mailbox_role = function
823
-
| All -> "all"
824
-
| Archive -> "archive"
825
-
| Drafts -> "drafts"
826
-
| Flagged -> "flagged"
827
-
| Important -> "important"
828
-
| Inbox -> "inbox"
829
-
| Junk -> "junk"
830
-
| Sent -> "sent"
831
-
| Trash -> "trash"
832
-
| Unknown s -> s
833
-
834
-
let mailbox_role_of_string = function
835
-
| "all" -> All
836
-
| "archive" -> Archive
837
-
| "drafts" -> Drafts
838
-
| "flagged" -> Flagged
839
-
| "important" -> Important
840
-
| "inbox" -> Inbox
841
-
| "junk" -> Junk
842
-
| "sent" -> Sent
843
-
| "trash" -> Trash
844
-
| s -> Unknown s
845
-
846
-
let string_of_keyword = function
847
-
| Flagged -> "$flagged"
848
-
| Answered -> "$answered"
849
-
| Draft -> "$draft"
850
-
| Forwarded -> "$forwarded"
851
-
| Phishing -> "$phishing"
852
-
| Junk -> "$junk"
853
-
| NotJunk -> "$notjunk"
854
-
| Seen -> "$seen"
855
-
| Unread -> "$unread"
856
-
| Custom s -> s
857
-
858
-
let keyword_of_string = function
859
-
| "$flagged" -> Flagged
860
-
| "$answered" -> Answered
861
-
| "$draft" -> Draft
862
-
| "$forwarded" -> Forwarded
863
-
| "$phishing" -> Phishing
864
-
| "$junk" -> Junk
865
-
| "$notjunk" -> NotJunk
866
-
| "$seen" -> Seen
867
-
| "$unread" -> Unread
868
-
| s -> Custom s
869
-
870
-
(** {2 Mailbox serialization} *)
871
-
872
-
(** TODO:claude - Need to implement all JSON serialization functions
873
-
for each type we've defined. This would be a substantial amount of
874
-
code and likely require additional understanding of the ezjsonm API.
875
-
876
-
For a full implementation, we would need functions to convert between
877
-
OCaml types and JSON for each of:
878
-
- mailbox, mailbox_rights, mailbox query/update operations
879
-
- thread operations
880
-
- email, email_address, header, email_body_part
881
-
- email query/update operations
882
-
- submission operations
883
-
- identity operations
884
-
- vacation response operations
885
-
*)
886
-
end
887
-
888
-
(** {1 API functions} *)
889
-
890
-
open Lwt.Syntax
891
-
open Jmap.Api
892
-
open Jmap.Types
893
-
894
-
(** Authentication credentials for a JMAP server *)
895
-
type credentials = {
896
-
username: string;
897
-
password: string;
898
-
}
899
-
900
-
(** Connection to a JMAP mail server *)
901
-
type connection = {
902
-
session: Jmap.Types.session;
903
-
config: Jmap.Api.config;
904
-
}
905
-
906
-
(** Convert JSON mail object to OCaml type *)
907
-
let mailbox_of_json json =
908
-
try
909
-
let open Ezjsonm in
910
-
let id = get_string (find json ["id"]) in
911
-
let name = get_string (find json ["name"]) in
912
-
let parent_id = find_opt json ["parentId"] |> Option.map get_string in
913
-
let role = find_opt json ["role"] |> Option.map (fun r -> Json.mailbox_role_of_string (get_string r)) in
914
-
let sort_order = get_int (find json ["sortOrder"]) in
915
-
let total_emails = get_int (find json ["totalEmails"]) in
916
-
let unread_emails = get_int (find json ["unreadEmails"]) in
917
-
let total_threads = get_int (find json ["totalThreads"]) in
918
-
let unread_threads = get_int (find json ["unreadThreads"]) in
919
-
let is_subscribed = get_bool (find json ["isSubscribed"]) in
920
-
921
-
let rights_json = find json ["myRights"] in
922
-
let my_rights = {
923
-
Types.may_read_items = get_bool (find rights_json ["mayReadItems"]);
924
-
may_add_items = get_bool (find rights_json ["mayAddItems"]);
925
-
may_remove_items = get_bool (find rights_json ["mayRemoveItems"]);
926
-
may_set_seen = get_bool (find rights_json ["maySetSeen"]);
927
-
may_set_keywords = get_bool (find rights_json ["maySetKeywords"]);
928
-
may_create_child = get_bool (find rights_json ["mayCreateChild"]);
929
-
may_rename = get_bool (find rights_json ["mayRename"]);
930
-
may_delete = get_bool (find rights_json ["mayDelete"]);
931
-
may_submit = get_bool (find rights_json ["maySubmit"]);
932
-
} in
933
-
934
-
Ok ({
935
-
Types.id;
936
-
name;
937
-
parent_id;
938
-
role;
939
-
sort_order;
940
-
total_emails;
941
-
unread_emails;
942
-
total_threads;
943
-
unread_threads;
944
-
is_subscribed;
945
-
my_rights;
946
-
})
947
-
with
948
-
| Not_found -> Error (Parse_error "Required field not found in mailbox object")
949
-
| Invalid_argument msg -> Error (Parse_error msg)
950
-
| e -> Error (Parse_error (Printexc.to_string e))
951
-
952
-
(** Convert JSON email object to OCaml type *)
953
-
let email_of_json json =
954
-
try
955
-
let open Ezjsonm in
956
-
let id = get_string (find json ["id"]) in
957
-
let blob_id = get_string (find json ["blobId"]) in
958
-
let thread_id = get_string (find json ["threadId"]) in
959
-
960
-
(* Process mailboxIds map *)
961
-
let mailbox_ids_json = find json ["mailboxIds"] in
962
-
let mailbox_ids = match mailbox_ids_json with
963
-
| `O items -> List.map (fun (id, v) -> (id, get_bool v)) items
964
-
| _ -> raise (Invalid_argument "mailboxIds is not an object")
965
-
in
966
-
967
-
(* Process keywords map *)
968
-
let keywords_json = find json ["keywords"] in
969
-
let keywords = match keywords_json with
970
-
| `O items -> List.map (fun (k, v) ->
971
-
(Json.keyword_of_string k, get_bool v)) items
972
-
| _ -> raise (Invalid_argument "keywords is not an object")
973
-
in
974
-
975
-
let size = get_int (find json ["size"]) in
976
-
let received_at = get_string (find json ["receivedAt"]) in
977
-
let message_id = match find json ["messageId"] with
978
-
| `A ids -> List.map (fun id -> get_string id) ids
979
-
| _ -> raise (Invalid_argument "messageId is not an array")
980
-
in
981
-
982
-
(* Parse optional fields *)
983
-
let parse_email_addresses opt_json =
984
-
match opt_json with
985
-
| Some (`A items) ->
986
-
Some (List.map (fun addr_json ->
987
-
let name = find_opt addr_json ["name"] |> Option.map get_string in
988
-
let email = get_string (find addr_json ["email"]) in
989
-
let parameters = match find_opt addr_json ["parameters"] with
990
-
| Some (`O items) -> List.map (fun (k, v) -> (k, get_string v)) items
991
-
| _ -> []
992
-
in
993
-
{ Types.name; email; parameters }
994
-
) items)
995
-
| _ -> None
996
-
in
997
-
998
-
let in_reply_to = find_opt json ["inReplyTo"] |> Option.map (function
999
-
| `A ids -> List.map get_string ids
1000
-
| _ -> []
1001
-
) in
1002
-
1003
-
let references = find_opt json ["references"] |> Option.map (function
1004
-
| `A ids -> List.map get_string ids
1005
-
| _ -> []
1006
-
) in
1007
-
1008
-
let sender = parse_email_addresses (find_opt json ["sender"]) in
1009
-
let from = parse_email_addresses (find_opt json ["from"]) in
1010
-
let to_ = parse_email_addresses (find_opt json ["to"]) in
1011
-
let cc = parse_email_addresses (find_opt json ["cc"]) in
1012
-
let bcc = parse_email_addresses (find_opt json ["bcc"]) in
1013
-
let reply_to = parse_email_addresses (find_opt json ["replyTo"]) in
1014
-
1015
-
let subject = find_opt json ["subject"] |> Option.map get_string in
1016
-
let sent_at = find_opt json ["sentAt"] |> Option.map get_string in
1017
-
let has_attachment = find_opt json ["hasAttachment"] |> Option.map get_bool in
1018
-
let preview = find_opt json ["preview"] |> Option.map get_string in
1019
-
1020
-
(* Body parts parsing would go here - omitting for brevity *)
1021
-
1022
-
Ok ({
1023
-
Types.id;
1024
-
blob_id;
1025
-
thread_id;
1026
-
mailbox_ids;
1027
-
keywords;
1028
-
size;
1029
-
received_at;
1030
-
message_id;
1031
-
in_reply_to;
1032
-
references;
1033
-
sender;
1034
-
from;
1035
-
to_;
1036
-
cc;
1037
-
bcc;
1038
-
reply_to;
1039
-
subject;
1040
-
sent_at;
1041
-
has_attachment;
1042
-
preview;
1043
-
body_values = None;
1044
-
text_body = None;
1045
-
html_body = None;
1046
-
attachments = None;
1047
-
headers = None;
1048
-
})
1049
-
with
1050
-
| Not_found -> Error (Parse_error "Required field not found in email object")
1051
-
| Invalid_argument msg -> Error (Parse_error msg)
1052
-
| e -> Error (Parse_error (Printexc.to_string e))
1053
-
1054
-
(** Login to a JMAP server and establish a connection
1055
-
@param uri The URI of the JMAP server
1056
-
@param credentials Authentication credentials
1057
-
@return A connection object if successful
1058
-
1059
-
TODO:claude *)
1060
-
let login ~uri ~credentials =
1061
-
let* session_result = get_session (Uri.of_string uri)
1062
-
~username:credentials.username
1063
-
~authentication_token:credentials.password
1064
-
() in
1065
-
match session_result with
1066
-
| Ok session ->
1067
-
let api_uri = Uri.of_string session.api_url in
1068
-
let config = {
1069
-
api_uri;
1070
-
username = credentials.username;
1071
-
authentication_token = credentials.password;
1072
-
} in
1073
-
Lwt.return (Ok { session; config })
1074
-
| Error e -> Lwt.return (Error e)
1075
-
1076
-
(** Get all mailboxes for an account
1077
-
@param conn The JMAP connection
1078
-
@param account_id The account ID to get mailboxes for
1079
-
@return A list of mailboxes if successful
1080
-
1081
-
TODO:claude *)
1082
-
let get_mailboxes conn ~account_id =
1083
-
let request = {
1084
-
using = ["urn:ietf:params:jmap:core"; Types.capability_mail];
1085
-
method_calls = [
1086
-
{
1087
-
name = "Mailbox/get";
1088
-
arguments = `O [
1089
-
("accountId", `String account_id);
1090
-
];
1091
-
method_call_id = "m1";
1092
-
}
1093
-
];
1094
-
created_ids = None;
1095
-
} in
1096
-
1097
-
let* response_result = make_request conn.config request in
1098
-
match response_result with
1099
-
| Ok response ->
1100
-
let result =
1101
-
try
1102
-
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1103
-
inv.name = "Mailbox/get") response.method_responses in
1104
-
let args = method_response.arguments in
1105
-
match Ezjsonm.find_opt args ["list"] with
1106
-
| Some (`A mailbox_list) ->
1107
-
let parse_results = List.map mailbox_of_json mailbox_list in
1108
-
let (successes, failures) = List.partition Result.is_ok parse_results in
1109
-
if List.length failures > 0 then
1110
-
Error (Parse_error "Failed to parse some mailboxes")
1111
-
else
1112
-
Ok (List.map Result.get_ok successes)
1113
-
| _ -> Error (Parse_error "Mailbox list not found in response")
1114
-
with
1115
-
| Not_found -> Error (Parse_error "Mailbox/get method response not found")
1116
-
| e -> Error (Parse_error (Printexc.to_string e))
1117
-
in
1118
-
Lwt.return result
1119
-
| Error e -> Lwt.return (Error e)
1120
-
1121
-
(** Get a specific mailbox by ID
1122
-
@param conn The JMAP connection
1123
-
@param account_id The account ID
1124
-
@param mailbox_id The mailbox ID to retrieve
1125
-
@return The mailbox if found
1126
-
1127
-
TODO:claude *)
1128
-
let get_mailbox conn ~account_id ~mailbox_id =
1129
-
let request = {
1130
-
using = ["urn:ietf:params:jmap:core"; Types.capability_mail];
1131
-
method_calls = [
1132
-
{
1133
-
name = "Mailbox/get";
1134
-
arguments = `O [
1135
-
("accountId", `String account_id);
1136
-
("ids", `A [`String mailbox_id]);
1137
-
];
1138
-
method_call_id = "m1";
1139
-
}
1140
-
];
1141
-
created_ids = None;
1142
-
} in
1143
-
1144
-
let* response_result = make_request conn.config request in
1145
-
match response_result with
1146
-
| Ok response ->
1147
-
let result =
1148
-
try
1149
-
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1150
-
inv.name = "Mailbox/get") response.method_responses in
1151
-
let args = method_response.arguments in
1152
-
match Ezjsonm.find_opt args ["list"] with
1153
-
| Some (`A [mailbox]) -> mailbox_of_json mailbox
1154
-
| Some (`A []) -> Error (Parse_error ("Mailbox not found: " ^ mailbox_id))
1155
-
| _ -> Error (Parse_error "Expected single mailbox in response")
1156
-
with
1157
-
| Not_found -> Error (Parse_error "Mailbox/get method response not found")
1158
-
| e -> Error (Parse_error (Printexc.to_string e))
1159
-
in
1160
-
Lwt.return result
1161
-
| Error e -> Lwt.return (Error e)
1162
-
1163
-
(** Get messages in a mailbox
1164
-
@param conn The JMAP connection
1165
-
@param account_id The account ID
1166
-
@param mailbox_id The mailbox ID to get messages from
1167
-
@param limit Optional limit on number of messages to return
1168
-
@return The list of email messages if successful
1169
-
1170
-
TODO:claude *)
1171
-
let get_messages_in_mailbox conn ~account_id ~mailbox_id ?limit () =
1172
-
(* First query the emails in the mailbox *)
1173
-
let query_request = {
1174
-
using = ["urn:ietf:params:jmap:core"; Types.capability_mail];
1175
-
method_calls = [
1176
-
{
1177
-
name = "Email/query";
1178
-
arguments = `O ([
1179
-
("accountId", `String account_id);
1180
-
("filter", `O [("inMailbox", `String mailbox_id)]);
1181
-
("sort", `A [`O [("property", `String "receivedAt"); ("isAscending", `Bool false)]]);
1182
-
] @ (match limit with
1183
-
| Some l -> [("limit", `Float (float_of_int l))]
1184
-
| None -> []
1185
-
));
1186
-
method_call_id = "q1";
1187
-
}
1188
-
];
1189
-
created_ids = None;
1190
-
} in
1191
-
1192
-
let* query_result = make_request conn.config query_request in
1193
-
match query_result with
1194
-
| Ok query_response ->
1195
-
(try
1196
-
let query_method = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1197
-
inv.name = "Email/query") query_response.method_responses in
1198
-
let args = query_method.arguments in
1199
-
match Ezjsonm.find_opt args ["ids"] with
1200
-
| Some (`A ids) ->
1201
-
let email_ids = List.map (function
1202
-
| `String id -> id
1203
-
| _ -> raise (Invalid_argument "Email ID is not a string")
1204
-
) ids in
1205
-
1206
-
(* If we have IDs, fetch the actual email objects *)
1207
-
if List.length email_ids > 0 then
1208
-
let get_request = {
1209
-
using = ["urn:ietf:params:jmap:core"; Types.capability_mail];
1210
-
method_calls = [
1211
-
{
1212
-
name = "Email/get";
1213
-
arguments = `O [
1214
-
("accountId", `String account_id);
1215
-
("ids", `A (List.map (fun id -> `String id) email_ids));
1216
-
];
1217
-
method_call_id = "g1";
1218
-
}
1219
-
];
1220
-
created_ids = None;
1221
-
} in
1222
-
1223
-
let* get_result = make_request conn.config get_request in
1224
-
match get_result with
1225
-
| Ok get_response ->
1226
-
(try
1227
-
let get_method = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1228
-
inv.name = "Email/get") get_response.method_responses in
1229
-
let args = get_method.arguments in
1230
-
match Ezjsonm.find_opt args ["list"] with
1231
-
| Some (`A email_list) ->
1232
-
let parse_results = List.map email_of_json email_list in
1233
-
let (successes, failures) = List.partition Result.is_ok parse_results in
1234
-
if List.length failures > 0 then
1235
-
Lwt.return (Error (Parse_error "Failed to parse some emails"))
1236
-
else
1237
-
Lwt.return (Ok (List.map Result.get_ok successes))
1238
-
| _ -> Lwt.return (Error (Parse_error "Email list not found in response"))
1239
-
with
1240
-
| Not_found -> Lwt.return (Error (Parse_error "Email/get method response not found"))
1241
-
| e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
1242
-
| Error e -> Lwt.return (Error e)
1243
-
else
1244
-
(* No emails in mailbox *)
1245
-
Lwt.return (Ok [])
1246
-
1247
-
| _ -> Lwt.return (Error (Parse_error "Email IDs not found in query response"))
1248
-
with
1249
-
| Not_found -> Lwt.return (Error (Parse_error "Email/query method response not found"))
1250
-
| Invalid_argument msg -> Lwt.return (Error (Parse_error msg))
1251
-
| e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
1252
-
| Error e -> Lwt.return (Error e)
1253
-
1254
-
(** Get a single email message by ID
1255
-
@param conn The JMAP connection
1256
-
@param account_id The account ID
1257
-
@param email_id The email ID to retrieve
1258
-
@return The email message if found
1259
-
1260
-
TODO:claude *)
1261
-
let get_email conn ~account_id ~email_id =
1262
-
let request = {
1263
-
using = ["urn:ietf:params:jmap:core"; Types.capability_mail];
1264
-
method_calls = [
1265
-
{
1266
-
name = "Email/get";
1267
-
arguments = `O [
1268
-
("accountId", `String account_id);
1269
-
("ids", `A [`String email_id]);
1270
-
];
1271
-
method_call_id = "m1";
1272
-
}
1273
-
];
1274
-
created_ids = None;
1275
-
} in
1276
-
1277
-
let* response_result = make_request conn.config request in
1278
-
match response_result with
1279
-
| Ok response ->
1280
-
let result =
1281
-
try
1282
-
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1283
-
inv.name = "Email/get") response.method_responses in
1284
-
let args = method_response.arguments in
1285
-
match Ezjsonm.find_opt args ["list"] with
1286
-
| Some (`A [email]) -> email_of_json email
1287
-
| Some (`A []) -> Error (Parse_error ("Email not found: " ^ email_id))
1288
-
| _ -> Error (Parse_error "Expected single email in response")
1289
-
with
1290
-
| Not_found -> Error (Parse_error "Email/get method response not found")
1291
-
| e -> Error (Parse_error (Printexc.to_string e))
1292
-
in
1293
-
Lwt.return result
1294
-
| Error e -> Lwt.return (Error e)
-920
lib/jmap_mail.mli
-920
lib/jmap_mail.mli
···
1
-
(** Implementation of the JMAP Mail extension, as defined in RFC8621 *)
2
-
3
-
(** Types for the JMAP Mail extension *)
4
-
module Types : sig
5
-
open Jmap.Types
6
-
7
-
(** {1 Mail capabilities} *)
8
-
9
-
(** Capability URI for JMAP Mail*)
10
-
val capability_mail : string
11
-
12
-
(** Capability URI for JMAP Submission *)
13
-
val capability_submission : string
14
-
15
-
(** Capability URI for JMAP Vacation Response *)
16
-
val capability_vacation_response : string
17
-
18
-
(** {1:mailbox Mailbox objects} *)
19
-
20
-
(** A role for a mailbox. See RFC8621 Section 2. *)
21
-
type mailbox_role =
22
-
| All (** All mail *)
23
-
| Archive (** Archived mail *)
24
-
| Drafts (** Draft messages *)
25
-
| Flagged (** Starred/flagged mail *)
26
-
| Important (** Important mail *)
27
-
| Inbox (** Inbox *)
28
-
| Junk (** Spam/Junk mail *)
29
-
| Sent (** Sent mail *)
30
-
| Trash (** Deleted/Trash mail *)
31
-
| Unknown of string (** Server-specific roles *)
32
-
33
-
(** A mailbox (folder) in a mail account. See RFC8621 Section 2. *)
34
-
type mailbox = {
35
-
id : id;
36
-
name : string;
37
-
parent_id : id option;
38
-
role : mailbox_role option;
39
-
sort_order : unsigned_int;
40
-
total_emails : unsigned_int;
41
-
unread_emails : unsigned_int;
42
-
total_threads : unsigned_int;
43
-
unread_threads : unsigned_int;
44
-
is_subscribed : bool;
45
-
my_rights : mailbox_rights;
46
-
}
47
-
48
-
(** Rights for a mailbox. See RFC8621 Section 2. *)
49
-
and mailbox_rights = {
50
-
may_read_items : bool;
51
-
may_add_items : bool;
52
-
may_remove_items : bool;
53
-
may_set_seen : bool;
54
-
may_set_keywords : bool;
55
-
may_create_child : bool;
56
-
may_rename : bool;
57
-
may_delete : bool;
58
-
may_submit : bool;
59
-
}
60
-
61
-
(** Filter condition for mailbox queries. See RFC8621 Section 2.3. *)
62
-
type mailbox_filter_condition = {
63
-
parent_id : id option;
64
-
name : string option;
65
-
role : string option;
66
-
has_any_role : bool option;
67
-
is_subscribed : bool option;
68
-
}
69
-
70
-
type mailbox_query_filter = [
71
-
| `And of mailbox_query_filter list
72
-
| `Or of mailbox_query_filter list
73
-
| `Not of mailbox_query_filter
74
-
| `Condition of mailbox_filter_condition
75
-
]
76
-
77
-
(** Mailbox/get request arguments. See RFC8621 Section 2.1. *)
78
-
type mailbox_get_arguments = {
79
-
account_id : id;
80
-
ids : id list option;
81
-
properties : string list option;
82
-
}
83
-
84
-
(** Mailbox/get response. See RFC8621 Section 2.1. *)
85
-
type mailbox_get_response = {
86
-
account_id : id;
87
-
state : string;
88
-
list : mailbox list;
89
-
not_found : id list;
90
-
}
91
-
92
-
(** Mailbox/changes request arguments. See RFC8621 Section 2.2. *)
93
-
type mailbox_changes_arguments = {
94
-
account_id : id;
95
-
since_state : string;
96
-
max_changes : unsigned_int option;
97
-
}
98
-
99
-
(** Mailbox/changes response. See RFC8621 Section 2.2. *)
100
-
type mailbox_changes_response = {
101
-
account_id : id;
102
-
old_state : string;
103
-
new_state : string;
104
-
has_more_changes : bool;
105
-
created : id list;
106
-
updated : id list;
107
-
destroyed : id list;
108
-
}
109
-
110
-
(** Mailbox/query request arguments. See RFC8621 Section 2.3. *)
111
-
type mailbox_query_arguments = {
112
-
account_id : id;
113
-
filter : mailbox_query_filter option;
114
-
sort : [ `name | `role | `sort_order ] list option;
115
-
limit : unsigned_int option;
116
-
}
117
-
118
-
(** Mailbox/query response. See RFC8621 Section 2.3. *)
119
-
type mailbox_query_response = {
120
-
account_id : id;
121
-
query_state : string;
122
-
can_calculate_changes : bool;
123
-
position : unsigned_int;
124
-
ids : id list;
125
-
total : unsigned_int option;
126
-
}
127
-
128
-
(** Mailbox/queryChanges request arguments. See RFC8621 Section 2.4. *)
129
-
type mailbox_query_changes_arguments = {
130
-
account_id : id;
131
-
filter : mailbox_query_filter option;
132
-
sort : [ `name | `role | `sort_order ] list option;
133
-
since_query_state : string;
134
-
max_changes : unsigned_int option;
135
-
up_to_id : id option;
136
-
}
137
-
138
-
(** Mailbox/queryChanges response. See RFC8621 Section 2.4. *)
139
-
type mailbox_query_changes_response = {
140
-
account_id : id;
141
-
old_query_state : string;
142
-
new_query_state : string;
143
-
total : unsigned_int option;
144
-
removed : id list;
145
-
added : mailbox_query_changes_added list;
146
-
}
147
-
148
-
and mailbox_query_changes_added = {
149
-
id : id;
150
-
index : unsigned_int;
151
-
}
152
-
153
-
(** Mailbox/set request arguments. See RFC8621 Section 2.5. *)
154
-
type mailbox_set_arguments = {
155
-
account_id : id;
156
-
if_in_state : string option;
157
-
create : (id * mailbox_creation) list option;
158
-
update : (id * mailbox_update) list option;
159
-
destroy : id list option;
160
-
}
161
-
162
-
and mailbox_creation = {
163
-
name : string;
164
-
parent_id : id option;
165
-
role : string option;
166
-
sort_order : unsigned_int option;
167
-
is_subscribed : bool option;
168
-
}
169
-
170
-
and mailbox_update = {
171
-
name : string option;
172
-
parent_id : id option;
173
-
role : string option;
174
-
sort_order : unsigned_int option;
175
-
is_subscribed : bool option;
176
-
}
177
-
178
-
(** Mailbox/set response. See RFC8621 Section 2.5. *)
179
-
type mailbox_set_response = {
180
-
account_id : id;
181
-
old_state : string option;
182
-
new_state : string;
183
-
created : (id * mailbox) list option;
184
-
updated : id list option;
185
-
destroyed : id list option;
186
-
not_created : (id * set_error) list option;
187
-
not_updated : (id * set_error) list option;
188
-
not_destroyed : (id * set_error) list option;
189
-
}
190
-
191
-
(** {1:thread Thread objects} *)
192
-
193
-
(** A thread in a mail account. See RFC8621 Section 3. *)
194
-
type thread = {
195
-
id : id;
196
-
email_ids : id list;
197
-
}
198
-
199
-
(** Thread/get request arguments. See RFC8621 Section 3.1. *)
200
-
type thread_get_arguments = {
201
-
account_id : id;
202
-
ids : id list option;
203
-
properties : string list option;
204
-
}
205
-
206
-
(** Thread/get response. See RFC8621 Section 3.1. *)
207
-
type thread_get_response = {
208
-
account_id : id;
209
-
state : string;
210
-
list : thread list;
211
-
not_found : id list;
212
-
}
213
-
214
-
(** Thread/changes request arguments. See RFC8621 Section 3.2. *)
215
-
type thread_changes_arguments = {
216
-
account_id : id;
217
-
since_state : string;
218
-
max_changes : unsigned_int option;
219
-
}
220
-
221
-
(** Thread/changes response. See RFC8621 Section 3.2. *)
222
-
type thread_changes_response = {
223
-
account_id : id;
224
-
old_state : string;
225
-
new_state : string;
226
-
has_more_changes : bool;
227
-
created : id list;
228
-
updated : id list;
229
-
destroyed : id list;
230
-
}
231
-
232
-
(** {1:email Email objects} *)
233
-
234
-
(** Addressing (mailbox) information. See RFC8621 Section 4.1.1. *)
235
-
type email_address = {
236
-
name : string option;
237
-
email : string;
238
-
parameters : (string * string) list;
239
-
}
240
-
241
-
(** Message header field. See RFC8621 Section 4.1.2. *)
242
-
type header = {
243
-
name : string;
244
-
value : string;
245
-
}
246
-
247
-
(** Email keyword (flag). See RFC8621 Section 4.3. *)
248
-
type keyword =
249
-
| Flagged
250
-
| Answered
251
-
| Draft
252
-
| Forwarded
253
-
| Phishing
254
-
| Junk
255
-
| NotJunk
256
-
| Seen
257
-
| Unread
258
-
| Custom of string
259
-
260
-
(** Email message. See RFC8621 Section 4. *)
261
-
type email = {
262
-
id : id;
263
-
blob_id : id;
264
-
thread_id : id;
265
-
mailbox_ids : (id * bool) list;
266
-
keywords : (keyword * bool) list;
267
-
size : unsigned_int;
268
-
received_at : utc_date;
269
-
message_id : string list;
270
-
in_reply_to : string list option;
271
-
references : string list option;
272
-
sender : email_address list option;
273
-
from : email_address list option;
274
-
to_ : email_address list option;
275
-
cc : email_address list option;
276
-
bcc : email_address list option;
277
-
reply_to : email_address list option;
278
-
subject : string option;
279
-
sent_at : utc_date option;
280
-
has_attachment : bool option;
281
-
preview : string option;
282
-
body_values : (string * string) list option;
283
-
text_body : email_body_part list option;
284
-
html_body : email_body_part list option;
285
-
attachments : email_body_part list option;
286
-
headers : header list option;
287
-
}
288
-
289
-
(** Email body part. See RFC8621 Section 4.1.4. *)
290
-
and email_body_part = {
291
-
part_id : string option;
292
-
blob_id : id option;
293
-
size : unsigned_int option;
294
-
headers : header list option;
295
-
name : string option;
296
-
type_ : string option;
297
-
charset : string option;
298
-
disposition : string option;
299
-
cid : string option;
300
-
language : string list option;
301
-
location : string option;
302
-
sub_parts : email_body_part list option;
303
-
header_parameter_name : string option;
304
-
header_parameter_value : string option;
305
-
}
306
-
307
-
(** Email query filter condition. See RFC8621 Section 4.4. *)
308
-
type email_filter_condition = {
309
-
in_mailbox : id option;
310
-
in_mailbox_other_than : id list option;
311
-
min_size : unsigned_int option;
312
-
max_size : unsigned_int option;
313
-
before : utc_date option;
314
-
after : utc_date option;
315
-
header : (string * string) option;
316
-
from : string option;
317
-
to_ : string option;
318
-
cc : string option;
319
-
bcc : string option;
320
-
subject : string option;
321
-
body : string option;
322
-
has_keyword : string option;
323
-
not_keyword : string option;
324
-
has_attachment : bool option;
325
-
text : string option;
326
-
}
327
-
328
-
type email_query_filter = [
329
-
| `And of email_query_filter list
330
-
| `Or of email_query_filter list
331
-
| `Not of email_query_filter
332
-
| `Condition of email_filter_condition
333
-
]
334
-
335
-
(** Email/get request arguments. See RFC8621 Section 4.5. *)
336
-
type email_get_arguments = {
337
-
account_id : id;
338
-
ids : id list option;
339
-
properties : string list option;
340
-
body_properties : string list option;
341
-
fetch_text_body_values : bool option;
342
-
fetch_html_body_values : bool option;
343
-
fetch_all_body_values : bool option;
344
-
max_body_value_bytes : unsigned_int option;
345
-
}
346
-
347
-
(** Email/get response. See RFC8621 Section 4.5. *)
348
-
type email_get_response = {
349
-
account_id : id;
350
-
state : string;
351
-
list : email list;
352
-
not_found : id list;
353
-
}
354
-
355
-
(** Email/changes request arguments. See RFC8621 Section 4.6. *)
356
-
type email_changes_arguments = {
357
-
account_id : id;
358
-
since_state : string;
359
-
max_changes : unsigned_int option;
360
-
}
361
-
362
-
(** Email/changes response. See RFC8621 Section 4.6. *)
363
-
type email_changes_response = {
364
-
account_id : id;
365
-
old_state : string;
366
-
new_state : string;
367
-
has_more_changes : bool;
368
-
created : id list;
369
-
updated : id list;
370
-
destroyed : id list;
371
-
}
372
-
373
-
(** Email/query request arguments. See RFC8621 Section 4.4. *)
374
-
type email_query_arguments = {
375
-
account_id : id;
376
-
filter : email_query_filter option;
377
-
sort : comparator list option;
378
-
collapse_threads : bool option;
379
-
position : unsigned_int option;
380
-
anchor : id option;
381
-
anchor_offset : int_t option;
382
-
limit : unsigned_int option;
383
-
calculate_total : bool option;
384
-
}
385
-
386
-
(** Email/query response. See RFC8621 Section 4.4. *)
387
-
type email_query_response = {
388
-
account_id : id;
389
-
query_state : string;
390
-
can_calculate_changes : bool;
391
-
position : unsigned_int;
392
-
ids : id list;
393
-
total : unsigned_int option;
394
-
thread_ids : id list option;
395
-
}
396
-
397
-
(** Email/queryChanges request arguments. See RFC8621 Section 4.7. *)
398
-
type email_query_changes_arguments = {
399
-
account_id : id;
400
-
filter : email_query_filter option;
401
-
sort : comparator list option;
402
-
collapse_threads : bool option;
403
-
since_query_state : string;
404
-
max_changes : unsigned_int option;
405
-
up_to_id : id option;
406
-
}
407
-
408
-
(** Email/queryChanges response. See RFC8621 Section 4.7. *)
409
-
type email_query_changes_response = {
410
-
account_id : id;
411
-
old_query_state : string;
412
-
new_query_state : string;
413
-
total : unsigned_int option;
414
-
removed : id list;
415
-
added : email_query_changes_added list;
416
-
}
417
-
418
-
and email_query_changes_added = {
419
-
id : id;
420
-
index : unsigned_int;
421
-
}
422
-
423
-
(** Email/set request arguments. See RFC8621 Section 4.8. *)
424
-
type email_set_arguments = {
425
-
account_id : id;
426
-
if_in_state : string option;
427
-
create : (id * email_creation) list option;
428
-
update : (id * email_update) list option;
429
-
destroy : id list option;
430
-
}
431
-
432
-
and email_creation = {
433
-
mailbox_ids : (id * bool) list;
434
-
keywords : (keyword * bool) list option;
435
-
received_at : utc_date option;
436
-
message_id : string list option;
437
-
in_reply_to : string list option;
438
-
references : string list option;
439
-
sender : email_address list option;
440
-
from : email_address list option;
441
-
to_ : email_address list option;
442
-
cc : email_address list option;
443
-
bcc : email_address list option;
444
-
reply_to : email_address list option;
445
-
subject : string option;
446
-
body_values : (string * string) list option;
447
-
text_body : email_body_part list option;
448
-
html_body : email_body_part list option;
449
-
attachments : email_body_part list option;
450
-
headers : header list option;
451
-
}
452
-
453
-
and email_update = {
454
-
keywords : (keyword * bool) list option;
455
-
mailbox_ids : (id * bool) list option;
456
-
}
457
-
458
-
(** Email/set response. See RFC8621 Section 4.8. *)
459
-
type email_set_response = {
460
-
account_id : id;
461
-
old_state : string option;
462
-
new_state : string;
463
-
created : (id * email) list option;
464
-
updated : id list option;
465
-
destroyed : id list option;
466
-
not_created : (id * set_error) list option;
467
-
not_updated : (id * set_error) list option;
468
-
not_destroyed : (id * set_error) list option;
469
-
}
470
-
471
-
(** Email/copy request arguments. See RFC8621 Section 4.9. *)
472
-
type email_copy_arguments = {
473
-
from_account_id : id;
474
-
account_id : id;
475
-
create : (id * email_creation) list;
476
-
on_success_destroy_original : bool option;
477
-
}
478
-
479
-
(** Email/copy response. See RFC8621 Section 4.9. *)
480
-
type email_copy_response = {
481
-
from_account_id : id;
482
-
account_id : id;
483
-
created : (id * email) list option;
484
-
not_created : (id * set_error) list option;
485
-
}
486
-
487
-
(** Email/import request arguments. See RFC8621 Section 4.10. *)
488
-
type email_import_arguments = {
489
-
account_id : id;
490
-
emails : (id * email_import) list;
491
-
}
492
-
493
-
and email_import = {
494
-
blob_id : id;
495
-
mailbox_ids : (id * bool) list;
496
-
keywords : (keyword * bool) list option;
497
-
received_at : utc_date option;
498
-
}
499
-
500
-
(** Email/import response. See RFC8621 Section 4.10. *)
501
-
type email_import_response = {
502
-
account_id : id;
503
-
created : (id * email) list option;
504
-
not_created : (id * set_error) list option;
505
-
}
506
-
507
-
(** {1:search_snippet Search snippets} *)
508
-
509
-
(** SearchSnippet/get request arguments. See RFC8621 Section 4.11. *)
510
-
type search_snippet_get_arguments = {
511
-
account_id : id;
512
-
email_ids : id list;
513
-
filter : email_filter_condition;
514
-
}
515
-
516
-
(** SearchSnippet/get response. See RFC8621 Section 4.11. *)
517
-
type search_snippet_get_response = {
518
-
account_id : id;
519
-
list : (id * search_snippet) list;
520
-
not_found : id list;
521
-
}
522
-
523
-
and search_snippet = {
524
-
subject : string option;
525
-
preview : string option;
526
-
}
527
-
528
-
(** {1:submission EmailSubmission objects} *)
529
-
530
-
(** EmailSubmission address. See RFC8621 Section 5.1. *)
531
-
type submission_address = {
532
-
email : string;
533
-
parameters : (string * string) list option;
534
-
}
535
-
536
-
(** Email submission object. See RFC8621 Section 5.1. *)
537
-
type email_submission = {
538
-
id : id;
539
-
identity_id : id;
540
-
email_id : id;
541
-
thread_id : id;
542
-
envelope : envelope option;
543
-
send_at : utc_date option;
544
-
undo_status : [
545
-
| `pending
546
-
| `final
547
-
| `canceled
548
-
] option;
549
-
delivery_status : (string * submission_status) list option;
550
-
dsn_blob_ids : (string * id) list option;
551
-
mdn_blob_ids : (string * id) list option;
552
-
}
553
-
554
-
(** Envelope for mail submission. See RFC8621 Section 5.1. *)
555
-
and envelope = {
556
-
mail_from : submission_address;
557
-
rcpt_to : submission_address list;
558
-
}
559
-
560
-
(** Delivery status for submitted email. See RFC8621 Section 5.1. *)
561
-
and submission_status = {
562
-
smtp_reply : string;
563
-
delivered : string option;
564
-
}
565
-
566
-
(** EmailSubmission/get request arguments. See RFC8621 Section 5.3. *)
567
-
type email_submission_get_arguments = {
568
-
account_id : id;
569
-
ids : id list option;
570
-
properties : string list option;
571
-
}
572
-
573
-
(** EmailSubmission/get response. See RFC8621 Section 5.3. *)
574
-
type email_submission_get_response = {
575
-
account_id : id;
576
-
state : string;
577
-
list : email_submission list;
578
-
not_found : id list;
579
-
}
580
-
581
-
(** EmailSubmission/changes request arguments. See RFC8621 Section 5.4. *)
582
-
type email_submission_changes_arguments = {
583
-
account_id : id;
584
-
since_state : string;
585
-
max_changes : unsigned_int option;
586
-
}
587
-
588
-
(** EmailSubmission/changes response. See RFC8621 Section 5.4. *)
589
-
type email_submission_changes_response = {
590
-
account_id : id;
591
-
old_state : string;
592
-
new_state : string;
593
-
has_more_changes : bool;
594
-
created : id list;
595
-
updated : id list;
596
-
destroyed : id list;
597
-
}
598
-
599
-
(** EmailSubmission/query filter condition. See RFC8621 Section 5.5. *)
600
-
type email_submission_filter_condition = {
601
-
identity_id : id option;
602
-
email_id : id option;
603
-
thread_id : id option;
604
-
before : utc_date option;
605
-
after : utc_date option;
606
-
subject : string option;
607
-
}
608
-
609
-
type email_submission_query_filter = [
610
-
| `And of email_submission_query_filter list
611
-
| `Or of email_submission_query_filter list
612
-
| `Not of email_submission_query_filter
613
-
| `Condition of email_submission_filter_condition
614
-
]
615
-
616
-
(** EmailSubmission/query request arguments. See RFC8621 Section 5.5. *)
617
-
type email_submission_query_arguments = {
618
-
account_id : id;
619
-
filter : email_submission_query_filter option;
620
-
sort : comparator list option;
621
-
position : unsigned_int option;
622
-
anchor : id option;
623
-
anchor_offset : int_t option;
624
-
limit : unsigned_int option;
625
-
calculate_total : bool option;
626
-
}
627
-
628
-
(** EmailSubmission/query response. See RFC8621 Section 5.5. *)
629
-
type email_submission_query_response = {
630
-
account_id : id;
631
-
query_state : string;
632
-
can_calculate_changes : bool;
633
-
position : unsigned_int;
634
-
ids : id list;
635
-
total : unsigned_int option;
636
-
}
637
-
638
-
(** EmailSubmission/set request arguments. See RFC8621 Section 5.6. *)
639
-
type email_submission_set_arguments = {
640
-
account_id : id;
641
-
if_in_state : string option;
642
-
create : (id * email_submission_creation) list option;
643
-
update : (id * email_submission_update) list option;
644
-
destroy : id list option;
645
-
on_success_update_email : (id * email_update) list option;
646
-
}
647
-
648
-
and email_submission_creation = {
649
-
email_id : id;
650
-
identity_id : id;
651
-
envelope : envelope option;
652
-
send_at : utc_date option;
653
-
}
654
-
655
-
and email_submission_update = {
656
-
email_id : id option;
657
-
identity_id : id option;
658
-
envelope : envelope option;
659
-
undo_status : [`canceled] option;
660
-
}
661
-
662
-
(** EmailSubmission/set response. See RFC8621 Section 5.6. *)
663
-
type email_submission_set_response = {
664
-
account_id : id;
665
-
old_state : string option;
666
-
new_state : string;
667
-
created : (id * email_submission) list option;
668
-
updated : id list option;
669
-
destroyed : id list option;
670
-
not_created : (id * set_error) list option;
671
-
not_updated : (id * set_error) list option;
672
-
not_destroyed : (id * set_error) list option;
673
-
}
674
-
675
-
(** {1:identity Identity objects} *)
676
-
677
-
(** Identity for sending mail. See RFC8621 Section 6. *)
678
-
type identity = {
679
-
id : id;
680
-
name : string;
681
-
email : string;
682
-
reply_to : email_address list option;
683
-
bcc : email_address list option;
684
-
text_signature : string option;
685
-
html_signature : string option;
686
-
may_delete : bool;
687
-
}
688
-
689
-
(** Identity/get request arguments. See RFC8621 Section 6.1. *)
690
-
type identity_get_arguments = {
691
-
account_id : id;
692
-
ids : id list option;
693
-
properties : string list option;
694
-
}
695
-
696
-
(** Identity/get response. See RFC8621 Section 6.1. *)
697
-
type identity_get_response = {
698
-
account_id : id;
699
-
state : string;
700
-
list : identity list;
701
-
not_found : id list;
702
-
}
703
-
704
-
(** Identity/changes request arguments. See RFC8621 Section 6.2. *)
705
-
type identity_changes_arguments = {
706
-
account_id : id;
707
-
since_state : string;
708
-
max_changes : unsigned_int option;
709
-
}
710
-
711
-
(** Identity/changes response. See RFC8621 Section 6.2. *)
712
-
type identity_changes_response = {
713
-
account_id : id;
714
-
old_state : string;
715
-
new_state : string;
716
-
has_more_changes : bool;
717
-
created : id list;
718
-
updated : id list;
719
-
destroyed : id list;
720
-
}
721
-
722
-
(** Identity/set request arguments. See RFC8621 Section 6.3. *)
723
-
type identity_set_arguments = {
724
-
account_id : id;
725
-
if_in_state : string option;
726
-
create : (id * identity_creation) list option;
727
-
update : (id * identity_update) list option;
728
-
destroy : id list option;
729
-
}
730
-
731
-
and identity_creation = {
732
-
name : string;
733
-
email : string;
734
-
reply_to : email_address list option;
735
-
bcc : email_address list option;
736
-
text_signature : string option;
737
-
html_signature : string option;
738
-
}
739
-
740
-
and identity_update = {
741
-
name : string option;
742
-
email : string option;
743
-
reply_to : email_address list option;
744
-
bcc : email_address list option;
745
-
text_signature : string option;
746
-
html_signature : string option;
747
-
}
748
-
749
-
(** Identity/set response. See RFC8621 Section 6.3. *)
750
-
type identity_set_response = {
751
-
account_id : id;
752
-
old_state : string option;
753
-
new_state : string;
754
-
created : (id * identity) list option;
755
-
updated : id list option;
756
-
destroyed : id list option;
757
-
not_created : (id * set_error) list option;
758
-
not_updated : (id * set_error) list option;
759
-
not_destroyed : (id * set_error) list option;
760
-
}
761
-
762
-
(** {1:vacation_response VacationResponse objects} *)
763
-
764
-
(** Vacation auto-reply setting. See RFC8621 Section 7. *)
765
-
type vacation_response = {
766
-
id : id;
767
-
is_enabled : bool;
768
-
from_date : utc_date option;
769
-
to_date : utc_date option;
770
-
subject : string option;
771
-
text_body : string option;
772
-
html_body : string option;
773
-
}
774
-
775
-
(** VacationResponse/get request arguments. See RFC8621 Section 7.2. *)
776
-
type vacation_response_get_arguments = {
777
-
account_id : id;
778
-
ids : id list option;
779
-
properties : string list option;
780
-
}
781
-
782
-
(** VacationResponse/get response. See RFC8621 Section 7.2. *)
783
-
type vacation_response_get_response = {
784
-
account_id : id;
785
-
state : string;
786
-
list : vacation_response list;
787
-
not_found : id list;
788
-
}
789
-
790
-
(** VacationResponse/set request arguments. See RFC8621 Section 7.3. *)
791
-
type vacation_response_set_arguments = {
792
-
account_id : id;
793
-
if_in_state : string option;
794
-
update : (id * vacation_response_update) list;
795
-
}
796
-
797
-
and vacation_response_update = {
798
-
is_enabled : bool option;
799
-
from_date : utc_date option;
800
-
to_date : utc_date option;
801
-
subject : string option;
802
-
text_body : string option;
803
-
html_body : string option;
804
-
}
805
-
806
-
(** VacationResponse/set response. See RFC8621 Section 7.3. *)
807
-
type vacation_response_set_response = {
808
-
account_id : id;
809
-
old_state : string option;
810
-
new_state : string;
811
-
updated : id list option;
812
-
not_updated : (id * set_error) list option;
813
-
}
814
-
end
815
-
816
-
(** {1 JSON serialization} *)
817
-
818
-
module Json : sig
819
-
open Types
820
-
821
-
(** {2 Helper functions for serialization} *)
822
-
823
-
val string_of_mailbox_role : mailbox_role -> string
824
-
val mailbox_role_of_string : string -> mailbox_role
825
-
826
-
val string_of_keyword : keyword -> string
827
-
val keyword_of_string : string -> keyword
828
-
829
-
(** {2 Mailbox serialization} *)
830
-
831
-
(** TODO:claude - Need to implement all JSON serialization functions
832
-
for each type we've defined. This would be a substantial amount of
833
-
code and likely require additional understanding of the ezjsonm API.
834
-
835
-
The interface would include functions like:
836
-
837
-
val mailbox_to_json : mailbox -> Ezjsonm.value
838
-
val mailbox_of_json : Ezjsonm.value -> mailbox result
839
-
840
-
And similarly for all other types.
841
-
*)
842
-
end
843
-
844
-
(** {1 API functions} *)
845
-
846
-
(** Authentication credentials for a JMAP server *)
847
-
type credentials = {
848
-
username: string;
849
-
password: string;
850
-
}
851
-
852
-
(** Connection to a JMAP mail server *)
853
-
type connection = {
854
-
session: Jmap.Types.session;
855
-
config: Jmap.Api.config;
856
-
}
857
-
858
-
(** Login to a JMAP server and establish a connection
859
-
@param uri The URI of the JMAP server
860
-
@param credentials Authentication credentials
861
-
@return A connection object if successful
862
-
863
-
TODO:claude *)
864
-
val login :
865
-
uri:string ->
866
-
credentials:credentials ->
867
-
(connection, Jmap.Api.error) result Lwt.t
868
-
869
-
(** Get all mailboxes for an account
870
-
@param conn The JMAP connection
871
-
@param account_id The account ID to get mailboxes for
872
-
@return A list of mailboxes if successful
873
-
874
-
TODO:claude *)
875
-
val get_mailboxes :
876
-
connection ->
877
-
account_id:Jmap.Types.id ->
878
-
(Types.mailbox list, Jmap.Api.error) result Lwt.t
879
-
880
-
(** Get a specific mailbox by ID
881
-
@param conn The JMAP connection
882
-
@param account_id The account ID
883
-
@param mailbox_id The mailbox ID to retrieve
884
-
@return The mailbox if found
885
-
886
-
TODO:claude *)
887
-
val get_mailbox :
888
-
connection ->
889
-
account_id:Jmap.Types.id ->
890
-
mailbox_id:Jmap.Types.id ->
891
-
(Types.mailbox, Jmap.Api.error) result Lwt.t
892
-
893
-
(** Get messages in a mailbox
894
-
@param conn The JMAP connection
895
-
@param account_id The account ID
896
-
@param mailbox_id The mailbox ID to get messages from
897
-
@param limit Optional limit on number of messages to return
898
-
@return The list of email messages if successful
899
-
900
-
TODO:claude *)
901
-
val get_messages_in_mailbox :
902
-
connection ->
903
-
account_id:Jmap.Types.id ->
904
-
mailbox_id:Jmap.Types.id ->
905
-
?limit:int ->
906
-
unit ->
907
-
(Types.email list, Jmap.Api.error) result Lwt.t
908
-
909
-
(** Get a single email message by ID
910
-
@param conn The JMAP connection
911
-
@param account_id The account ID
912
-
@param email_id The email ID to retrieve
913
-
@return The email message if found
914
-
915
-
TODO:claude *)
916
-
val get_email :
917
-
connection ->
918
-
account_id:Jmap.Types.id ->
919
-
email_id:Jmap.Types.id ->
920
-
(Types.email, Jmap.Api.error) result Lwt.t
+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. *)
+896
spec/draft-ietf-mailmaint-messageflag-mailboxattribute-02.txt
+896
spec/draft-ietf-mailmaint-messageflag-mailboxattribute-02.txt
···
1
+
2
+
3
+
4
+
5
+
MailMaint N.M. Jenkins, Ed.
6
+
Internet-Draft Fastmail
7
+
Intended status: Informational D. Eggert, Ed.
8
+
Expires: 21 August 2025 Apple Inc
9
+
17 February 2025
10
+
11
+
12
+
Registration of further IMAP/JMAP keywords and mailbox attribute names
13
+
draft-ietf-mailmaint-messageflag-mailboxattribute-02
14
+
15
+
Abstract
16
+
17
+
This document defines a number of keywords that have been in use by
18
+
Fastmail and Apple respectively for some time. It defines their
19
+
intended use. Additionally some mailbox names with special meaning
20
+
have been in use by Fastmail, and this document defines their
21
+
intended use. This document registers all of these names with IANA
22
+
to avoid name collisions.
23
+
24
+
Status of This Memo
25
+
26
+
This Internet-Draft is submitted in full conformance with the
27
+
provisions of BCP 78 and BCP 79.
28
+
29
+
Internet-Drafts are working documents of the Internet Engineering
30
+
Task Force (IETF). Note that other groups may also distribute
31
+
working documents as Internet-Drafts. The list of current Internet-
32
+
Drafts is at https://datatracker.ietf.org/drafts/current/.
33
+
34
+
Internet-Drafts are draft documents valid for a maximum of six months
35
+
and may be updated, replaced, or obsoleted by other documents at any
36
+
time. It is inappropriate to use Internet-Drafts as reference
37
+
material or to cite them other than as "work in progress."
38
+
39
+
This Internet-Draft will expire on 21 August 2025.
40
+
41
+
Copyright Notice
42
+
43
+
Copyright (c) 2025 IETF Trust and the persons identified as the
44
+
document authors. All rights reserved.
45
+
46
+
47
+
48
+
49
+
50
+
51
+
52
+
53
+
54
+
55
+
56
+
Jenkins & Eggert Expires 21 August 2025 [Page 1]
57
+
58
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
59
+
60
+
61
+
This document is subject to BCP 78 and the IETF Trust's Legal
62
+
Provisions Relating to IETF Documents (https://trustee.ietf.org/
63
+
license-info) in effect on the date of publication of this document.
64
+
Please review these documents carefully, as they describe your rights
65
+
and restrictions with respect to this document. Code Components
66
+
extracted from this document must include Revised BSD License text as
67
+
described in Section 4.e of the Trust Legal Provisions and are
68
+
provided without warranty as described in the Revised BSD License.
69
+
70
+
Table of Contents
71
+
72
+
1. Introduction . . . . . . . . . . . . . . . . . . . . . . . . 3
73
+
2. Requirements Language . . . . . . . . . . . . . . . . . . . . 4
74
+
3. Flag Colors . . . . . . . . . . . . . . . . . . . . . . . . . 4
75
+
3.1. Definition of the MailFlagBit Message Keyword . . . . . . 4
76
+
3.2. Implementation Notes . . . . . . . . . . . . . . . . . . 5
77
+
4. IANA Considerations . . . . . . . . . . . . . . . . . . . . . 5
78
+
4.1. IMAP/JMAP Keyword Registrations . . . . . . . . . . . . . 5
79
+
4.1.1. $notify keyword registration . . . . . . . . . . . . 5
80
+
4.1.2. $muted keyword registration . . . . . . . . . . . . . 6
81
+
4.1.3. $followed keyword registration . . . . . . . . . . . 7
82
+
4.1.4. $memo keyword registration . . . . . . . . . . . . . 7
83
+
4.1.5. $hasmemo keyword registration . . . . . . . . . . . . 8
84
+
4.1.6. Attachment Detection . . . . . . . . . . . . . . . . 8
85
+
4.1.7. $autosent keyword registration . . . . . . . . . . . 9
86
+
4.1.8. $unsubscribed keyword registration . . . . . . . . . 10
87
+
4.1.9. $canunsubscribe keyword registration . . . . . . . . 10
88
+
4.1.10. $imported keyword registration . . . . . . . . . . . 11
89
+
4.1.11. $istrusted keyword registration . . . . . . . . . . . 11
90
+
4.1.12. $maskedemail keyword registration . . . . . . . . . . 12
91
+
4.1.13. $new keyword registration . . . . . . . . . . . . . . 12
92
+
4.1.14. $MailFlagBit0 keyword registration . . . . . . . . . 13
93
+
4.1.15. $MailFlagBit1 keyword registration . . . . . . . . . 13
94
+
4.1.16. $MailFlagBit2 keyword registration . . . . . . . . . 13
95
+
4.2. IMAP Mailbox Name Attributes Registrations . . . . . . . 14
96
+
4.2.1. Snoozed mailbox name attribute registration . . . . . 14
97
+
4.2.2. Scheduled mailbox name attribute registration . . . . 14
98
+
4.2.3. Memos mailbox name attribute registration . . . . . . 14
99
+
5. Security Considerations . . . . . . . . . . . . . . . . . . . 15
100
+
6. References . . . . . . . . . . . . . . . . . . . . . . . . . 15
101
+
6.1. Normative References . . . . . . . . . . . . . . . . . . 15
102
+
Authors' Addresses . . . . . . . . . . . . . . . . . . . . . . . 15
103
+
104
+
105
+
106
+
107
+
108
+
109
+
110
+
111
+
112
+
Jenkins & Eggert Expires 21 August 2025 [Page 2]
113
+
114
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
115
+
116
+
117
+
1. Introduction
118
+
119
+
The Internet Message Access Protocol (IMAP) specification [RFC9051]
120
+
defines the use of message keywords, and an "IMAP Keywords" registry
121
+
is created in [RFC5788]. Similarly [RFC8457] creates an "IMAP
122
+
Mailbox Name Attributes Registry".
123
+
124
+
This document does the following:
125
+
126
+
* Defines 16 message keywords
127
+
128
+
- $notify
129
+
130
+
- $muted
131
+
132
+
- $followed
133
+
134
+
- $memo
135
+
136
+
- $hasmemo
137
+
138
+
- $hasattachment
139
+
140
+
- $hasnoattachment
141
+
142
+
- $autosent
143
+
144
+
- $unsubscribed
145
+
146
+
- $canunsubscribe
147
+
148
+
- $imported
149
+
150
+
- $istrusted
151
+
152
+
- $maskedemail
153
+
154
+
- $new
155
+
156
+
- $MailFlagBit0
157
+
158
+
- $MailFlagBit1
159
+
160
+
- $MailFlagBit2
161
+
162
+
* Defines 3 mailbox name attributes
163
+
164
+
- Snoozed
165
+
166
+
167
+
168
+
Jenkins & Eggert Expires 21 August 2025 [Page 3]
169
+
170
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
171
+
172
+
173
+
- Scheduled
174
+
175
+
- Memos
176
+
177
+
* Registers these in the "IMAP Keywords" registry and "IMAP Mailbox
178
+
Name Attributes" registry respectively.
179
+
180
+
2. Requirements Language
181
+
182
+
The key words "MUST", "MUST NOT", "REQUIRED", "SHALL", "SHALL NOT",
183
+
"SHOULD", "SHOULD NOT", "RECOMMENDED", "NOT RECOMMENDED", "MAY", and
184
+
"OPTIONAL" in this document are to be interpreted as described in BCP
185
+
14 [RFC2119] [RFC8174] when, and only when, they appear in all
186
+
capitals, as shown here.
187
+
188
+
3. Flag Colors
189
+
190
+
The Internet Message Access Protocol (IMAP) specification [RFC9051]
191
+
defines a \Flagged system flag to mark a message for urgent/special
192
+
attention. The new keywords defined in Sections 4.1.14, 4.1.15, and
193
+
4.1.16 allow such a flagged message to have that flag be of one of 7
194
+
colors.
195
+
196
+
3.1. Definition of the MailFlagBit Message Keyword
197
+
198
+
The 3 flag color keywords $MailFlagBit0, $MailFlagBit1, and
199
+
$MailFlagBit2 make up a bit pattern that define the color of the flag
200
+
as such:
201
+
202
+
+=======+=======+=======+========+
203
+
| Bit 0 | Bit 1 | Bit 2 | Color |
204
+
+=======+=======+=======+========+
205
+
| 0 | 0 | 0 | red |
206
+
+-------+-------+-------+--------+
207
+
| 1 | 0 | 0 | orange |
208
+
+-------+-------+-------+--------+
209
+
| 0 | 1 | 0 | yellow |
210
+
+-------+-------+-------+--------+
211
+
| 1 | 1 | 1 | green |
212
+
+-------+-------+-------+--------+
213
+
| 0 | 0 | 1 | blue |
214
+
+-------+-------+-------+--------+
215
+
| 1 | 0 | 1 | purple |
216
+
+-------+-------+-------+--------+
217
+
| 0 | 1 | 1 | gray |
218
+
+-------+-------+-------+--------+
219
+
220
+
Table 1: Flag Colors
221
+
222
+
223
+
224
+
Jenkins & Eggert Expires 21 August 2025 [Page 4]
225
+
226
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
227
+
228
+
229
+
These flags SHOULD be ignored if the \Flagged system flag is not set.
230
+
If the \Flagged system flag is set, the flagged status MAY be
231
+
displayed to the user in the color corresponding to the combination
232
+
of the 3 flag color keywords.
233
+
234
+
3.2. Implementation Notes
235
+
236
+
A mail client that is aware of these flag color keywords SHOULD clear
237
+
all 3 flag color keywords when the user unflags the message, i.e.
238
+
when unsetting the \Flagged system flag, all 3 flag color keywords
239
+
SHOULD also be unset.
240
+
241
+
A mail client SHOULD NOT set any of these flags unless the \Flagged
242
+
system flag is already set or is being set.
243
+
244
+
Servers MAY unset these flag color keywords when a client unsets the
245
+
\Flagged system flag.
246
+
247
+
4. IANA Considerations
248
+
249
+
3 IMAP/JMAP keywords are registered in the IMAP/JMAP keywords
250
+
registry, as established in RFC5788.
251
+
252
+
4.1. IMAP/JMAP Keyword Registrations
253
+
254
+
4.1.1. $notify keyword registration
255
+
256
+
IMAP/JMAP keyword name: $notify
257
+
Purpose: Indicate to the client that a notification should be shown
258
+
for this message.
259
+
Private or Shared on a server: SHARED
260
+
Is it an advisory keyword or may it cause an automatic action: This
261
+
keyword can cause automatic action. On supporting clients, when a
262
+
new message is added to the mailstore with this keyword, the
263
+
client should show the user a notification.
264
+
Mail clients commonly show notifications for new mail, but often
265
+
the only option is to show a notification for every message that
266
+
arrives in the inbox. This keyword allows the user to create
267
+
rules (or the server to automatically determine) specific messages
268
+
that should show a notification.
269
+
Notifications for these messages may be in addition to
270
+
notifications for messages matching other criteria, according to
271
+
user preference set on the client.
272
+
When/by whom the keyword is set/cleared: This keyword is set by a
273
+
274
+
275
+
276
+
277
+
278
+
279
+
280
+
Jenkins & Eggert Expires 21 August 2025 [Page 5]
281
+
282
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
283
+
284
+
285
+
server on delivery when a message meets criteria such that the
286
+
user should be shown a notification. It may be cleared by a
287
+
client when the user opens, archives, or otherwise interacts with
288
+
the message. Other clients connected to the same account may
289
+
choose to automatically close the notification if the flag is
290
+
cleared.
291
+
Related keywords: None
292
+
Related IMAP capabilities: None
293
+
Security considerations: None
294
+
Published specification: This document
295
+
Intended usage: COMMON
296
+
Scope: BOTH
297
+
Owner/Change controller: IESG
298
+
299
+
4.1.2. $muted keyword registration
300
+
301
+
IMAP/JMAP keyword name: $muted
302
+
Purpose: Indicate to the server that the user is not interested in
303
+
future replies to a particular thread.
304
+
Private or Shared on a server: SHARED
305
+
Is it an advisory keyword or may it cause an automatic action: This
306
+
keyword can cause automatic action. On supporting servers, when a
307
+
new message arrives that is in the same thread as a message with
308
+
this keyword the server may automatically process it in some way
309
+
to deprioritise it for the user, for example by moving it to the
310
+
archive or trash, or marking it read. The exact action, whether
311
+
this is customisable by the user, and interaction with user rules
312
+
is vendor specific.
313
+
A message is defined to be in the same thread as another if the
314
+
server assigns them both the same thread id, as defined in
315
+
[RFC8474] Section 5.2 for IMAP or [RFC8621], Section 3 for JMAP.
316
+
When/by whom the keyword is set/cleared: This keyword is set by a
317
+
client when the user indicates they wish to mute or unmute a
318
+
thread. When unmuting a thread, the client must remove the
319
+
keyword from every message in the thread that has it.
320
+
Related keywords: Mutually exclusive with $followed. If both are
321
+
specified on a thread, servers MUST behave as though only
322
+
$followed were set.
323
+
Related IMAP capabilities: None
324
+
Security considerations: Muting a thread can mean a user won't see a
325
+
reply. If someone compromises a user's account, they may mute
326
+
threads where they don't want the user to see the reply, for
327
+
example when sending phishing to the user's contacts. There are
328
+
many other ways an attacker with access to the user's mailbox can
329
+
also achieve this however, so this is not greatly increasing the
330
+
attack surface.
331
+
Published specification: This document
332
+
Intended usage: COMMON
333
+
334
+
335
+
336
+
Jenkins & Eggert Expires 21 August 2025 [Page 6]
337
+
338
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
339
+
340
+
341
+
Scope: BOTH
342
+
Owner/Change controller: IESG
343
+
344
+
4.1.3. $followed keyword registration
345
+
346
+
IMAP/JMAP keyword name: $followed
347
+
Purpose: Indicate to the server that the user is particularly
348
+
interested in future replies to a particular thread.
349
+
Private or Shared on a server: SHARED
350
+
Is it an advisory keyword or may it cause an automatic action: This
351
+
keyword can cause automatic action. On supporting servers, when a
352
+
new message arrives that is in the same thread as a message with
353
+
this keyword the server may automatically process it in some way
354
+
to prioritise it for the user, for example by ignoring rules that
355
+
would make it skip the inbox, or automatically adding the $notify
356
+
keyword. The exact action, whether this is customisable by the
357
+
user, and interaction with user rules is vendor specific.
358
+
A message is defined to be in the same thread as another if the
359
+
server assigns them both the same thread id, as defined in
360
+
[RFC8474] Section 5.2 for IMAP or [RFC8621], Section 3 for JMAP.
361
+
When/by whom the keyword is set/cleared: This keyword is set by a
362
+
client when the user indicates they wish to follow or unfollow a
363
+
thread. When unfollowing a thread, the client must remove the
364
+
keyword from every message in the thread that has it.
365
+
Related keywords: Mutually exclusive with $muted. If both are
366
+
specified on a thread, servers MUST behave as though only
367
+
$followed were set.
368
+
Related IMAP capabilities: None
369
+
Security considerations: None
370
+
Published specification: This document
371
+
Intended usage: COMMON
372
+
Scope: BOTH
373
+
Owner/Change controller: IESG
374
+
375
+
4.1.4. $memo keyword registration
376
+
377
+
IMAP/JMAP keyword name: $memo
378
+
Purpose: Indicate to the client that a message is a note-to-self
379
+
from the user regarding another message in the same thread.
380
+
Private or Shared on a server: SHARED
381
+
Is it an advisory keyword or may it cause an automatic action: This
382
+
keyword is advisory.
383
+
When/by whom the keyword is set/cleared: This keyword is set by a
384
+
client when creating such a message. The message should otherwise
385
+
be contructed like a reply to the message to which this memo is
386
+
attached (i.e. appropriate Subject and Reply-To headers set). In
387
+
supporting clients, messages with this flag may be presented
388
+
differently to the user, attached to the message the memo is
389
+
390
+
391
+
392
+
Jenkins & Eggert Expires 21 August 2025 [Page 7]
393
+
394
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
395
+
396
+
397
+
commenting on, and may offer the user the ability to edit or
398
+
delete the memo. (As messages are immutable, editing requires
399
+
replacing the message.)
400
+
Related keywords: The $hasmemo keyword should be set/cleared at the
401
+
same time.
402
+
Related IMAP capabilities: None
403
+
Security considerations: None
404
+
Published specification: This document
405
+
Intended usage: COMMON
406
+
Scope: BOTH
407
+
Owner/Change controller: IESG
408
+
409
+
4.1.5. $hasmemo keyword registration
410
+
411
+
IMAP/JMAP keyword name: $hasmemo
412
+
Purpose: Indicate to the client that a message has an associated
413
+
memo with the $memo keyword.
414
+
Private or Shared on a server: SHARED
415
+
Is it an advisory keyword or may it cause an automatic action: This
416
+
keyword is advisory.
417
+
When/by whom the keyword is set/cleared: This keyword is set by a
418
+
client when creating a memo. The memo gets the $memo keyword, the
419
+
message it is a note for gets the $hasmemo keyword. This keyword
420
+
can help in searching for messages with memos, or deciding whether
421
+
to fetch the whole thread to look for memos when loading a
422
+
mailbox.
423
+
Related keywords: A message with the $memo keyword should be
424
+
created/destroyed at the same time.
425
+
Related IMAP capabilities: None
426
+
Security considerations: None
427
+
Published specification: This document
428
+
Intended usage: COMMON
429
+
Scope: BOTH
430
+
Owner/Change controller: IESG
431
+
432
+
4.1.6. Attachment Detection
433
+
434
+
The $hasattachment and $hasnoattachment are mutually exclusive. A
435
+
message SHOULD NOT contain both keywords.
436
+
437
+
4.1.6.1. $hasattachment keyword registration
438
+
439
+
IMAP/JMAP keyword name: $hasattachment
440
+
Purpose: Indicate to the client that a message has an attachment.
441
+
Private or Shared on a server: SHARED
442
+
Is it an advisory keyword or may it cause an automatic action: This
443
+
keyword is advisory.
444
+
When/by whom the keyword is set/cleared: This keyword is set by a
445
+
446
+
447
+
448
+
Jenkins & Eggert Expires 21 August 2025 [Page 8]
449
+
450
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
451
+
452
+
453
+
server on messages it determines have an attachment. This can
454
+
help mailbox clients indicate this to the user without having to
455
+
fetch the full message body structure. Over JMAP, the
456
+
"hasAttachment" Email property should indicate the same value.
457
+
Related keywords: $hasnoattachment
458
+
Related IMAP capabilities: None
459
+
Security considerations: None
460
+
Published specification: This document
461
+
Intended usage: COMMON
462
+
Scope: BOTH
463
+
Owner/Change controller: IESG
464
+
465
+
4.1.6.2. $hasnoattachment keyword registration
466
+
467
+
IMAP/JMAP keyword name: $hasnoattachment
468
+
Purpose: Indicate to the client that a message does not have an
469
+
attachment.
470
+
Private or Shared on a server: SHARED
471
+
Is it an advisory keyword or may it cause an automatic action: This
472
+
keyword is advisory.
473
+
When/by whom the keyword is set/cleared: This keyword is set by a
474
+
server on messages it determines does NOT have an attachment.
475
+
Over JMAP, the "hasNoAttachment" Email property should indicate
476
+
the same value. This keyword is needed in addition to the
477
+
$hasattachment keyword, as a client cannot otherwise determine
478
+
whether the server has processed the message for the presence of
479
+
an attachment. In other words, the absence of the $hasattachment
480
+
keyword for a message does not tell a client whether the message
481
+
actually contains an attachment, as the client has no information
482
+
on whether the server has processed the message.
483
+
Related keywords: None
484
+
Related IMAP capabilities: None
485
+
Security considerations: None
486
+
Published specification: This document
487
+
Intended usage: COMMON
488
+
Scope: BOTH
489
+
Owner/Change controller: IESG
490
+
491
+
4.1.7. $autosent keyword registration
492
+
493
+
IMAP/JMAP keyword name: $autosent
494
+
Purpose: Indicate to the client that a message was sent
495
+
automatically as a response due to a user rule or setting.
496
+
Private or Shared on a server: SHARED
497
+
Is it an advisory keyword or may it cause an automatic action: This
498
+
keyword is advisory.
499
+
When/by whom the keyword is set/cleared: This keyword is set by a
500
+
501
+
502
+
503
+
504
+
Jenkins & Eggert Expires 21 August 2025 [Page 9]
505
+
506
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
507
+
508
+
509
+
server on the user's copy of their vacation response and other
510
+
automated messages sent on behalf of the user. Clients may use
511
+
this to indicate to the user that this message was sent
512
+
automatically, as if they have forgotten the rule or vacation
513
+
response is set up they may be surprised to see it among their
514
+
sent items.
515
+
Related keywords: None
516
+
Related IMAP capabilities: None
517
+
Security considerations: None
518
+
Published specification: This document
519
+
Intended usage: COMMON
520
+
Scope: BOTH
521
+
Owner/Change controller: IESG
522
+
523
+
4.1.8. $unsubscribed keyword registration
524
+
525
+
IMAP/JMAP keyword name: $unsubscribed
526
+
Purpose: Indicate to the client that it has unsubscribed from the
527
+
thread this message is on.
528
+
Private or Shared on a server: SHARED
529
+
Is it an advisory keyword or may it cause an automatic action: This
530
+
keyword is advisory.
531
+
When/by whom the keyword is set/cleared: This keyword is set by a
532
+
client on a message after attempting to unsubscribe from the
533
+
mailing list this message came from (e.g., after attempting
534
+
RFC8058 one-click List-Unsubscribe). It allows clients to remind
535
+
the user that they have unsubscribed if they open the message
536
+
again.
537
+
Related keywords: None
538
+
Related IMAP capabilities: None
539
+
Security considerations: None
540
+
Published specification: This document
541
+
Intended usage: COMMON
542
+
Scope: BOTH
543
+
Owner/Change controller: IESG
544
+
545
+
4.1.9. $canunsubscribe keyword registration
546
+
547
+
IMAP/JMAP keyword name: $canunsubscribe
548
+
Purpose: Indicate to the client that this message has an
549
+
RFC8058-compliant List-Unsubscribe header.
550
+
Private or Shared on a server: SHARED
551
+
Is it an advisory keyword or may it cause an automatic action: This
552
+
keyword is advisory.
553
+
When/by whom the keyword is set/cleared: This keyword is set by a
554
+
555
+
556
+
557
+
558
+
559
+
560
+
Jenkins & Eggert Expires 21 August 2025 [Page 10]
561
+
562
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
563
+
564
+
565
+
server on messages with an RFC8058-compliant List-Unsubscribe
566
+
header. It may only do so if the message passes vendor-specific
567
+
reputation checks. It is intended to indicate to clients that
568
+
they may be able to do a one-click unsubscribe, without them
569
+
having to fetch the List-Unsubscribe header to determine themself.
570
+
Related keywords: None
571
+
Related IMAP capabilities: None
572
+
Security considerations: None
573
+
Published specification: This document
574
+
Intended usage: COMMON
575
+
Scope: BOTH
576
+
Owner/Change controller: IESG
577
+
578
+
4.1.10. $imported keyword registration
579
+
580
+
IMAP/JMAP keyword name: $imported
581
+
Purpose: Indicate to the client that this message was imported from
582
+
another mailbox.
583
+
Private or Shared on a server: SHARED
584
+
Is it an advisory keyword or may it cause an automatic action: This
585
+
keyword is advisory.
586
+
When/by whom the keyword is set/cleared: This keyword is set by a
587
+
server on messages in imports from another mailbox.
588
+
Related keywords: None
589
+
Related IMAP capabilities: None
590
+
Security considerations: None
591
+
Published specification: This document
592
+
Intended usage: COMMON
593
+
Scope: BOTH
594
+
Owner/Change controller: IESG
595
+
596
+
4.1.11. $istrusted keyword registration
597
+
598
+
IMAP/JMAP keyword name: $istrusted
599
+
Purpose: Indicate to the client that the authenticity of the from
600
+
name and email address have been verified with complete confidence
601
+
by the server.
602
+
Private or Shared on a server: SHARED
603
+
Is it an advisory keyword or may it cause an automatic action: This
604
+
keyword is advisory. Clients may show a verification mark (often
605
+
a tick icon) on messages with this keyword to indicate their
606
+
trusted status to the user.
607
+
When/by whom the keyword is set/cleared: This keyword is set by a
608
+
server on messages it delivers where it wishes to confirm to the
609
+
user that this is a legitimate email they can trust. It is
610
+
usually only used for the mailbox provider's own messages to the
611
+
customer, where they can know with absolute certainty that the
612
+
friendly from name and email address are legitimate.
613
+
614
+
615
+
616
+
Jenkins & Eggert Expires 21 August 2025 [Page 11]
617
+
618
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
619
+
620
+
621
+
Related keywords: None
622
+
Related IMAP capabilities: None
623
+
Security considerations: Servers should make sure this keyword is
624
+
only set for messages that really are trusted!
625
+
Published specification: This document
626
+
Intended usage: COMMON
627
+
Scope: BOTH
628
+
Owner/Change controller: IESG
629
+
630
+
4.1.12. $maskedemail keyword registration
631
+
632
+
IMAP/JMAP keyword name: $maskedemail
633
+
Purpose: Indicate to the client that the message was received via an
634
+
alias created for an individual sender.
635
+
Private or Shared on a server: SHARED
636
+
Is it an advisory keyword or may it cause an automatic action: This
637
+
keyword is advisory. Clients may show an icon to indicate to the
638
+
user this was received via a masked email address - an alias
639
+
created for a specific sender to hide the user's real email
640
+
address.
641
+
When/by whom the keyword is set/cleared: This keyword is set by a
642
+
server on messages it delivers that arrived via such an alias.
643
+
Related keywords: None
644
+
Related IMAP capabilities: None
645
+
Security considerations: None
646
+
Published specification: This document
647
+
Intended usage: LIMITED
648
+
Scope: BOTH
649
+
Owner/Change controller: IESG
650
+
651
+
4.1.13. $new keyword registration
652
+
653
+
IMAP/JMAP keyword name: $new
654
+
Purpose: Indicate to the client that a message should be made more
655
+
prominent to the user due to a recent action.
656
+
Private or Shared on a server: SHARED
657
+
Is it an advisory keyword or may it cause an automatic action: This
658
+
keyword is advisory. Clients may show the status of the message.
659
+
When/by whom the keyword is set/cleared: This keyword is set by a
660
+
server on messages after awakening them from snooze. Clients
661
+
should clear the keyword when the message is opened.
662
+
Related keywords: None
663
+
Related IMAP capabilities: None
664
+
Security considerations: None
665
+
Published specification: This document
666
+
Intended usage: LIMITED
667
+
Scope: BOTH
668
+
Owner/Change controller: IESG
669
+
670
+
671
+
672
+
Jenkins & Eggert Expires 21 August 2025 [Page 12]
673
+
674
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
675
+
676
+
677
+
4.1.14. $MailFlagBit0 keyword registration
678
+
679
+
IMAP/JMAP keyword name: $MailFlagBit0
680
+
Purpose: 0 bit part of a 3-bit bitmask that defines the color of the
681
+
flag when the has the system flag \Flagged set. See Section 3 for
682
+
details.
683
+
Private or Shared on a server: SHARED
684
+
Is it an advisory keyword or may it cause an automatic action: No
685
+
When/by whom the keyword is set/cleared: This keyword is set by a
686
+
client as the result of a user action to "flag" a message for
687
+
urgent/special attention.
688
+
Related keywords: $MailFlagBit1, $MailFlagBit2
689
+
Related IMAP capabilities: None
690
+
Security considerations: None
691
+
Published specification: This document
692
+
Intended usage: COMMON
693
+
Owner/Change controller: IESG
694
+
695
+
4.1.15. $MailFlagBit1 keyword registration
696
+
697
+
IMAP/JMAP keyword name: $MailFlagBit1
698
+
Purpose: 0 bit part of a 3-bit bitmask that defines the color of the
699
+
flag when the has the system flag \Flagged set. See Section 3 for
700
+
details.
701
+
Private or Shared on a server: SHARED
702
+
Is it an advisory keyword or may it cause an automatic action: No
703
+
When/by whom the keyword is set/cleared: This keyword is set by a
704
+
client as the result of a user action to "flag" a message for
705
+
urgent/special attention.
706
+
Related keywords: $MailFlagBit0, $MailFlagBit2
707
+
Related IMAP capabilities: None
708
+
Security considerations: None
709
+
Published specification: This document
710
+
Intended usage: COMMON
711
+
Owner/Change controller: IESG
712
+
713
+
4.1.16. $MailFlagBit2 keyword registration
714
+
715
+
IMAP/JMAP keyword name: $MailFlagBit2
716
+
Purpose: 0 bit part of a 3-bit bitmask that defines the color of the
717
+
flag when the has the system flag \Flagged set. See Section 3 for
718
+
details.
719
+
Private or Shared on a server: SHARED
720
+
Is it an advisory keyword or may it cause an automatic action: No
721
+
When/by whom the keyword is set/cleared: This keyword is set by a
722
+
client as the result of a user action to "flag" a message for
723
+
urgent/special attention.
724
+
Related keywords: $MailFlagBit0, $MailFlagBit1
725
+
726
+
727
+
728
+
Jenkins & Eggert Expires 21 August 2025 [Page 13]
729
+
730
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
731
+
732
+
733
+
Related IMAP capabilities: None
734
+
Security considerations: None
735
+
Published specification: This document
736
+
Intended usage: COMMON
737
+
Owner/Change controller: IESG
738
+
739
+
4.2. IMAP Mailbox Name Attributes Registrations
740
+
741
+
This section lists mailbox name attributes to be registered with the
742
+
"IMAP Mailbox Name Attributes" created with [RFC8457].
743
+
744
+
Note that none of the attribute names in this seciton have an implied
745
+
backslash. This sets them apart from those specified in Section 2 of
746
+
[RFC6154].
747
+
748
+
4.2.1. Snoozed mailbox name attribute registration
749
+
750
+
Attribute Name: Snoozed
751
+
Description: Messages that have been snoozed are moved to this
752
+
mailbox until the "awaken" time, when they are moved out of it
753
+
again automatically by the server.
754
+
Reference: This document.
755
+
Usage Notes: Snooze functionality is common among services but not
756
+
yet standardised. This attribute marks the mailbox where snoozed
757
+
messages may be found, but does not on its own provide a way for
758
+
clients to snooze messages.
759
+
760
+
4.2.2. Scheduled mailbox name attribute registration
761
+
762
+
Attribute Name: Scheduled
763
+
Description: Messages that have been scheduled to send at a later
764
+
time. Once the server has sent them at the scheduled time, they
765
+
will automatically be deleted or moved from this mailbox by the
766
+
server (probably to the \Sent mailbox).
767
+
Reference: This document.
768
+
Usage Notes: Scheduled sending functionality is common among
769
+
services but not yet standardised. This attribute marks the
770
+
mailbox where scheduled messages may be found, but does not on its
771
+
own provide a way for clients to schedule messages for sending.
772
+
773
+
4.2.3. Memos mailbox name attribute registration
774
+
775
+
Attribute Name: Memos
776
+
Description: Messages that have the $memo keyword. Clients creating
777
+
memos are recommended to store them in this mailbox. This allows
778
+
them to more easily be hidden from the user as "messages", and
779
+
presented only as memos instead.
780
+
Reference: This document.
781
+
782
+
783
+
784
+
Jenkins & Eggert Expires 21 August 2025 [Page 14]
785
+
786
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
787
+
788
+
789
+
Usage Notes: None.
790
+
791
+
5. Security Considerations
792
+
793
+
This document should not affect the security of the Internet.
794
+
795
+
6. References
796
+
797
+
6.1. Normative References
798
+
799
+
[RFC2119] Bradner, S., "Key words for use in RFCs to Indicate
800
+
Requirement Levels", BCP 14, RFC 2119,
801
+
DOI 10.17487/RFC2119, March 1997,
802
+
<https://www.rfc-editor.org/info/rfc2119>.
803
+
804
+
[RFC6154] Leiba, B. and J. Nicolson, "IMAP LIST Extension for
805
+
Special-Use Mailboxes", RFC 6154, DOI 10.17487/RFC6154,
806
+
March 2011, <https://www.rfc-editor.org/info/rfc6154>.
807
+
808
+
[RFC8174] Leiba, B., "Ambiguity of Uppercase vs Lowercase in RFC
809
+
2119 Key Words", BCP 14, RFC 8174, DOI 10.17487/RFC8174,
810
+
May 2017, <https://www.rfc-editor.org/info/rfc8174>.
811
+
812
+
[RFC8457] Leiba, B., Ed., "IMAP "$Important" Keyword and
813
+
"\Important" Special-Use Attribute", RFC 8457,
814
+
DOI 10.17487/RFC8457, September 2018,
815
+
<https://www.rfc-editor.org/info/rfc8457>.
816
+
817
+
[RFC8474] Gondwana, B., Ed., "IMAP Extension for Object
818
+
Identifiers", RFC 8474, DOI 10.17487/RFC8474, September
819
+
2018, <https://www.rfc-editor.org/info/rfc8474>.
820
+
821
+
[RFC8621] Jenkins, N. and C. Newman, "The JSON Meta Application
822
+
Protocol (JMAP) for Mail", RFC 8621, DOI 10.17487/RFC8621,
823
+
August 2019, <https://www.rfc-editor.org/info/rfc8621>.
824
+
825
+
[RFC9051] Melnikov, A., Ed. and B. Leiba, Ed., "Internet Message
826
+
Access Protocol (IMAP) - Version 4rev2", RFC 9051,
827
+
DOI 10.17487/RFC9051, August 2021,
828
+
<https://www.rfc-editor.org/info/rfc9051>.
829
+
830
+
[RFC5788] Melnikov, A. and D. Cridland, "IMAP4 Keyword Registry",
831
+
RFC 5788, DOI 10.17487/RFC5788, March 2010,
832
+
<https://www.rfc-editor.org/info/rfc5788>.
833
+
834
+
Authors' Addresses
835
+
836
+
837
+
838
+
839
+
840
+
Jenkins & Eggert Expires 21 August 2025 [Page 15]
841
+
842
+
Internet-Draft Further IMAP/JMAP keywords & attributes February 2025
843
+
844
+
845
+
Neil Jenkins (editor)
846
+
Fastmail
847
+
PO Box 234, Collins St West
848
+
Melbourne VIC 8007
849
+
Australia
850
+
Email: neilj@fastmailteam.com
851
+
URI: https://www.fastmail.com
852
+
853
+
854
+
Daniel Eggert (editor)
855
+
Apple Inc
856
+
One Apple Park Way
857
+
Cupertino, CA 95014
858
+
United States of America
859
+
Email: deggert@apple.com
860
+
URI: https://www.apple.com
861
+
862
+
863
+
864
+
865
+
866
+
867
+
868
+
869
+
870
+
871
+
872
+
873
+
874
+
875
+
876
+
877
+
878
+
879
+
880
+
881
+
882
+
883
+
884
+
885
+
886
+
887
+
888
+
889
+
890
+
891
+
892
+
893
+
894
+
895
+
896
+
Jenkins & Eggert Expires 21 August 2025 [Page 16]
+10
test/proto/capability/valid/core.json
+10
test/proto/capability/valid/core.json
+6
test/proto/capability/valid/mail.json
+6
test/proto/capability/valid/mail.json
+7
test/proto/capability/valid/submission.json
+7
test/proto/capability/valid/submission.json
+1
test/proto/date/edge/microseconds.json
+1
test/proto/date/edge/microseconds.json
···
1
+
2024-01-15T10:30:00.123456Z
+1
test/proto/date/edge/negative_offset.json
+1
test/proto/date/edge/negative_offset.json
···
1
+
2024-01-15T10:30:00-08:00
+1
test/proto/date/invalid/bad_format.json
+1
test/proto/date/invalid/bad_format.json
···
1
+
January 15, 2024
+1
test/proto/date/invalid/invalid_date.json
+1
test/proto/date/invalid/invalid_date.json
···
1
+
2024-02-30T10:30:00Z
+1
test/proto/date/invalid/lowercase_t.json
+1
test/proto/date/invalid/lowercase_t.json
···
1
+
2024-01-15t10:30:00Z
+1
test/proto/date/invalid/lowercase_z.json
+1
test/proto/date/invalid/lowercase_z.json
···
1
+
2024-01-15T10:30:00z
+1
test/proto/date/invalid/missing_seconds.json
+1
test/proto/date/invalid/missing_seconds.json
···
1
+
2024-01-15T10:30Z
+1
test/proto/date/invalid/no_timezone.json
+1
test/proto/date/invalid/no_timezone.json
···
1
+
2024-01-15T10:30:00
+1
test/proto/date/invalid/not_string.json
+1
test/proto/date/invalid/not_string.json
···
1
+
1705315800
+1
test/proto/date/valid/negative_offset.json
+1
test/proto/date/valid/negative_offset.json
···
1
+
2024-01-15T10:30:00-08:00
+1
test/proto/date/valid/utc_z.json
+1
test/proto/date/valid/utc_z.json
···
1
+
2024-01-15T10:30:00Z
+1
test/proto/date/valid/with_milliseconds.json
+1
test/proto/date/valid/with_milliseconds.json
···
1
+
2024-01-15T10:30:00.123Z
+1
test/proto/date/valid/with_offset.json
+1
test/proto/date/valid/with_offset.json
···
1
+
2024-01-15T10:30:00+05:30
+17
test/proto/dune
+17
test/proto/dune
···
1
+
(test
2
+
(name test_proto)
3
+
(package jmap)
4
+
(libraries jmap alcotest jsont.bytesrw)
5
+
(deps
6
+
(source_tree id)
7
+
(source_tree int53)
8
+
(source_tree date)
9
+
(source_tree session)
10
+
(source_tree request)
11
+
(source_tree response)
12
+
(source_tree invocation)
13
+
(source_tree capability)
14
+
(source_tree filter)
15
+
(source_tree method)
16
+
(source_tree error)
17
+
(source_tree mail)))
+4
test/proto/error/valid/method_error.json
+4
test/proto/error/valid/method_error.json
+4
test/proto/error/valid/method_error_account_not_found.json
+4
test/proto/error/valid/method_error_account_not_found.json
+4
test/proto/error/valid/method_error_account_read_only.json
+4
test/proto/error/valid/method_error_account_read_only.json
+4
test/proto/error/valid/method_error_forbidden.json
+4
test/proto/error/valid/method_error_forbidden.json
+4
test/proto/error/valid/method_error_invalid_arguments.json
+4
test/proto/error/valid/method_error_invalid_arguments.json
+4
test/proto/error/valid/method_error_server_fail.json
+4
test/proto/error/valid/method_error_server_fail.json
+5
test/proto/error/valid/request_error.json
+5
test/proto/error/valid/request_error.json
+6
test/proto/error/valid/request_error_limit.json
+6
test/proto/error/valid/request_error_limit.json
+5
test/proto/error/valid/request_error_not_json.json
+5
test/proto/error/valid/request_error_not_json.json
+5
test/proto/error/valid/set_error.json
+5
test/proto/error/valid/set_error.json
+4
test/proto/error/valid/set_error_forbidden.json
+4
test/proto/error/valid/set_error_forbidden.json
+5
test/proto/error/valid/set_error_invalid_properties.json
+5
test/proto/error/valid/set_error_invalid_properties.json
+4
test/proto/error/valid/set_error_not_found.json
+4
test/proto/error/valid/set_error_not_found.json
+4
test/proto/error/valid/set_error_over_quota.json
+4
test/proto/error/valid/set_error_over_quota.json
+4
test/proto/error/valid/set_error_singleton.json
+4
test/proto/error/valid/set_error_singleton.json
+4
test/proto/filter/edge/empty_conditions.json
+4
test/proto/filter/edge/empty_conditions.json
+7
test/proto/filter/valid/and_operator.json
+7
test/proto/filter/valid/and_operator.json
+4
test/proto/filter/valid/comparator_descending.json
+4
test/proto/filter/valid/comparator_descending.json
+5
test/proto/filter/valid/comparator_with_collation.json
+5
test/proto/filter/valid/comparator_with_collation.json
+18
test/proto/filter/valid/deeply_nested.json
+18
test/proto/filter/valid/deeply_nested.json
+19
test/proto/filter/valid/nested.json
+19
test/proto/filter/valid/nested.json
···
1
+
{
2
+
"operator": "AND",
3
+
"conditions": [
4
+
{"inMailbox": "inbox"},
5
+
{
6
+
"operator": "OR",
7
+
"conditions": [
8
+
{"from": "boss@company.com"},
9
+
{"hasKeyword": "$important"}
10
+
]
11
+
},
12
+
{
13
+
"operator": "NOT",
14
+
"conditions": [
15
+
{"hasKeyword": "$seen"}
16
+
]
17
+
}
18
+
]
19
+
}
+13
test/proto/filter/valid/nested_and_or.json
+13
test/proto/filter/valid/nested_and_or.json
+6
test/proto/filter/valid/not_operator.json
+6
test/proto/filter/valid/not_operator.json
+7
test/proto/filter/valid/or_operator.json
+7
test/proto/filter/valid/or_operator.json
+1
test/proto/id/edge/creation_ref.json
+1
test/proto/id/edge/creation_ref.json
···
1
+
#newEmail1
+1
test/proto/id/edge/digits_only.json
+1
test/proto/id/edge/digits_only.json
···
1
+
123456789
+1
test/proto/id/edge/max_length_255.json
+1
test/proto/id/edge/max_length_255.json
···
1
+
aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
+1
test/proto/id/edge/nil_literal.json
+1
test/proto/id/edge/nil_literal.json
···
1
+
NIL
+1
test/proto/id/edge/over_max_length_256.json
+1
test/proto/id/edge/over_max_length_256.json
···
1
+
aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
+1
test/proto/id/edge/starts_with_dash.json
+1
test/proto/id/edge/starts_with_dash.json
···
1
+
-abc123
+1
test/proto/id/edge/starts_with_digit.json
+1
test/proto/id/edge/starts_with_digit.json
···
1
+
1abc
test/proto/id/invalid/empty.json
test/proto/id/invalid/empty.json
This is a binary file and will not be displayed.
+1
test/proto/id/invalid/not_string.json
+1
test/proto/id/invalid/not_string.json
···
1
+
12345
+1
test/proto/id/invalid/null.json
+1
test/proto/id/invalid/null.json
···
1
+
null
+1
test/proto/id/invalid/with_slash.json
+1
test/proto/id/invalid/with_slash.json
···
1
+
abc/def
+1
test/proto/id/invalid/with_space.json
+1
test/proto/id/invalid/with_space.json
···
1
+
hello world
+1
test/proto/id/invalid/with_special.json
+1
test/proto/id/invalid/with_special.json
···
1
+
abc@def
+1
test/proto/id/valid/alphanumeric.json
+1
test/proto/id/valid/alphanumeric.json
···
1
+
ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789
+1
test/proto/id/valid/base64_like.json
+1
test/proto/id/valid/base64_like.json
···
1
+
dXNlcl8xMjM0NTY3ODkw
+1
test/proto/id/valid/simple.json
+1
test/proto/id/valid/simple.json
···
1
+
abc123
+1
test/proto/id/valid/single_char.json
+1
test/proto/id/valid/single_char.json
···
1
+
a
+1
test/proto/id/valid/uuid_style.json
+1
test/proto/id/valid/uuid_style.json
···
1
+
550e8400-e29b-41d4-a716-446655440000
+1
test/proto/id/valid/with_hyphen.json
+1
test/proto/id/valid/with_hyphen.json
···
1
+
msg-2024-01-15-abcdef
+1
test/proto/id/valid/with_underscore.json
+1
test/proto/id/valid/with_underscore.json
···
1
+
user_123_abc
+1
test/proto/int53/edge/over_max_safe.json
+1
test/proto/int53/edge/over_max_safe.json
···
1
+
9007199254740992
+1
test/proto/int53/edge/under_min_safe.json
+1
test/proto/int53/edge/under_min_safe.json
···
1
+
-9007199254740992
+1
test/proto/int53/invalid/float.json
+1
test/proto/int53/invalid/float.json
···
1
+
123.456
+1
test/proto/int53/invalid/leading_zero.json
+1
test/proto/int53/invalid/leading_zero.json
···
1
+
0123
+1
test/proto/int53/invalid/null.json
+1
test/proto/int53/invalid/null.json
···
1
+
null
+1
test/proto/int53/invalid/scientific.json
+1
test/proto/int53/invalid/scientific.json
···
1
+
1e5
+1
test/proto/int53/invalid/string.json
+1
test/proto/int53/invalid/string.json
···
1
+
12345
+1
test/proto/int53/valid/max_safe.json
+1
test/proto/int53/valid/max_safe.json
···
1
+
9007199254740991
+1
test/proto/int53/valid/min_safe.json
+1
test/proto/int53/valid/min_safe.json
···
1
+
-9007199254740991
+1
test/proto/int53/valid/negative.json
+1
test/proto/int53/valid/negative.json
···
1
+
-12345
+1
test/proto/int53/valid/positive.json
+1
test/proto/int53/valid/positive.json
···
1
+
12345
+1
test/proto/int53/valid/zero.json
+1
test/proto/int53/valid/zero.json
···
1
+
0
+1
test/proto/invocation/invalid/not_array.json
+1
test/proto/invocation/invalid/not_array.json
···
1
+
{"method": "Email/get", "args": {}, "callId": "c1"}
+1
test/proto/invocation/invalid/wrong_length.json
+1
test/proto/invocation/invalid/wrong_length.json
···
1
+
["Email/get", {"accountId": "acc1"}]
+1
test/proto/invocation/valid/get.json
+1
test/proto/invocation/valid/get.json
···
1
+
["Email/get", {"accountId": "acc1", "ids": ["e1", "e2"]}, "call-001"]
+1
test/proto/invocation/valid/query.json
+1
test/proto/invocation/valid/query.json
···
1
+
["Email/query", {"accountId": "acc1", "filter": {"inMailbox": "inbox"}, "sort": [{"property": "receivedAt", "isAscending": false}], "limit": 50}, "call-003"]
+1
test/proto/invocation/valid/set.json
+1
test/proto/invocation/valid/set.json
···
1
+
["Mailbox/set", {"accountId": "acc1", "create": {"temp1": {"name": "Drafts"}}}, "call-002"]
+11
test/proto/mail/email/edge/empty_keywords.json
+11
test/proto/mail/email/edge/empty_keywords.json
+14
test/proto/mail/email/valid/draft_email.json
+14
test/proto/mail/email/valid/draft_email.json
···
1
+
{
2
+
"id": "e3",
3
+
"blobId": "blob3",
4
+
"threadId": "t3",
5
+
"size": 512,
6
+
"receivedAt": "2024-01-17T14:00:00Z",
7
+
"mailboxIds": {"drafts": true},
8
+
"keywords": {"$draft": true},
9
+
"from": [{"name": "Me", "email": "me@example.com"}],
10
+
"to": [{"name": "You", "email": "you@example.com"}],
11
+
"subject": "Draft: Meeting notes",
12
+
"hasAttachment": false,
13
+
"preview": "This is a draft email"
14
+
}
+30
test/proto/mail/email/valid/full.json
+30
test/proto/mail/email/valid/full.json
···
1
+
{
2
+
"id": "e2",
3
+
"blobId": "blob2",
4
+
"threadId": "t2",
5
+
"mailboxIds": {"inbox": true, "important": true},
6
+
"keywords": {"$seen": true, "$flagged": true, "$answered": true},
7
+
"size": 5000,
8
+
"receivedAt": "2024-01-15T14:30:00Z",
9
+
"messageId": ["msg123@example.com"],
10
+
"inReplyTo": ["msg100@example.com"],
11
+
"references": ["msg100@example.com", "msg99@example.com"],
12
+
"sender": [{"name": "Alice Smith", "email": "alice@example.com"}],
13
+
"from": [{"name": "Alice Smith", "email": "alice@example.com"}],
14
+
"to": [{"name": "Bob Jones", "email": "bob@example.com"}],
15
+
"cc": [{"name": "Carol White", "email": "carol@example.com"}],
16
+
"bcc": [],
17
+
"replyTo": [{"email": "alice-reply@example.com"}],
18
+
"subject": "Re: Important meeting",
19
+
"sentAt": "2024-01-15T14:29:00Z",
20
+
"hasAttachment": true,
21
+
"preview": "Thanks for the update. I'll review the documents and get back to you by...",
22
+
"bodyValues": {
23
+
"1": {"value": "Thanks for the update.\n\nI'll review the documents.", "isEncodingProblem": false, "isTruncated": false}
24
+
},
25
+
"textBody": [{"partId": "1", "type": "text/plain"}],
26
+
"htmlBody": [],
27
+
"attachments": [
28
+
{"partId": "2", "blobId": "attach1", "type": "application/pdf", "name": "document.pdf", "size": 12345}
29
+
]
30
+
}
+9
test/proto/mail/email/valid/minimal.json
+9
test/proto/mail/email/valid/minimal.json
+15
test/proto/mail/email/valid/multiple_mailboxes.json
+15
test/proto/mail/email/valid/multiple_mailboxes.json
···
1
+
{
2
+
"id": "e2",
3
+
"blobId": "blob2",
4
+
"threadId": "t2",
5
+
"size": 4096,
6
+
"receivedAt": "2024-01-16T08:00:00Z",
7
+
"mailboxIds": {
8
+
"inbox": true,
9
+
"important": true,
10
+
"work": true
11
+
},
12
+
"keywords": {"$seen": true},
13
+
"hasAttachment": false,
14
+
"preview": "Email in multiple mailboxes"
15
+
}
+18
test/proto/mail/email/valid/with_all_system_keywords.json
+18
test/proto/mail/email/valid/with_all_system_keywords.json
···
1
+
{
2
+
"id": "e4",
3
+
"blobId": "blob4",
4
+
"threadId": "t4",
5
+
"size": 8192,
6
+
"receivedAt": "2024-01-18T09:00:00Z",
7
+
"mailboxIds": {"mb1": true},
8
+
"keywords": {
9
+
"$draft": true,
10
+
"$seen": true,
11
+
"$flagged": true,
12
+
"$answered": true,
13
+
"$forwarded": true,
14
+
"custom-keyword": true
15
+
},
16
+
"hasAttachment": false,
17
+
"preview": "Email with all system keywords"
18
+
}
+16
test/proto/mail/email/valid/with_headers.json
+16
test/proto/mail/email/valid/with_headers.json
···
1
+
{
2
+
"id": "e3",
3
+
"blobId": "blob3",
4
+
"threadId": "t3",
5
+
"mailboxIds": {"inbox": true},
6
+
"keywords": {},
7
+
"size": 2048,
8
+
"receivedAt": "2024-01-16T09:00:00Z",
9
+
"headers": [
10
+
{"name": "X-Priority", "value": "1"},
11
+
{"name": "X-Mailer", "value": "Test Client 1.0"},
12
+
{"name": "List-Unsubscribe", "value": "<mailto:unsubscribe@example.com>"}
13
+
],
14
+
"header:X-Priority:asText": "1",
15
+
"header:X-Mailer:asText": "Test Client 1.0"
16
+
}
+15
test/proto/mail/email/valid/with_keywords.json
+15
test/proto/mail/email/valid/with_keywords.json
···
1
+
{
2
+
"id": "e1",
3
+
"blobId": "blob1",
4
+
"threadId": "t1",
5
+
"size": 2048,
6
+
"receivedAt": "2024-01-15T10:30:00Z",
7
+
"mailboxIds": {"mb1": true},
8
+
"keywords": {
9
+
"$seen": true,
10
+
"$flagged": true,
11
+
"$answered": true
12
+
},
13
+
"hasAttachment": false,
14
+
"preview": "This is a flagged and answered email"
15
+
}
+15
test/proto/mail/email/valid/with_message_ids.json
+15
test/proto/mail/email/valid/with_message_ids.json
···
1
+
{
2
+
"id": "e6",
3
+
"blobId": "blob6",
4
+
"threadId": "t6",
5
+
"size": 4096,
6
+
"receivedAt": "2024-01-20T16:00:00Z",
7
+
"mailboxIds": {"inbox": true},
8
+
"keywords": {"$seen": true},
9
+
"messageId": ["unique-123@example.com"],
10
+
"inReplyTo": ["parent-456@example.com"],
11
+
"references": ["root-001@example.com", "parent-456@example.com"],
12
+
"subject": "Re: Original thread",
13
+
"hasAttachment": false,
14
+
"preview": "Reply in thread"
15
+
}
+3
test/proto/mail/email_address/valid/email_only.json
+3
test/proto/mail/email_address/valid/email_only.json
+4
test/proto/mail/email_address/valid/full.json
+4
test/proto/mail/email_address/valid/full.json
+28
test/proto/mail/email_body/edge/deep_nesting.json
+28
test/proto/mail/email_body/edge/deep_nesting.json
···
1
+
{
2
+
"partId": "0",
3
+
"size": 20000,
4
+
"type": "multipart/mixed",
5
+
"subParts": [
6
+
{
7
+
"partId": "1",
8
+
"size": 15000,
9
+
"type": "multipart/mixed",
10
+
"subParts": [
11
+
{
12
+
"partId": "1.1",
13
+
"size": 10000,
14
+
"type": "multipart/alternative",
15
+
"subParts": [
16
+
{
17
+
"partId": "1.1.1",
18
+
"blobId": "b1",
19
+
"size": 500,
20
+
"type": "text/plain",
21
+
"charset": "utf-8"
22
+
}
23
+
]
24
+
}
25
+
]
26
+
}
27
+
]
28
+
}
+21
test/proto/mail/email_body/valid/multipart.json
+21
test/proto/mail/email_body/valid/multipart.json
···
1
+
{
2
+
"partId": "0",
3
+
"size": 5000,
4
+
"type": "multipart/alternative",
5
+
"subParts": [
6
+
{
7
+
"partId": "1",
8
+
"blobId": "b1",
9
+
"size": 200,
10
+
"type": "text/plain",
11
+
"charset": "utf-8"
12
+
},
13
+
{
14
+
"partId": "2",
15
+
"blobId": "b2",
16
+
"size": 4800,
17
+
"type": "text/html",
18
+
"charset": "utf-8"
19
+
}
20
+
]
21
+
}
+36
test/proto/mail/email_body/valid/multipart_mixed.json
+36
test/proto/mail/email_body/valid/multipart_mixed.json
···
1
+
{
2
+
"partId": "0",
3
+
"size": 10000,
4
+
"type": "multipart/mixed",
5
+
"subParts": [
6
+
{
7
+
"partId": "1",
8
+
"size": 5000,
9
+
"type": "multipart/alternative",
10
+
"subParts": [
11
+
{
12
+
"partId": "1.1",
13
+
"blobId": "b1",
14
+
"size": 500,
15
+
"type": "text/plain",
16
+
"charset": "utf-8"
17
+
},
18
+
{
19
+
"partId": "1.2",
20
+
"blobId": "b2",
21
+
"size": 4500,
22
+
"type": "text/html",
23
+
"charset": "utf-8"
24
+
}
25
+
]
26
+
},
27
+
{
28
+
"partId": "2",
29
+
"blobId": "b3",
30
+
"size": 5000,
31
+
"type": "application/pdf",
32
+
"name": "document.pdf",
33
+
"disposition": "attachment"
34
+
}
35
+
]
36
+
}
+9
test/proto/mail/email_body/valid/text_part.json
+9
test/proto/mail/email_body/valid/text_part.json
+23
test/proto/mail/email_body/valid/with_inline_image.json
+23
test/proto/mail/email_body/valid/with_inline_image.json
···
1
+
{
2
+
"partId": "0",
3
+
"size": 50000,
4
+
"type": "multipart/related",
5
+
"subParts": [
6
+
{
7
+
"partId": "1",
8
+
"blobId": "b1",
9
+
"size": 2000,
10
+
"type": "text/html",
11
+
"charset": "utf-8"
12
+
},
13
+
{
14
+
"partId": "2",
15
+
"blobId": "b2",
16
+
"size": 48000,
17
+
"type": "image/png",
18
+
"name": "logo.png",
19
+
"disposition": "inline",
20
+
"cid": "logo@example.com"
21
+
}
22
+
]
23
+
}
+9
test/proto/mail/email_body/valid/with_language.json
+9
test/proto/mail/email_body/valid/with_language.json
+9
test/proto/mail/identity/valid/simple.json
+9
test/proto/mail/identity/valid/simple.json
···
1
+
{
2
+
"id": "ident1",
3
+
"name": "Work Identity",
4
+
"email": "john.doe@company.com",
5
+
"replyTo": [{"email": "john.doe@company.com"}],
6
+
"textSignature": "-- \nJohn Doe\nSenior Engineer",
7
+
"htmlSignature": "<p>-- </p><p><b>John Doe</b><br/>Senior Engineer</p>",
8
+
"mayDelete": true
9
+
}
+21
test/proto/mail/mailbox/edge/all_rights_false.json
+21
test/proto/mail/mailbox/edge/all_rights_false.json
···
1
+
{
2
+
"id": "mbReadOnly",
3
+
"name": "Read Only Folder",
4
+
"sortOrder": 99,
5
+
"totalEmails": 50,
6
+
"unreadEmails": 10,
7
+
"totalThreads": 40,
8
+
"unreadThreads": 8,
9
+
"myRights": {
10
+
"mayReadItems": true,
11
+
"mayAddItems": false,
12
+
"mayRemoveItems": false,
13
+
"maySetSeen": false,
14
+
"maySetKeywords": false,
15
+
"mayCreateChild": false,
16
+
"mayRename": false,
17
+
"mayDelete": false,
18
+
"maySubmit": false
19
+
},
20
+
"isSubscribed": false
21
+
}
+12
test/proto/mail/mailbox/valid/all_roles.json
+12
test/proto/mail/mailbox/valid/all_roles.json
···
1
+
[
2
+
{"id": "r1", "name": "Inbox", "role": "inbox", "sortOrder": 1},
3
+
{"id": "r2", "name": "Drafts", "role": "drafts", "sortOrder": 2},
4
+
{"id": "r3", "name": "Sent", "role": "sent", "sortOrder": 3},
5
+
{"id": "r4", "name": "Junk", "role": "junk", "sortOrder": 4},
6
+
{"id": "r5", "name": "Trash", "role": "trash", "sortOrder": 5},
7
+
{"id": "r6", "name": "Archive", "role": "archive", "sortOrder": 6},
8
+
{"id": "r7", "name": "All", "role": "all", "sortOrder": 7},
9
+
{"id": "r8", "name": "Important", "role": "important", "sortOrder": 8},
10
+
{"id": "r9", "name": "Scheduled", "role": "scheduled", "sortOrder": 9},
11
+
{"id": "r10", "name": "Subscribed", "role": "subscribed", "sortOrder": 10}
12
+
]
+22
test/proto/mail/mailbox/valid/nested.json
+22
test/proto/mail/mailbox/valid/nested.json
···
1
+
{
2
+
"id": "mb2",
3
+
"name": "Work",
4
+
"parentId": "mb1",
5
+
"sortOrder": 10,
6
+
"totalEmails": 0,
7
+
"unreadEmails": 0,
8
+
"totalThreads": 0,
9
+
"unreadThreads": 0,
10
+
"myRights": {
11
+
"mayReadItems": true,
12
+
"mayAddItems": true,
13
+
"mayRemoveItems": true,
14
+
"maySetSeen": true,
15
+
"maySetKeywords": true,
16
+
"mayCreateChild": true,
17
+
"mayRename": true,
18
+
"mayDelete": true,
19
+
"maySubmit": false
20
+
},
21
+
"isSubscribed": false
22
+
}
+22
test/proto/mail/mailbox/valid/simple.json
+22
test/proto/mail/mailbox/valid/simple.json
···
1
+
{
2
+
"id": "mb1",
3
+
"name": "Inbox",
4
+
"role": "inbox",
5
+
"sortOrder": 1,
6
+
"totalEmails": 150,
7
+
"unreadEmails": 5,
8
+
"totalThreads": 100,
9
+
"unreadThreads": 3,
10
+
"myRights": {
11
+
"mayReadItems": true,
12
+
"mayAddItems": true,
13
+
"mayRemoveItems": true,
14
+
"maySetSeen": true,
15
+
"maySetKeywords": true,
16
+
"mayCreateChild": true,
17
+
"mayRename": false,
18
+
"mayDelete": false,
19
+
"maySubmit": true
20
+
},
21
+
"isSubscribed": true
22
+
}
+22
test/proto/mail/mailbox/valid/with_all_roles.json
+22
test/proto/mail/mailbox/valid/with_all_roles.json
···
1
+
{
2
+
"id": "mbArchive",
3
+
"name": "Archive",
4
+
"role": "archive",
5
+
"sortOrder": 5,
6
+
"totalEmails": 1000,
7
+
"unreadEmails": 0,
8
+
"totalThreads": 800,
9
+
"unreadThreads": 0,
10
+
"myRights": {
11
+
"mayReadItems": true,
12
+
"mayAddItems": true,
13
+
"mayRemoveItems": true,
14
+
"maySetSeen": true,
15
+
"maySetKeywords": true,
16
+
"mayCreateChild": true,
17
+
"mayRename": true,
18
+
"mayDelete": true,
19
+
"maySubmit": false
20
+
},
21
+
"isSubscribed": true
22
+
}
+21
test/proto/mail/submission/valid/final_status.json
+21
test/proto/mail/submission/valid/final_status.json
···
1
+
{
2
+
"id": "sub3",
3
+
"identityId": "ident1",
4
+
"emailId": "e2",
5
+
"threadId": "t2",
6
+
"envelope": {
7
+
"mailFrom": {"email": "sender@example.com"},
8
+
"rcptTo": [{"email": "recipient@example.com"}]
9
+
},
10
+
"sendAt": "2024-01-15T12:00:00Z",
11
+
"undoStatus": "final",
12
+
"deliveryStatus": {
13
+
"recipient@example.com": {
14
+
"smtpReply": "250 2.0.0 OK",
15
+
"delivered": "yes",
16
+
"displayed": "unknown"
17
+
}
18
+
},
19
+
"dsnBlobIds": [],
20
+
"mdnBlobIds": []
21
+
}
+14
test/proto/mail/submission/valid/simple.json
+14
test/proto/mail/submission/valid/simple.json
···
1
+
{
2
+
"id": "sub1",
3
+
"identityId": "ident1",
4
+
"emailId": "e1",
5
+
"threadId": "t1",
6
+
"envelope": {
7
+
"mailFrom": {"email": "sender@example.com"},
8
+
"rcptTo": [{"email": "recipient@example.com"}]
9
+
},
10
+
"sendAt": "2024-01-15T15:00:00Z",
11
+
"undoStatus": "pending",
12
+
"dsnBlobIds": [],
13
+
"mdnBlobIds": []
14
+
}
+20
test/proto/mail/submission/valid/with_envelope.json
+20
test/proto/mail/submission/valid/with_envelope.json
···
1
+
{
2
+
"id": "sub2",
3
+
"identityId": "ident1",
4
+
"emailId": "e1",
5
+
"threadId": "t1",
6
+
"envelope": {
7
+
"mailFrom": {
8
+
"email": "sender@example.com",
9
+
"parameters": {"SIZE": "1024", "BODY": "8BITMIME"}
10
+
},
11
+
"rcptTo": [
12
+
{"email": "recipient1@example.com"},
13
+
{"email": "recipient2@example.com", "parameters": {"NOTIFY": "SUCCESS,FAILURE"}}
14
+
]
15
+
},
16
+
"sendAt": "2024-01-15T15:00:00Z",
17
+
"undoStatus": "pending",
18
+
"dsnBlobIds": [],
19
+
"mdnBlobIds": []
20
+
}
+4
test/proto/mail/thread/valid/conversation.json
+4
test/proto/mail/thread/valid/conversation.json
+4
test/proto/mail/vacation/valid/disabled.json
+4
test/proto/mail/vacation/valid/disabled.json
+9
test/proto/mail/vacation/valid/enabled.json
+9
test/proto/mail/vacation/valid/enabled.json
···
1
+
{
2
+
"id": "singleton",
3
+
"isEnabled": true,
4
+
"fromDate": "2024-01-20T00:00:00Z",
5
+
"toDate": "2024-01-27T23:59:59Z",
6
+
"subject": "Out of Office",
7
+
"textBody": "I am currently out of the office and will return on January 27th.",
8
+
"htmlBody": "<p>I am currently out of the office and will return on January 27th.</p>"
9
+
}
+9
test/proto/method/valid/changes_response.json
+9
test/proto/method/valid/changes_response.json
+5
test/proto/method/valid/get_args.json
+5
test/proto/method/valid/get_args.json
+16
test/proto/method/valid/query_args.json
+16
test/proto/method/valid/query_args.json
···
1
+
{
2
+
"accountId": "acc1",
3
+
"filter": {
4
+
"operator": "AND",
5
+
"conditions": [
6
+
{"inMailbox": "inbox"},
7
+
{"hasKeyword": "$seen"}
8
+
]
9
+
},
10
+
"sort": [
11
+
{"property": "receivedAt", "isAscending": false}
12
+
],
13
+
"position": 0,
14
+
"limit": 100,
15
+
"calculateTotal": true
16
+
}
+8
test/proto/method/valid/query_response.json
+8
test/proto/method/valid/query_response.json
+12
test/proto/method/valid/set_args.json
+12
test/proto/method/valid/set_args.json
+16
test/proto/method/valid/set_response.json
+16
test/proto/method/valid/set_response.json
···
1
+
{
2
+
"accountId": "acc1",
3
+
"oldState": "state123",
4
+
"newState": "state456",
5
+
"created": {
6
+
"new1": {"id": "mb123", "name": "Folder 1"},
7
+
"new2": {"id": "mb456", "name": "Folder 2"}
8
+
},
9
+
"updated": {
10
+
"existing1": null
11
+
},
12
+
"destroyed": ["old1", "old2"],
13
+
"notCreated": {},
14
+
"notUpdated": {},
15
+
"notDestroyed": {}
16
+
}
+19
test/proto/method/valid/set_response_with_errors.json
+19
test/proto/method/valid/set_response_with_errors.json
···
1
+
{
2
+
"accountId": "acc1",
3
+
"oldState": "state123",
4
+
"newState": "state124",
5
+
"created": {
6
+
"new1": {"id": "mb789", "name": "Success Folder"}
7
+
},
8
+
"updated": {},
9
+
"destroyed": [],
10
+
"notCreated": {
11
+
"new2": {"type": "invalidProperties", "properties": ["name"]}
12
+
},
13
+
"notUpdated": {
14
+
"existing1": {"type": "notFound"}
15
+
},
16
+
"notDestroyed": {
17
+
"old1": {"type": "forbidden", "description": "Cannot delete inbox"}
18
+
}
19
+
}
+5
test/proto/request/invalid/missing_using.json
+5
test/proto/request/invalid/missing_using.json
+1
test/proto/request/invalid/not_object.json
+1
test/proto/request/invalid/not_object.json
···
1
+
["urn:ietf:params:jmap:core"]
+4
test/proto/request/valid/empty_methods.json
+4
test/proto/request/valid/empty_methods.json
+8
test/proto/request/valid/multiple_methods.json
+8
test/proto/request/valid/multiple_methods.json
···
1
+
{
2
+
"using": ["urn:ietf:params:jmap:core", "urn:ietf:params:jmap:mail"],
3
+
"methodCalls": [
4
+
["Mailbox/get", {"accountId": "acc1"}, "c1"],
5
+
["Email/query", {"accountId": "acc1", "filter": {"inMailbox": "inbox1"}}, "c2"],
6
+
["Email/get", {"accountId": "acc1", "#ids": {"resultOf": "c2", "name": "Email/query", "path": "/ids"}}, "c3"]
7
+
]
8
+
}
+6
test/proto/request/valid/single_method.json
+6
test/proto/request/valid/single_method.json
+9
test/proto/request/valid/with_created_ids.json
+9
test/proto/request/valid/with_created_ids.json
+20
test/proto/request/valid/with_creation_refs.json
+20
test/proto/request/valid/with_creation_refs.json
···
1
+
{
2
+
"using": ["urn:ietf:params:jmap:core", "urn:ietf:params:jmap:mail"],
3
+
"methodCalls": [
4
+
["Mailbox/set", {
5
+
"accountId": "acc1",
6
+
"create": {
7
+
"newBox": {"name": "New Folder", "parentId": null}
8
+
}
9
+
}, "c1"],
10
+
["Email/set", {
11
+
"accountId": "acc1",
12
+
"create": {
13
+
"draft1": {
14
+
"mailboxIds": {"#newBox": true},
15
+
"subject": "Draft in new folder"
16
+
}
17
+
}
18
+
}, "c2"]
19
+
]
20
+
}
+7
test/proto/request/valid/with_result_reference.json
+7
test/proto/request/valid/with_result_reference.json
···
1
+
{
2
+
"using": ["urn:ietf:params:jmap:core", "urn:ietf:params:jmap:mail"],
3
+
"methodCalls": [
4
+
["Mailbox/query", {"accountId": "acc1", "filter": {"role": "inbox"}}, "0"],
5
+
["Mailbox/get", {"accountId": "acc1", "#ids": {"resultOf": "0", "name": "Mailbox/query", "path": "/ids"}}, "1"]
6
+
]
7
+
}
+5
test/proto/response/invalid/missing_session_state.json
+5
test/proto/response/invalid/missing_session_state.json
+7
test/proto/response/valid/multiple_responses.json
+7
test/proto/response/valid/multiple_responses.json
···
1
+
{
2
+
"methodResponses": [
3
+
["Email/query", {"accountId": "acc1", "queryState": "q1", "canCalculateChanges": true, "position": 0, "ids": ["e1", "e2", "e3"], "total": 100}, "c1"],
4
+
["Email/get", {"accountId": "acc1", "state": "s1", "list": [{"id": "e1", "blobId": "b1", "threadId": "t1", "mailboxIds": {"inbox": true}, "keywords": {"$seen": true}, "size": 1234, "receivedAt": "2024-01-15T10:30:00Z"}], "notFound": []}, "c2"]
5
+
],
6
+
"sessionState": "sessionABC"
7
+
}
+6
test/proto/response/valid/success.json
+6
test/proto/response/valid/success.json
+9
test/proto/response/valid/with_created_ids.json
+9
test/proto/response/valid/with_created_ids.json
+6
test/proto/response/valid/with_error.json
+6
test/proto/response/valid/with_error.json
+22
test/proto/session/edge/empty_accounts.json
+22
test/proto/session/edge/empty_accounts.json
···
1
+
{
2
+
"capabilities": {
3
+
"urn:ietf:params:jmap:core": {
4
+
"maxSizeUpload": 50000000,
5
+
"maxConcurrentUpload": 4,
6
+
"maxSizeRequest": 10000000,
7
+
"maxConcurrentRequests": 4,
8
+
"maxCallsInRequest": 16,
9
+
"maxObjectsInGet": 500,
10
+
"maxObjectsInSet": 500,
11
+
"collationAlgorithms": []
12
+
}
13
+
},
14
+
"accounts": {},
15
+
"primaryAccounts": {},
16
+
"username": "anonymous",
17
+
"apiUrl": "https://api.example.com/jmap/",
18
+
"downloadUrl": "https://api.example.com/download/{accountId}/{blobId}/{name}",
19
+
"uploadUrl": "https://api.example.com/upload/{accountId}/",
20
+
"eventSourceUrl": "https://api.example.com/events/",
21
+
"state": "empty"
22
+
}
+10
test/proto/session/invalid/missing_api_url.json
+10
test/proto/session/invalid/missing_api_url.json
···
1
+
{
2
+
"capabilities": {},
3
+
"accounts": {},
4
+
"primaryAccounts": {},
5
+
"username": "test@example.com",
6
+
"downloadUrl": "https://api.example.com/download/",
7
+
"uploadUrl": "https://api.example.com/upload/",
8
+
"eventSourceUrl": "https://api.example.com/events/",
9
+
"state": "abc"
10
+
}
+17
test/proto/session/invalid/missing_capabilities.json
+17
test/proto/session/invalid/missing_capabilities.json
···
1
+
{
2
+
"accounts": {
3
+
"acc1": {
4
+
"name": "Test Account",
5
+
"isPersonal": true,
6
+
"isReadOnly": false,
7
+
"accountCapabilities": {}
8
+
}
9
+
},
10
+
"primaryAccounts": {},
11
+
"username": "test@example.com",
12
+
"apiUrl": "https://api.example.com/jmap/",
13
+
"downloadUrl": "https://api.example.com/download/",
14
+
"uploadUrl": "https://api.example.com/upload/",
15
+
"eventSourceUrl": "https://api.example.com/events/",
16
+
"state": "abc"
17
+
}
+31
test/proto/session/valid/minimal.json
+31
test/proto/session/valid/minimal.json
···
1
+
{
2
+
"capabilities": {
3
+
"urn:ietf:params:jmap:core": {
4
+
"maxSizeUpload": 50000000,
5
+
"maxConcurrentUpload": 4,
6
+
"maxSizeRequest": 10000000,
7
+
"maxConcurrentRequests": 4,
8
+
"maxCallsInRequest": 16,
9
+
"maxObjectsInGet": 500,
10
+
"maxObjectsInSet": 500,
11
+
"collationAlgorithms": ["i;ascii-casemap", "i;octet"]
12
+
}
13
+
},
14
+
"accounts": {
15
+
"acc1": {
16
+
"name": "Test Account",
17
+
"isPersonal": true,
18
+
"isReadOnly": false,
19
+
"accountCapabilities": {}
20
+
}
21
+
},
22
+
"primaryAccounts": {
23
+
"urn:ietf:params:jmap:core": "acc1"
24
+
},
25
+
"username": "test@example.com",
26
+
"apiUrl": "https://api.example.com/jmap/",
27
+
"downloadUrl": "https://api.example.com/jmap/download/{accountId}/{blobId}/{name}?type={type}",
28
+
"uploadUrl": "https://api.example.com/jmap/upload/{accountId}/",
29
+
"eventSourceUrl": "https://api.example.com/jmap/eventsource/",
30
+
"state": "abc123"
31
+
}
+44
test/proto/session/valid/with_accounts.json
+44
test/proto/session/valid/with_accounts.json
···
1
+
{
2
+
"capabilities": {
3
+
"urn:ietf:params:jmap:core": {
4
+
"maxSizeUpload": 50000000,
5
+
"maxConcurrentUpload": 4,
6
+
"maxSizeRequest": 10000000,
7
+
"maxConcurrentRequests": 4,
8
+
"maxCallsInRequest": 16,
9
+
"maxObjectsInGet": 500,
10
+
"maxObjectsInSet": 500,
11
+
"collationAlgorithms": ["i;ascii-casemap", "i;unicode-casemap"]
12
+
}
13
+
},
14
+
"accounts": {
15
+
"acc1": {
16
+
"name": "Personal Account",
17
+
"isPersonal": true,
18
+
"isReadOnly": false,
19
+
"accountCapabilities": {
20
+
"urn:ietf:params:jmap:core": {},
21
+
"urn:ietf:params:jmap:mail": {}
22
+
}
23
+
},
24
+
"acc2": {
25
+
"name": "Shared Account",
26
+
"isPersonal": false,
27
+
"isReadOnly": true,
28
+
"accountCapabilities": {
29
+
"urn:ietf:params:jmap:core": {},
30
+
"urn:ietf:params:jmap:mail": {}
31
+
}
32
+
}
33
+
},
34
+
"primaryAccounts": {
35
+
"urn:ietf:params:jmap:core": "acc1",
36
+
"urn:ietf:params:jmap:mail": "acc1"
37
+
},
38
+
"username": "user@example.com",
39
+
"apiUrl": "https://api.example.com/jmap/",
40
+
"downloadUrl": "https://api.example.com/download/{accountId}/{blobId}/{name}?accept={type}",
41
+
"uploadUrl": "https://api.example.com/upload/{accountId}/",
42
+
"eventSourceUrl": "https://api.example.com/eventsource/?types={types}&closeafter={closeafter}&ping={ping}",
43
+
"state": "session123"
44
+
}
+56
test/proto/session/valid/with_mail.json
+56
test/proto/session/valid/with_mail.json
···
1
+
{
2
+
"capabilities": {
3
+
"urn:ietf:params:jmap:core": {
4
+
"maxSizeUpload": 50000000,
5
+
"maxConcurrentUpload": 4,
6
+
"maxSizeRequest": 10000000,
7
+
"maxConcurrentRequests": 4,
8
+
"maxCallsInRequest": 16,
9
+
"maxObjectsInGet": 500,
10
+
"maxObjectsInSet": 500,
11
+
"collationAlgorithms": ["i;ascii-casemap", "i;octet"]
12
+
},
13
+
"urn:ietf:params:jmap:mail": {
14
+
"maxMailboxesPerEmail": 1000,
15
+
"maxMailboxDepth": 10,
16
+
"maxSizeMailboxName": 490,
17
+
"maxSizeAttachmentsPerEmail": 50000000,
18
+
"emailQuerySortOptions": ["receivedAt", "from", "to", "subject", "size"],
19
+
"mayCreateTopLevelMailbox": true
20
+
},
21
+
"urn:ietf:params:jmap:submission": {
22
+
"maxDelayedSend": 86400,
23
+
"submissionExtensions": {}
24
+
}
25
+
},
26
+
"accounts": {
27
+
"A001": {
28
+
"name": "Personal",
29
+
"isPersonal": true,
30
+
"isReadOnly": false,
31
+
"accountCapabilities": {
32
+
"urn:ietf:params:jmap:core": {},
33
+
"urn:ietf:params:jmap:mail": {}
34
+
}
35
+
},
36
+
"A002": {
37
+
"name": "Shared Archive",
38
+
"isPersonal": false,
39
+
"isReadOnly": true,
40
+
"accountCapabilities": {
41
+
"urn:ietf:params:jmap:mail": {}
42
+
}
43
+
}
44
+
},
45
+
"primaryAccounts": {
46
+
"urn:ietf:params:jmap:core": "A001",
47
+
"urn:ietf:params:jmap:mail": "A001",
48
+
"urn:ietf:params:jmap:submission": "A001"
49
+
},
50
+
"username": "john.doe@example.com",
51
+
"apiUrl": "https://jmap.example.com/api/",
52
+
"downloadUrl": "https://jmap.example.com/download/{accountId}/{blobId}/{name}?type={type}",
53
+
"uploadUrl": "https://jmap.example.com/upload/{accountId}/",
54
+
"eventSourceUrl": "https://jmap.example.com/events/?types={types}&closeafter={closeafter}&ping={ping}",
55
+
"state": "xyz789-session-state"
56
+
}
+993
test/proto/test_proto.ml
+993
test/proto/test_proto.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP Protocol codec tests using sample JSON files *)
7
+
8
+
let read_file path =
9
+
let ic = open_in path in
10
+
let n = in_channel_length ic in
11
+
let s = really_input_string ic n in
12
+
close_in ic;
13
+
s
14
+
15
+
let decode jsont json_str =
16
+
Jsont_bytesrw.decode_string' jsont json_str
17
+
18
+
let encode jsont value =
19
+
Jsont_bytesrw.encode_string' jsont value
20
+
21
+
(* Test helpers *)
22
+
23
+
let test_decode_success name jsont path () =
24
+
let json = read_file path in
25
+
match decode jsont json with
26
+
| Ok _ -> ()
27
+
| Error e ->
28
+
Alcotest.failf "%s: expected success but got error: %s" name (Jsont.Error.to_string e)
29
+
30
+
let test_decode_failure name jsont path () =
31
+
let json = read_file path in
32
+
match decode jsont json with
33
+
| Ok _ -> Alcotest.failf "%s: expected failure but got success" name
34
+
| Error _ -> ()
35
+
36
+
let test_roundtrip name jsont path () =
37
+
let json = read_file path in
38
+
match decode jsont json with
39
+
| Error e ->
40
+
Alcotest.failf "%s: decode failed: %s" name (Jsont.Error.to_string e)
41
+
| Ok value ->
42
+
match encode jsont value with
43
+
| Error e ->
44
+
Alcotest.failf "%s: encode failed: %s" name (Jsont.Error.to_string e)
45
+
| Ok encoded ->
46
+
match decode jsont encoded with
47
+
| Error e ->
48
+
Alcotest.failf "%s: re-decode failed: %s" name (Jsont.Error.to_string e)
49
+
| Ok _ -> ()
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
+
57
+
(* ID tests *)
58
+
module Id_tests = struct
59
+
open Jmap.Proto
60
+
61
+
let test_valid_simple () =
62
+
let json = "\"abc123\"" in
63
+
match decode Id.jsont json with
64
+
| Ok id -> Alcotest.(check string) "id value" "abc123" (Id.to_string id)
65
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
66
+
67
+
let test_valid_single_char () =
68
+
let json = "\"a\"" in
69
+
match decode Id.jsont json with
70
+
| Ok id -> Alcotest.(check string) "id value" "a" (Id.to_string id)
71
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
72
+
73
+
let test_valid_with_hyphen () =
74
+
let json = "\"msg-2024-01\"" in
75
+
match decode Id.jsont json with
76
+
| Ok id -> Alcotest.(check string) "id value" "msg-2024-01" (Id.to_string id)
77
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
78
+
79
+
let test_valid_with_underscore () =
80
+
let json = "\"user_id_123\"" in
81
+
match decode Id.jsont json with
82
+
| Ok id -> Alcotest.(check string) "id value" "user_id_123" (Id.to_string id)
83
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
84
+
85
+
let test_invalid_empty () =
86
+
let json = "\"\"" in
87
+
match decode Id.jsont json with
88
+
| Ok _ -> Alcotest.fail "expected failure for empty id"
89
+
| Error _ -> ()
90
+
91
+
let test_invalid_with_space () =
92
+
let json = "\"hello world\"" in
93
+
match decode Id.jsont json with
94
+
| Ok _ -> Alcotest.fail "expected failure for id with space"
95
+
| Error _ -> ()
96
+
97
+
let test_invalid_with_special () =
98
+
let json = "\"abc@def\"" in
99
+
match decode Id.jsont json with
100
+
| Ok _ -> Alcotest.fail "expected failure for id with @"
101
+
| Error _ -> ()
102
+
103
+
let test_invalid_not_string () =
104
+
let json = "12345" in
105
+
match decode Id.jsont json with
106
+
| Ok _ -> Alcotest.fail "expected failure for non-string"
107
+
| Error _ -> ()
108
+
109
+
let test_edge_max_length () =
110
+
let id_255 = String.make 255 'a' in
111
+
let json = Printf.sprintf "\"%s\"" id_255 in
112
+
match decode Id.jsont json with
113
+
| Ok id -> Alcotest.(check int) "id length" 255 (String.length (Id.to_string id))
114
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
115
+
116
+
let test_edge_over_max_length () =
117
+
let id_256 = String.make 256 'a' in
118
+
let json = Printf.sprintf "\"%s\"" id_256 in
119
+
match decode Id.jsont json with
120
+
| Ok _ -> Alcotest.fail "expected failure for 256 char id"
121
+
| Error _ -> ()
122
+
123
+
let tests = [
124
+
"valid: simple", `Quick, test_valid_simple;
125
+
"valid: single char", `Quick, test_valid_single_char;
126
+
"valid: with hyphen", `Quick, test_valid_with_hyphen;
127
+
"valid: with underscore", `Quick, test_valid_with_underscore;
128
+
"invalid: empty", `Quick, test_invalid_empty;
129
+
"invalid: with space", `Quick, test_invalid_with_space;
130
+
"invalid: with special", `Quick, test_invalid_with_special;
131
+
"invalid: not string", `Quick, test_invalid_not_string;
132
+
"edge: max length 255", `Quick, test_edge_max_length;
133
+
"edge: over max length 256", `Quick, test_edge_over_max_length;
134
+
]
135
+
end
136
+
137
+
(* Int53 tests *)
138
+
module Int53_tests = struct
139
+
open Jmap.Proto
140
+
141
+
let test_zero () =
142
+
match decode Int53.Signed.jsont "0" with
143
+
| Ok n -> Alcotest.(check int64) "value" 0L n
144
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
145
+
146
+
let test_positive () =
147
+
match decode Int53.Signed.jsont "12345" with
148
+
| Ok n -> Alcotest.(check int64) "value" 12345L n
149
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
150
+
151
+
let test_negative () =
152
+
match decode Int53.Signed.jsont "-12345" with
153
+
| Ok n -> Alcotest.(check int64) "value" (-12345L) n
154
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
155
+
156
+
let test_max_safe () =
157
+
match decode Int53.Signed.jsont "9007199254740991" with
158
+
| Ok n -> Alcotest.(check int64) "value" 9007199254740991L n
159
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
160
+
161
+
let test_min_safe () =
162
+
match decode Int53.Signed.jsont "-9007199254740991" with
163
+
| Ok n -> Alcotest.(check int64) "value" (-9007199254740991L) n
164
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
165
+
166
+
let test_over_max_safe () =
167
+
match decode Int53.Signed.jsont "9007199254740992" with
168
+
| Ok _ -> Alcotest.fail "expected failure for over max safe"
169
+
| Error _ -> ()
170
+
171
+
let test_under_min_safe () =
172
+
match decode Int53.Signed.jsont "-9007199254740992" with
173
+
| Ok _ -> Alcotest.fail "expected failure for under min safe"
174
+
| Error _ -> ()
175
+
176
+
let test_unsigned_zero () =
177
+
match decode Int53.Unsigned.jsont "0" with
178
+
| Ok n -> Alcotest.(check int64) "value" 0L n
179
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
180
+
181
+
let test_unsigned_max () =
182
+
match decode Int53.Unsigned.jsont "9007199254740991" with
183
+
| Ok n -> Alcotest.(check int64) "value" 9007199254740991L n
184
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
185
+
186
+
let test_unsigned_negative () =
187
+
match decode Int53.Unsigned.jsont "-1" with
188
+
| Ok _ -> Alcotest.fail "expected failure for negative unsigned"
189
+
| Error _ -> ()
190
+
191
+
let tests = [
192
+
"signed: zero", `Quick, test_zero;
193
+
"signed: positive", `Quick, test_positive;
194
+
"signed: negative", `Quick, test_negative;
195
+
"signed: max safe", `Quick, test_max_safe;
196
+
"signed: min safe", `Quick, test_min_safe;
197
+
"signed: over max safe", `Quick, test_over_max_safe;
198
+
"signed: under min safe", `Quick, test_under_min_safe;
199
+
"unsigned: zero", `Quick, test_unsigned_zero;
200
+
"unsigned: max", `Quick, test_unsigned_max;
201
+
"unsigned: negative fails", `Quick, test_unsigned_negative;
202
+
]
203
+
end
204
+
205
+
(* Date tests *)
206
+
module Date_tests = struct
207
+
open Jmap.Proto
208
+
209
+
let test_utc_z () =
210
+
match decode Date.Utc.jsont "\"2024-01-15T10:30:00Z\"" with
211
+
| Ok _ -> ()
212
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
213
+
214
+
let test_rfc3339_with_offset () =
215
+
match decode Date.Rfc3339.jsont "\"2024-01-15T10:30:00+05:30\"" with
216
+
| Ok _ -> ()
217
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
218
+
219
+
let test_with_milliseconds () =
220
+
match decode Date.Rfc3339.jsont "\"2024-01-15T10:30:00.123Z\"" with
221
+
| Ok _ -> ()
222
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
223
+
224
+
let test_invalid_format () =
225
+
match decode Date.Rfc3339.jsont "\"January 15, 2024\"" with
226
+
| Ok _ -> Alcotest.fail "expected failure for invalid format"
227
+
| Error _ -> ()
228
+
229
+
let test_not_string () =
230
+
match decode Date.Rfc3339.jsont "1705315800" with
231
+
| Ok _ -> Alcotest.fail "expected failure for non-string"
232
+
| Error _ -> ()
233
+
234
+
let tests = [
235
+
"utc: Z suffix", `Quick, test_utc_z;
236
+
"rfc3339: with offset", `Quick, test_rfc3339_with_offset;
237
+
"rfc3339: with milliseconds", `Quick, test_with_milliseconds;
238
+
"invalid: bad format", `Quick, test_invalid_format;
239
+
"invalid: not string", `Quick, test_not_string;
240
+
]
241
+
end
242
+
243
+
(* Session tests *)
244
+
module Session_tests = struct
245
+
open Jmap.Proto
246
+
247
+
let test_minimal () =
248
+
test_decode_success "minimal session" Session.jsont "session/valid/minimal.json" ()
249
+
250
+
let test_with_mail () =
251
+
test_decode_success "session with mail" Session.jsont "session/valid/with_mail.json" ()
252
+
253
+
let test_roundtrip_minimal () =
254
+
test_roundtrip "minimal session roundtrip" Session.jsont "session/valid/minimal.json" ()
255
+
256
+
let test_values () =
257
+
let json = read_file "session/valid/minimal.json" in
258
+
match decode Session.jsont json with
259
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
260
+
| Ok session ->
261
+
Alcotest.(check string) "username" "test@example.com" (Session.username session);
262
+
Alcotest.(check string) "apiUrl" "https://api.example.com/jmap/" (Session.api_url session);
263
+
Alcotest.(check string) "state" "abc123" (Session.state session);
264
+
Alcotest.(check bool) "has core capability" true
265
+
(Session.has_capability Capability.core session)
266
+
267
+
let test_with_accounts () =
268
+
test_decode_success "with accounts" Session.jsont "session/valid/with_accounts.json" ()
269
+
270
+
let test_empty_accounts () =
271
+
test_decode_success "empty accounts" Session.jsont "session/edge/empty_accounts.json" ()
272
+
273
+
let test_accounts_values () =
274
+
let json = read_file "session/valid/with_accounts.json" in
275
+
match decode Session.jsont json with
276
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
277
+
| Ok session ->
278
+
Alcotest.(check int) "accounts count" 2 (List.length (Session.accounts session));
279
+
Alcotest.(check int) "primary_accounts count" 2 (List.length (Session.primary_accounts session))
280
+
281
+
let tests = [
282
+
"valid: minimal", `Quick, test_minimal;
283
+
"valid: with mail", `Quick, test_with_mail;
284
+
"valid: with accounts", `Quick, test_with_accounts;
285
+
"edge: empty accounts", `Quick, test_empty_accounts;
286
+
"roundtrip: minimal", `Quick, test_roundtrip_minimal;
287
+
"values: minimal", `Quick, test_values;
288
+
"values: accounts", `Quick, test_accounts_values;
289
+
]
290
+
end
291
+
292
+
(* Request tests *)
293
+
module Request_tests = struct
294
+
open Jmap.Proto
295
+
296
+
let test_single_method () =
297
+
test_decode_success "single method" Request.jsont "request/valid/single_method.json" ()
298
+
299
+
let test_multiple_methods () =
300
+
test_decode_success "multiple methods" Request.jsont "request/valid/multiple_methods.json" ()
301
+
302
+
let test_with_created_ids () =
303
+
test_decode_success "with created ids" Request.jsont "request/valid/with_created_ids.json" ()
304
+
305
+
let test_empty_methods () =
306
+
test_decode_success "empty methods" Request.jsont "request/valid/empty_methods.json" ()
307
+
308
+
let test_values () =
309
+
let json = read_file "request/valid/single_method.json" in
310
+
match decode Request.jsont json with
311
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
312
+
| Ok request ->
313
+
Alcotest.(check int) "using count" 2 (List.length (Request.using request));
314
+
Alcotest.(check int) "method calls count" 1 (List.length (Request.method_calls request))
315
+
316
+
let test_roundtrip () =
317
+
test_roundtrip "single method roundtrip" Request.jsont "request/valid/single_method.json" ()
318
+
319
+
let tests = [
320
+
"valid: single method", `Quick, test_single_method;
321
+
"valid: multiple methods", `Quick, test_multiple_methods;
322
+
"valid: with created ids", `Quick, test_with_created_ids;
323
+
"valid: empty methods", `Quick, test_empty_methods;
324
+
"values: single method", `Quick, test_values;
325
+
"roundtrip: single method", `Quick, test_roundtrip;
326
+
]
327
+
end
328
+
329
+
(* Response tests *)
330
+
module Response_tests = struct
331
+
open Jmap.Proto
332
+
333
+
let test_success () =
334
+
test_decode_success "success" Response.jsont "response/valid/success.json" ()
335
+
336
+
let test_with_created_ids () =
337
+
test_decode_success "with created ids" Response.jsont "response/valid/with_created_ids.json" ()
338
+
339
+
let test_with_error () =
340
+
test_decode_success "with error" Response.jsont "response/valid/with_error.json" ()
341
+
342
+
let test_multiple_responses () =
343
+
test_decode_success "multiple responses" Response.jsont "response/valid/multiple_responses.json" ()
344
+
345
+
let test_values () =
346
+
let json = read_file "response/valid/success.json" in
347
+
match decode Response.jsont json with
348
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
349
+
| Ok response ->
350
+
Alcotest.(check string) "session state" "session123" (Response.session_state response);
351
+
Alcotest.(check int) "method responses count" 1 (List.length (Response.method_responses response))
352
+
353
+
let test_roundtrip () =
354
+
test_roundtrip "success roundtrip" Response.jsont "response/valid/success.json" ()
355
+
356
+
let tests = [
357
+
"valid: success", `Quick, test_success;
358
+
"valid: with created ids", `Quick, test_with_created_ids;
359
+
"valid: with error", `Quick, test_with_error;
360
+
"valid: multiple responses", `Quick, test_multiple_responses;
361
+
"values: success", `Quick, test_values;
362
+
"roundtrip: success", `Quick, test_roundtrip;
363
+
]
364
+
end
365
+
366
+
(* Invocation tests *)
367
+
module Invocation_tests = struct
368
+
open Jmap.Proto
369
+
370
+
let test_get () =
371
+
test_decode_success "get" Invocation.jsont "invocation/valid/get.json" ()
372
+
373
+
let test_set () =
374
+
test_decode_success "set" Invocation.jsont "invocation/valid/set.json" ()
375
+
376
+
let test_query () =
377
+
test_decode_success "query" Invocation.jsont "invocation/valid/query.json" ()
378
+
379
+
let test_values () =
380
+
let json = read_file "invocation/valid/get.json" in
381
+
match decode Invocation.jsont json with
382
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
383
+
| Ok inv ->
384
+
Alcotest.(check string) "name" "Email/get" (Invocation.name inv);
385
+
Alcotest.(check string) "method call id" "call-001" (Invocation.method_call_id inv)
386
+
387
+
let test_invalid_not_array () =
388
+
test_decode_failure "not array" Invocation.jsont "invocation/invalid/not_array.json" ()
389
+
390
+
let test_invalid_wrong_length () =
391
+
test_decode_failure "wrong length" Invocation.jsont "invocation/invalid/wrong_length.json" ()
392
+
393
+
let tests = [
394
+
"valid: get", `Quick, test_get;
395
+
"valid: set", `Quick, test_set;
396
+
"valid: query", `Quick, test_query;
397
+
"values: get", `Quick, test_values;
398
+
"invalid: not array", `Quick, test_invalid_not_array;
399
+
"invalid: wrong length", `Quick, test_invalid_wrong_length;
400
+
]
401
+
end
402
+
403
+
(* Capability tests *)
404
+
module Capability_tests = struct
405
+
open Jmap.Proto
406
+
407
+
let test_core () =
408
+
test_decode_success "core" Capability.Core.jsont "capability/valid/core.json" ()
409
+
410
+
let test_mail () =
411
+
test_decode_success "mail" Capability.Mail.jsont "capability/valid/mail.json" ()
412
+
413
+
let test_submission () =
414
+
test_decode_success "submission" Capability.Submission.jsont "capability/valid/submission.json" ()
415
+
416
+
let test_core_values () =
417
+
let json = read_file "capability/valid/core.json" in
418
+
match decode Capability.Core.jsont json with
419
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
420
+
| Ok cap ->
421
+
Alcotest.(check int64) "maxSizeUpload" 50000000L (Capability.Core.max_size_upload cap);
422
+
Alcotest.(check int) "maxConcurrentUpload" 4 (Capability.Core.max_concurrent_upload cap);
423
+
Alcotest.(check int) "maxCallsInRequest" 16 (Capability.Core.max_calls_in_request cap)
424
+
425
+
let test_mail_values () =
426
+
let json = read_file "capability/valid/mail.json" in
427
+
match decode Capability.Mail.jsont json with
428
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
429
+
| Ok cap ->
430
+
Alcotest.(check int64) "maxSizeMailboxName" 490L (Capability.Mail.max_size_mailbox_name cap);
431
+
Alcotest.(check bool) "mayCreateTopLevelMailbox" true (Capability.Mail.may_create_top_level_mailbox cap)
432
+
433
+
let tests = [
434
+
"valid: core", `Quick, test_core;
435
+
"valid: mail", `Quick, test_mail;
436
+
"valid: submission", `Quick, test_submission;
437
+
"values: core", `Quick, test_core_values;
438
+
"values: mail", `Quick, test_mail_values;
439
+
]
440
+
end
441
+
442
+
(* Method args/response tests *)
443
+
module Method_tests = struct
444
+
open Jmap.Proto
445
+
446
+
let test_get_args () =
447
+
test_decode_success "get_args" Method.get_args_jsont "method/valid/get_args.json" ()
448
+
449
+
let test_get_args_minimal () =
450
+
test_decode_success "get_args_minimal" Method.get_args_jsont "method/valid/get_args_minimal.json" ()
451
+
452
+
let test_query_response () =
453
+
test_decode_success "query_response" Method.query_response_jsont "method/valid/query_response.json" ()
454
+
455
+
let test_changes_response () =
456
+
test_decode_success "changes_response" Method.changes_response_jsont "method/valid/changes_response.json" ()
457
+
458
+
let test_get_args_values () =
459
+
let json = read_file "method/valid/get_args.json" in
460
+
match decode Method.get_args_jsont json with
461
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
462
+
| Ok args ->
463
+
Alcotest.(check string) "accountId" "acc1" (Id.to_string args.account_id);
464
+
Alcotest.(check (option (list string))) "properties" (Some ["id"; "name"; "role"]) args.properties
465
+
466
+
let test_query_response_values () =
467
+
let json = read_file "method/valid/query_response.json" in
468
+
match decode Method.query_response_jsont json with
469
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
470
+
| Ok resp ->
471
+
Alcotest.(check int) "ids count" 5 (List.length resp.ids);
472
+
Alcotest.(check int64) "position" 0L resp.position;
473
+
Alcotest.(check bool) "canCalculateChanges" true resp.can_calculate_changes;
474
+
Alcotest.(check (option int64)) "total" (Some 250L) resp.total
475
+
476
+
let test_changes_response_values () =
477
+
let json = read_file "method/valid/changes_response.json" in
478
+
match decode Method.changes_response_jsont json with
479
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
480
+
| Ok resp ->
481
+
Alcotest.(check string) "oldState" "old123" resp.old_state;
482
+
Alcotest.(check string) "newState" "new456" resp.new_state;
483
+
Alcotest.(check bool) "hasMoreChanges" false resp.has_more_changes;
484
+
Alcotest.(check int) "created count" 2 (List.length resp.created);
485
+
Alcotest.(check int) "destroyed count" 2 (List.length resp.destroyed)
486
+
487
+
let tests = [
488
+
"valid: get_args", `Quick, test_get_args;
489
+
"valid: get_args_minimal", `Quick, test_get_args_minimal;
490
+
"valid: query_response", `Quick, test_query_response;
491
+
"valid: changes_response", `Quick, test_changes_response;
492
+
"values: get_args", `Quick, test_get_args_values;
493
+
"values: query_response", `Quick, test_query_response_values;
494
+
"values: changes_response", `Quick, test_changes_response_values;
495
+
]
496
+
end
497
+
498
+
(* Error tests *)
499
+
module Error_tests = struct
500
+
open Jmap.Proto
501
+
502
+
let test_method_error () =
503
+
test_decode_success "method_error" Error.method_error_jsont "error/valid/method_error.json" ()
504
+
505
+
let test_set_error () =
506
+
test_decode_success "set_error" Error.set_error_jsont "error/valid/set_error.json" ()
507
+
508
+
let test_request_error () =
509
+
test_decode_success "request_error" Error.Request_error.jsont "error/valid/request_error.json" ()
510
+
511
+
let method_error_type_testable =
512
+
Alcotest.testable
513
+
(fun fmt t -> Format.pp_print_string fmt (Error.method_error_type_to_string t))
514
+
(=)
515
+
516
+
let test_method_error_values () =
517
+
let json = read_file "error/valid/method_error.json" in
518
+
match decode Error.method_error_jsont json with
519
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
520
+
| Ok err ->
521
+
Alcotest.(check method_error_type_testable) "type" `Unknown_method err.type_
522
+
523
+
(* Additional error type tests *)
524
+
let test_set_error_forbidden () =
525
+
test_decode_success "set_error_forbidden" Error.set_error_jsont "error/valid/set_error_forbidden.json" ()
526
+
527
+
let test_set_error_not_found () =
528
+
test_decode_success "set_error_not_found" Error.set_error_jsont "error/valid/set_error_not_found.json" ()
529
+
530
+
let test_set_error_invalid_properties () =
531
+
test_decode_success "set_error_invalid_properties" Error.set_error_jsont "error/valid/set_error_invalid_properties.json" ()
532
+
533
+
let test_set_error_singleton () =
534
+
test_decode_success "set_error_singleton" Error.set_error_jsont "error/valid/set_error_singleton.json" ()
535
+
536
+
let test_set_error_over_quota () =
537
+
test_decode_success "set_error_over_quota" Error.set_error_jsont "error/valid/set_error_over_quota.json" ()
538
+
539
+
let test_method_error_invalid_arguments () =
540
+
test_decode_success "method_error_invalid_arguments" Error.method_error_jsont "error/valid/method_error_invalid_arguments.json" ()
541
+
542
+
let test_method_error_server_fail () =
543
+
test_decode_success "method_error_server_fail" Error.method_error_jsont "error/valid/method_error_server_fail.json" ()
544
+
545
+
let test_method_error_account_not_found () =
546
+
test_decode_success "method_error_account_not_found" Error.method_error_jsont "error/valid/method_error_account_not_found.json" ()
547
+
548
+
let test_method_error_forbidden () =
549
+
test_decode_success "method_error_forbidden" Error.method_error_jsont "error/valid/method_error_forbidden.json" ()
550
+
551
+
let test_method_error_account_read_only () =
552
+
test_decode_success "method_error_account_read_only" Error.method_error_jsont "error/valid/method_error_account_read_only.json" ()
553
+
554
+
let test_request_error_not_json () =
555
+
test_decode_success "request_error_not_json" Error.Request_error.jsont "error/valid/request_error_not_json.json" ()
556
+
557
+
let test_request_error_limit () =
558
+
test_decode_success "request_error_limit" Error.Request_error.jsont "error/valid/request_error_limit.json" ()
559
+
560
+
let set_error_type_testable =
561
+
Alcotest.testable
562
+
(fun fmt t -> Format.pp_print_string fmt (Error.set_error_type_to_string t))
563
+
(=)
564
+
565
+
let test_set_error_types () =
566
+
let json = read_file "error/valid/set_error_invalid_properties.json" in
567
+
match decode Error.set_error_jsont json with
568
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
569
+
| Ok err ->
570
+
Alcotest.(check set_error_type_testable) "type" `Invalid_properties err.Error.type_;
571
+
match err.Error.properties with
572
+
| None -> Alcotest.fail "expected properties"
573
+
| Some props -> Alcotest.(check int) "properties count" 2 (List.length props)
574
+
575
+
let tests = [
576
+
"valid: method_error", `Quick, test_method_error;
577
+
"valid: set_error", `Quick, test_set_error;
578
+
"valid: request_error", `Quick, test_request_error;
579
+
"valid: set_error forbidden", `Quick, test_set_error_forbidden;
580
+
"valid: set_error notFound", `Quick, test_set_error_not_found;
581
+
"valid: set_error invalidProperties", `Quick, test_set_error_invalid_properties;
582
+
"valid: set_error singleton", `Quick, test_set_error_singleton;
583
+
"valid: set_error overQuota", `Quick, test_set_error_over_quota;
584
+
"valid: method_error invalidArguments", `Quick, test_method_error_invalid_arguments;
585
+
"valid: method_error serverFail", `Quick, test_method_error_server_fail;
586
+
"valid: method_error accountNotFound", `Quick, test_method_error_account_not_found;
587
+
"valid: method_error forbidden", `Quick, test_method_error_forbidden;
588
+
"valid: method_error accountReadOnly", `Quick, test_method_error_account_read_only;
589
+
"valid: request_error notJSON", `Quick, test_request_error_not_json;
590
+
"valid: request_error limit", `Quick, test_request_error_limit;
591
+
"values: method_error", `Quick, test_method_error_values;
592
+
"values: set_error types", `Quick, test_set_error_types;
593
+
]
594
+
end
595
+
596
+
(* Mailbox tests *)
597
+
module Mailbox_tests = struct
598
+
open Jmap.Proto
599
+
600
+
let role_testable =
601
+
Alcotest.testable
602
+
(fun fmt t -> Format.pp_print_string fmt (Mailbox.role_to_string t))
603
+
(=)
604
+
605
+
let test_simple () =
606
+
test_decode_success "simple" Mailbox.jsont "mail/mailbox/valid/simple.json" ()
607
+
608
+
let test_nested () =
609
+
test_decode_success "nested" Mailbox.jsont "mail/mailbox/valid/nested.json" ()
610
+
611
+
let test_values () =
612
+
let json = read_file "mail/mailbox/valid/simple.json" in
613
+
match decode Mailbox.jsont json with
614
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
615
+
| Ok 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))
621
+
622
+
let test_roundtrip () =
623
+
test_roundtrip "simple roundtrip" Mailbox.jsont "mail/mailbox/valid/simple.json" ()
624
+
625
+
let test_with_all_roles () =
626
+
test_decode_success "with all roles" Mailbox.jsont "mail/mailbox/valid/with_all_roles.json" ()
627
+
628
+
let test_all_rights_false () =
629
+
test_decode_success "all rights false" Mailbox.jsont "mail/mailbox/edge/all_rights_false.json" ()
630
+
631
+
let test_roles_values () =
632
+
let json = read_file "mail/mailbox/valid/with_all_roles.json" in
633
+
match decode Mailbox.jsont json with
634
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
635
+
| Ok 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))
638
+
639
+
let tests = [
640
+
"valid: simple", `Quick, test_simple;
641
+
"valid: nested", `Quick, test_nested;
642
+
"valid: with all roles", `Quick, test_with_all_roles;
643
+
"edge: all rights false", `Quick, test_all_rights_false;
644
+
"values: simple", `Quick, test_values;
645
+
"values: roles", `Quick, test_roles_values;
646
+
"roundtrip: simple", `Quick, test_roundtrip;
647
+
]
648
+
end
649
+
650
+
(* Email tests *)
651
+
module Email_tests = struct
652
+
open Jmap.Proto
653
+
654
+
let test_minimal () =
655
+
test_decode_success "minimal" Email.jsont "mail/email/valid/minimal.json" ()
656
+
657
+
let test_full () =
658
+
test_decode_success "full" Email.jsont "mail/email/valid/full.json" ()
659
+
660
+
let test_with_headers () =
661
+
test_decode_success "with_headers" Email.jsont "mail/email/valid/with_headers.json" ()
662
+
663
+
let test_minimal_values () =
664
+
let json = read_file "mail/email/valid/minimal.json" in
665
+
match decode Email.jsont json with
666
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
667
+
| Ok 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))
671
+
672
+
let test_full_values () =
673
+
let json = read_file "mail/email/valid/full.json" in
674
+
match decode Email.jsont json with
675
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
676
+
| Ok email ->
677
+
Alcotest.(check (option string)) "subject" (Some "Re: Important meeting") (Email.subject email);
678
+
Alcotest.(check bool) "hasAttachment" true (get_bool (Email.has_attachment email));
679
+
(* Check from address *)
680
+
match Email.from email with
681
+
| None -> Alcotest.fail "expected from address"
682
+
| Some addrs ->
683
+
Alcotest.(check int) "from count" 1 (List.length addrs);
684
+
let addr = List.hd addrs in
685
+
Alcotest.(check (option string)) "from name" (Some "Alice Smith") (Email_address.name addr);
686
+
Alcotest.(check string) "from email" "alice@example.com" (Email_address.email addr)
687
+
688
+
let test_with_keywords () =
689
+
test_decode_success "with keywords" Email.jsont "mail/email/valid/with_keywords.json" ()
690
+
691
+
let test_multiple_mailboxes () =
692
+
test_decode_success "multiple mailboxes" Email.jsont "mail/email/valid/multiple_mailboxes.json" ()
693
+
694
+
let test_draft_email () =
695
+
test_decode_success "draft email" Email.jsont "mail/email/valid/draft_email.json" ()
696
+
697
+
let test_with_all_system_keywords () =
698
+
test_decode_success "all system keywords" Email.jsont "mail/email/valid/with_all_system_keywords.json" ()
699
+
700
+
let test_empty_keywords () =
701
+
test_decode_success "empty keywords" Email.jsont "mail/email/edge/empty_keywords.json" ()
702
+
703
+
let test_with_message_ids () =
704
+
test_decode_success "with message ids" Email.jsont "mail/email/valid/with_message_ids.json" ()
705
+
706
+
let test_keywords_values () =
707
+
let json = read_file "mail/email/valid/with_keywords.json" in
708
+
match decode Email.jsont json with
709
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
710
+
| Ok email ->
711
+
let keywords = Option.value ~default:[] (Email.keywords email) in
712
+
Alcotest.(check int) "keywords count" 3 (List.length keywords);
713
+
Alcotest.(check bool) "$seen present" true (List.mem_assoc "$seen" keywords);
714
+
Alcotest.(check bool) "$flagged present" true (List.mem_assoc "$flagged" keywords)
715
+
716
+
let test_mailbox_ids_values () =
717
+
let json = read_file "mail/email/valid/multiple_mailboxes.json" in
718
+
match decode Email.jsont json with
719
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
720
+
| Ok email ->
721
+
let mailbox_ids = Option.value ~default:[] (Email.mailbox_ids email) in
722
+
Alcotest.(check int) "mailboxIds count" 3 (List.length mailbox_ids)
723
+
724
+
let tests = [
725
+
"valid: minimal", `Quick, test_minimal;
726
+
"valid: full", `Quick, test_full;
727
+
"valid: with_headers", `Quick, test_with_headers;
728
+
"valid: with keywords", `Quick, test_with_keywords;
729
+
"valid: multiple mailboxes", `Quick, test_multiple_mailboxes;
730
+
"valid: draft email", `Quick, test_draft_email;
731
+
"valid: all system keywords", `Quick, test_with_all_system_keywords;
732
+
"valid: with message ids", `Quick, test_with_message_ids;
733
+
"edge: empty keywords", `Quick, test_empty_keywords;
734
+
"values: minimal", `Quick, test_minimal_values;
735
+
"values: full", `Quick, test_full_values;
736
+
"values: keywords", `Quick, test_keywords_values;
737
+
"values: mailboxIds", `Quick, test_mailbox_ids_values;
738
+
]
739
+
end
740
+
741
+
(* Thread tests *)
742
+
module Thread_tests = struct
743
+
open Jmap.Proto
744
+
745
+
let test_simple () =
746
+
test_decode_success "simple" Thread.jsont "mail/thread/valid/simple.json" ()
747
+
748
+
let test_conversation () =
749
+
test_decode_success "conversation" Thread.jsont "mail/thread/valid/conversation.json" ()
750
+
751
+
let test_values () =
752
+
let json = read_file "mail/thread/valid/conversation.json" in
753
+
match decode Thread.jsont json with
754
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
755
+
| Ok 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)))
758
+
759
+
let tests = [
760
+
"valid: simple", `Quick, test_simple;
761
+
"valid: conversation", `Quick, test_conversation;
762
+
"values: conversation", `Quick, test_values;
763
+
]
764
+
end
765
+
766
+
(* Identity tests *)
767
+
module Identity_tests = struct
768
+
open Jmap.Proto
769
+
770
+
let test_simple () =
771
+
test_decode_success "simple" Identity.jsont "mail/identity/valid/simple.json" ()
772
+
773
+
let test_values () =
774
+
let json = read_file "mail/identity/valid/simple.json" in
775
+
match decode Identity.jsont json with
776
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
777
+
| Ok 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))
781
+
782
+
let tests = [
783
+
"valid: simple", `Quick, test_simple;
784
+
"values: simple", `Quick, test_values;
785
+
]
786
+
end
787
+
788
+
(* Email address tests *)
789
+
module Email_address_tests = struct
790
+
open Jmap.Proto
791
+
792
+
let test_full () =
793
+
test_decode_success "full" Email_address.jsont "mail/email_address/valid/full.json" ()
794
+
795
+
let test_email_only () =
796
+
test_decode_success "email_only" Email_address.jsont "mail/email_address/valid/email_only.json" ()
797
+
798
+
let test_full_values () =
799
+
let json = read_file "mail/email_address/valid/full.json" in
800
+
match decode Email_address.jsont json with
801
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
802
+
| Ok addr ->
803
+
Alcotest.(check (option string)) "name" (Some "John Doe") (Email_address.name addr);
804
+
Alcotest.(check string) "email" "john.doe@example.com" (Email_address.email addr)
805
+
806
+
let test_email_only_values () =
807
+
let json = read_file "mail/email_address/valid/email_only.json" in
808
+
match decode Email_address.jsont json with
809
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
810
+
| Ok addr ->
811
+
Alcotest.(check (option string)) "name" None (Email_address.name addr);
812
+
Alcotest.(check string) "email" "anonymous@example.com" (Email_address.email addr)
813
+
814
+
let tests = [
815
+
"valid: full", `Quick, test_full;
816
+
"valid: email_only", `Quick, test_email_only;
817
+
"values: full", `Quick, test_full_values;
818
+
"values: email_only", `Quick, test_email_only_values;
819
+
]
820
+
end
821
+
822
+
(* Vacation tests *)
823
+
module Vacation_tests = struct
824
+
open Jmap.Proto
825
+
826
+
let test_enabled () =
827
+
test_decode_success "enabled" Vacation.jsont "mail/vacation/valid/enabled.json" ()
828
+
829
+
let test_disabled () =
830
+
test_decode_success "disabled" Vacation.jsont "mail/vacation/valid/disabled.json" ()
831
+
832
+
let test_enabled_values () =
833
+
let json = read_file "mail/vacation/valid/enabled.json" in
834
+
match decode Vacation.jsont json with
835
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
836
+
| Ok vac ->
837
+
Alcotest.(check bool) "isEnabled" true (Vacation.is_enabled vac);
838
+
Alcotest.(check (option string)) "subject" (Some "Out of Office") (Vacation.subject vac)
839
+
840
+
let test_disabled_values () =
841
+
let json = read_file "mail/vacation/valid/disabled.json" in
842
+
match decode Vacation.jsont json with
843
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
844
+
| Ok vac ->
845
+
Alcotest.(check bool) "isEnabled" false (Vacation.is_enabled vac);
846
+
Alcotest.(check (option string)) "subject" None (Vacation.subject vac)
847
+
848
+
let tests = [
849
+
"valid: enabled", `Quick, test_enabled;
850
+
"valid: disabled", `Quick, test_disabled;
851
+
"values: enabled", `Quick, test_enabled_values;
852
+
"values: disabled", `Quick, test_disabled_values;
853
+
]
854
+
end
855
+
856
+
(* Comparator tests *)
857
+
module Comparator_tests = struct
858
+
open Jmap.Proto
859
+
860
+
let test_minimal () =
861
+
test_decode_success "minimal" Filter.comparator_jsont "filter/valid/comparator_minimal.json" ()
862
+
863
+
let test_descending () =
864
+
test_decode_success "descending" Filter.comparator_jsont "filter/valid/comparator_descending.json" ()
865
+
866
+
let test_with_collation () =
867
+
test_decode_success "with collation" Filter.comparator_jsont "filter/valid/comparator_with_collation.json" ()
868
+
869
+
let test_minimal_values () =
870
+
let json = read_file "filter/valid/comparator_minimal.json" in
871
+
match decode Filter.comparator_jsont json with
872
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
873
+
| Ok comp ->
874
+
Alcotest.(check string) "property" "size" (Filter.comparator_property comp);
875
+
Alcotest.(check bool) "isAscending" true (Filter.comparator_is_ascending comp);
876
+
Alcotest.(check (option string)) "collation" None (Filter.comparator_collation comp)
877
+
878
+
let test_collation_values () =
879
+
let json = read_file "filter/valid/comparator_with_collation.json" in
880
+
match decode Filter.comparator_jsont json with
881
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
882
+
| Ok comp ->
883
+
Alcotest.(check string) "property" "subject" (Filter.comparator_property comp);
884
+
Alcotest.(check (option string)) "collation" (Some "i;unicode-casemap") (Filter.comparator_collation comp)
885
+
886
+
let tests = [
887
+
"valid: minimal", `Quick, test_minimal;
888
+
"valid: descending", `Quick, test_descending;
889
+
"valid: with collation", `Quick, test_with_collation;
890
+
"values: minimal", `Quick, test_minimal_values;
891
+
"values: with collation", `Quick, test_collation_values;
892
+
]
893
+
end
894
+
895
+
(* EmailBody tests *)
896
+
module EmailBody_tests = struct
897
+
open Jmap.Proto
898
+
899
+
let test_text_part () =
900
+
test_decode_success "text part" Email_body.Part.jsont "mail/email_body/valid/text_part.json" ()
901
+
902
+
let test_multipart () =
903
+
test_decode_success "multipart" Email_body.Part.jsont "mail/email_body/valid/multipart.json" ()
904
+
905
+
let test_multipart_mixed () =
906
+
test_decode_success "multipart mixed" Email_body.Part.jsont "mail/email_body/valid/multipart_mixed.json" ()
907
+
908
+
let test_with_inline_image () =
909
+
test_decode_success "with inline image" Email_body.Part.jsont "mail/email_body/valid/with_inline_image.json" ()
910
+
911
+
let test_with_language () =
912
+
test_decode_success "with language" Email_body.Part.jsont "mail/email_body/valid/with_language.json" ()
913
+
914
+
let test_deep_nesting () =
915
+
test_decode_success "deep nesting" Email_body.Part.jsont "mail/email_body/edge/deep_nesting.json" ()
916
+
917
+
let test_multipart_values () =
918
+
let json = read_file "mail/email_body/valid/multipart.json" in
919
+
match decode Email_body.Part.jsont json with
920
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
921
+
| Ok part ->
922
+
Alcotest.(check (option string)) "partId" (Some "0") (Email_body.Part.part_id part);
923
+
Alcotest.(check string) "type" "multipart/alternative" (Email_body.Part.type_ part);
924
+
match Email_body.Part.sub_parts part with
925
+
| None -> Alcotest.fail "expected sub_parts"
926
+
| Some subs -> Alcotest.(check int) "sub_parts count" 2 (List.length subs)
927
+
928
+
let tests = [
929
+
"valid: text part", `Quick, test_text_part;
930
+
"valid: multipart", `Quick, test_multipart;
931
+
"valid: multipart mixed", `Quick, test_multipart_mixed;
932
+
"valid: with inline image", `Quick, test_with_inline_image;
933
+
"valid: with language", `Quick, test_with_language;
934
+
"edge: deep nesting", `Quick, test_deep_nesting;
935
+
"values: multipart", `Quick, test_multipart_values;
936
+
]
937
+
end
938
+
939
+
(* EmailSubmission tests *)
940
+
module EmailSubmission_tests = struct
941
+
open Jmap.Proto
942
+
943
+
let test_simple () =
944
+
test_decode_success "simple" Submission.jsont "mail/submission/valid/simple.json" ()
945
+
946
+
let test_with_envelope () =
947
+
test_decode_success "with envelope" Submission.jsont "mail/submission/valid/with_envelope.json" ()
948
+
949
+
let test_final_status () =
950
+
test_decode_success "final status" Submission.jsont "mail/submission/valid/final_status.json" ()
951
+
952
+
let test_simple_values () =
953
+
let json = read_file "mail/submission/valid/simple.json" in
954
+
match decode Submission.jsont json with
955
+
| Error e -> Alcotest.failf "decode failed: %s" (Jsont.Error.to_string e)
956
+
| Ok sub ->
957
+
Alcotest.(check string) "id" "sub1" (get_id (Submission.id sub));
958
+
(* Check undoStatus is Pending *)
959
+
match Submission.undo_status sub with
960
+
| Some `Pending -> ()
961
+
| _ -> Alcotest.fail "expected undoStatus to be pending"
962
+
963
+
let tests = [
964
+
"valid: simple", `Quick, test_simple;
965
+
"valid: with envelope", `Quick, test_with_envelope;
966
+
"valid: final status", `Quick, test_final_status;
967
+
"values: simple", `Quick, test_simple_values;
968
+
]
969
+
end
970
+
971
+
(* Run all tests *)
972
+
let () =
973
+
Alcotest.run "JMAP Proto Codecs" [
974
+
"Id", Id_tests.tests;
975
+
"Int53", Int53_tests.tests;
976
+
"Date", Date_tests.tests;
977
+
"Session", Session_tests.tests;
978
+
"Request", Request_tests.tests;
979
+
"Response", Response_tests.tests;
980
+
"Invocation", Invocation_tests.tests;
981
+
"Capability", Capability_tests.tests;
982
+
"Method", Method_tests.tests;
983
+
"Error", Error_tests.tests;
984
+
"Comparator", Comparator_tests.tests;
985
+
"Mailbox", Mailbox_tests.tests;
986
+
"Email", Email_tests.tests;
987
+
"EmailBody", EmailBody_tests.tests;
988
+
"Thread", Thread_tests.tests;
989
+
"Identity", Identity_tests.tests;
990
+
"Email_address", Email_address_tests.tests;
991
+
"EmailSubmission", EmailSubmission_tests.tests;
992
+
"Vacation", Vacation_tests.tests;
993
+
]
+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