anil.recoil.org
+22
-1
.gitignore
+22
-1
.gitignore
···
1
-
_build
1
+
# OCaml build artifacts
2
+
_build/
3
+
*.install
4
+
*.merlin
5
+
6
+
# Third-party sources (fetch locally with opam source)
7
+
third_party/
8
+
9
+
# Editor and OS files
10
+
.DS_Store
11
+
*.swp
12
+
*~
13
+
.vscode/
14
+
.idea/
15
+
16
+
# Opam local switch
17
+
_opam/
18
+
19
+
# Environment and secrets
2
20
.env
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
-73
AGENT.md
-73
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. If you
17
-
only partially complete the task, then add an extra step with TODO and the remaining
18
-
work.
19
-
20
-
1. DONE Define core OCaml type definitions corresponding to the JMAP protocol
21
-
specification, in a new Jmap.Types module.
22
-
2. DONE Add a `Jmap.Api` module to make JMAP API requests over HTTP and parse the
23
-
responses into the `Jmap.Types`. Used `Cohttp_lwt_unix` for the HTTP library.
24
-
Note: There is a compilation issue with the current ezjsonm package on the system.
25
-
3. DONE Add a `Jmap_mail` implementation that follows `spec/rfc8621.txt` as part of a
26
-
separate package. It should use the Jmap module and extend it appropriately.
27
-
4. DONE Complete the `Jmap_mail` implementation so that there are functions to login
28
-
and list mailboxes and messages in a mailbox.
29
-
5. DONE Fastmail provides me with an API token to login via JMAP rather than username
30
-
and password. Add the appropriate support for this into their API, which is
31
-
also explained over at https://www.fastmail.com/dev/. The summary is that the
32
-
auth token needs to add an Authorization header set to "Bearer {value}",
33
-
where {value} is the value of the token to your API request.
34
-
6. DONE Add an example `fastmail_list` binary that will use the authentication token
35
-
from a `JMAP_API_TOKEN` env variable and connect to the Fastmail endpoint
36
-
at https://api.fastmail.com/jmap/session and list the last 100 email with
37
-
subjects and sender details to stdout.
38
-
7. DONE Examine the implementation of fastmail-list as well as the JMAP specs,
39
-
and add better typed handling of string responses such as "urn:ietf:params:jmap:mail".
40
-
Add these to either `Jmap_mail` or Jmap modules as appropriate.
41
-
8. DONE Move some of the debug print messages into a debug logging mode, and ensure
42
-
that sensitive API tokens are never printed but redacted instead.
43
-
Modify the fastmail-list binary to optionally list only unread messages, and
44
-
also list the JMAP labels associated with each message.
45
-
9. DONE Read the mailbox attribute spec in specs/ and add a typed interface to the
46
-
JMAP labels defined in there.
47
-
10. DONE Integrate the human-readable keyword and label printing into fastmail-list.
48
-
11. DONE Add an OCaml interface to compose result references together explicitly into a
49
-
single request, from reading the specs.
50
-
12. DONE Extend the fastmail-list to filter messages displays by email address of the
51
-
sender. This may involve adding logic to parse email addresses; if so, add
52
-
this logic into the Jmap_mail library.
53
-
13. DONE Refine the ocamldoc in the interfaces to include documentation for every record
54
-
field and function by summarising the relevant part of the spec. Also include
55
-
a cross reference URL where relevant by linking to a URL of the form
56
-
"https://datatracker.ietf.org/doc/html/rfc8620#section-1.1" for the online
57
-
version of the RFCs stored in specs/
58
-
14. DONE Add an ocamldoc-format tutorial on how to use the library to index.mld along with cross references
59
-
into the various libraries. Put corresponding executable files into bin/ so that they can be
60
-
build tested and run as well. Assume the pattern of the JMAP_API_TOKEN environment variable being
61
-
set can be counted on to be present when they are run.
62
-
15. DONE Add a README.md to this repository that describes what this is. Note explicitly in the
63
-
README that this is largely an AI-generated interface and has not been audited carefully.
64
-
16. DONE Ensure examples use the proper higher-level API functions from the library instead of
65
-
manually constructing low-level requests. Particularly, the fastmail_list binary should
66
-
demonstrate the recommended way to use the library with Jmap_mail's API.
67
-
17. DONE Add helper functions to Jmap.Api such as `string_of_error` and `pp_error` to format
68
-
errors consistently. Updated the fastmail_list binary to use these functions instead of
69
-
duplicating error handling code.
70
-
18. DONE Add support for JMAP email submission to the library, and create a fastmail-send that accepts
71
-
a list of to: on the CLI as arguments and a subject on the CLI and reads in the message body
72
-
19. DONE Port fastmail-list to use Cmdliner instead of Arg with nice manual page.
73
-
20. Make JMAP_TOKEN_API handling a Cmdliner term as well so it can be reused.
+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.
+32
-49
README.md
+32
-49
README.md
···
1
-
# JMAP OCaml Client
1
+
# ocaml-jmap - JMAP Protocol Implementation for OCaml
2
2
3
-
An OCaml interface to the JMAP protocol ([RFC8620](https://datatracker.ietf.org/doc/html/rfc8620)) and JMAP Mail extension ([RFC8621](https://datatracker.ietf.org/doc/html/rfc8621)).
3
+
A complete implementation of the JSON Meta Application Protocol (JMAP) as specified in RFC 8620 (core) and RFC 8621 (mail).
4
4
5
-
**Note:** This library is largely AI-generated and has not been audited carefully. It's a proof-of-concept implementation of the JMAP specification.
5
+
## Packages
6
6
7
-
## Overview
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
8
10
9
-
JMAP (JSON Meta Application Protocol) is a modern protocol for synchronizing email, calendars, and contacts designed as a replacement for legacy protocols like IMAP. This OCaml implementation provides:
11
+
## Key Features
10
12
11
-
- Type-safe OCaml interfaces to the JMAP Core and Mail specifications
12
-
- Authentication with username/password or API tokens (Fastmail support)
13
-
- Convenient functions for common email and mailbox operations
14
-
- Support for composing complex multi-part requests with result references
15
-
- Typed handling of message flags, keywords, and mailbox attributes
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
16
18
17
-
## Installation
19
+
## Usage
18
20
19
-
Add to your project with opam:
21
+
```ocaml
22
+
(* Query emails from a mailbox *)
23
+
open Jmap
20
24
21
-
```
22
-
opam install .
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
23
29
```
24
30
25
-
## Features
31
+
## Installation
26
32
27
-
- **Core JMAP Protocol**
28
-
- Session handling
29
-
- API request/response management
30
-
- Type-safe representation of all JMAP structures
31
-
- Result references for composing multi-step requests
33
+
```
34
+
opam install jmap jmap-eio
35
+
```
32
36
33
-
- **JMAP Mail Extension**
34
-
- Mailbox operations (folders/labels)
35
-
- Email retrieval and manipulation
36
-
- Thread handling
37
-
- Identity management
38
-
- Email submission
39
-
- Message flags and keywords
37
+
For browser-based applications:
40
38
41
-
- **Fastmail Integration**
42
-
- API token authentication
43
-
- Example tools for listing messages
39
+
```
40
+
opam install jmap jmap-brr
41
+
```
44
42
45
43
## Documentation
46
44
47
-
The library includes comprehensive OCamldoc documentation with cross-references to the relevant sections of the JMAP specifications.
48
-
49
-
Build the documentation with:
45
+
API documentation is available via:
50
46
51
47
```
52
-
dune build @doc
48
+
opam install jmap
49
+
odig doc jmap
53
50
```
54
51
55
-
## Example Tools
56
-
57
-
The package includes several example tools:
58
-
59
-
- `fastmail-list`: Lists emails from a Fastmail account (requires JMAP_API_TOKEN)
60
-
- `jmap-tutorial-examples`: Demonstrates basic JMAP operations as shown in the tutorial
61
-
62
52
## License
63
53
64
-
[MIT License](LICENSE)
65
-
66
-
## References
67
-
68
-
- [RFC8620: The JSON Meta Application Protocol (JMAP)](https://datatracker.ietf.org/doc/html/rfc8620)
69
-
- [RFC8621: The JSON Meta Application Protocol (JMAP) for Mail](https://datatracker.ietf.org/doc/html/rfc8621)
70
-
- [Message Flag and Mailbox Attribute Extension](https://datatracker.ietf.org/doc/html/draft-ietf-mailmaint-messageflag-mailboxattribute-02)
71
-
- [Fastmail Developer Documentation](https://www.fastmail.com/dev/)
54
+
ISC
+10
-22
bin/dune
+10
-22
bin/dune
···
1
1
(executable
2
-
(name fastmail_list)
3
-
(public_name fastmail-list)
4
-
(package jmap)
5
-
(modules fastmail_list)
6
-
(libraries jmap jmap_mail lwt.unix logs logs.fmt cmdliner))
7
-
8
-
(executable
9
-
(name flag_color_test)
10
-
(public_name flag-color-test)
11
-
(package jmap)
12
-
(modules flag_color_test)
13
-
(libraries jmap jmap_mail))
14
-
15
-
(executable
16
-
(name tutorial_examples)
17
-
(public_name jmap-tutorial-examples)
2
+
(name jmap)
3
+
(public_name jmap)
18
4
(package jmap)
19
-
(modules tutorial_examples)
20
-
(libraries jmap jmap_mail))
5
+
(optional)
6
+
(modules jmap)
7
+
(libraries jmap.eio eio_main))
21
8
22
9
(executable
23
-
(name fastmail_send)
24
-
(public_name fastmail-send)
10
+
(name jmapq)
11
+
(public_name jmapq)
25
12
(package jmap)
26
-
(modules fastmail_send)
27
-
(libraries jmap jmap_mail lwt.unix cmdliner fmt))
13
+
(optional)
14
+
(modules jmapq)
15
+
(libraries jmap.eio eio_main re jsont.bytesrw))
+8
-8
bin/fastmail_list.ml
+8
-8
bin/fastmail_list.ml
···
18
18
19
19
open Lwt.Syntax
20
20
open Jmap
21
-
open Jmap_mail
21
+
open Jmap.Mail
22
22
open Cmdliner
23
-
module Mail = Jmap_mail.Types
23
+
module Mail = Jmap.Proto.Types
24
24
25
25
(** Prints the email details *)
26
26
let print_email ~show_labels (email : Mail.email) =
···
42
42
(* Format labels/keywords if requested *)
43
43
let labels_str =
44
44
if show_labels then
45
-
let formatted = Jmap_mail.Types.format_email_keywords email.keywords in
45
+
let formatted = Jmap.Proto.Types.format_email_keywords email.keywords in
46
46
if formatted <> "" then
47
47
" [" ^ formatted ^ "]"
48
48
else
···
73
73
Printf.printf "=====================\n";
74
74
75
75
(* Step 1: Get all mailboxes *)
76
-
let* mailboxes_result = Jmap_mail.get_mailboxes conn ~account_id in
76
+
let* mailboxes_result = Jmap.Proto.get_mailboxes conn ~account_id in
77
77
match mailboxes_result with
78
78
| Error err ->
79
79
Printf.printf "Error getting mailboxes: %s\n" (Api.string_of_error err);
···
90
90
Printf.printf "Using mailbox: %s\n" first_mailbox.Mail.name;
91
91
92
92
(* Step 3: Get emails from the selected mailbox *)
93
-
let* emails_result = Jmap_mail.get_messages_in_mailbox
93
+
let* emails_result = Jmap.Proto.get_messages_in_mailbox
94
94
conn
95
95
~account_id
96
96
~mailbox_id:first_mailbox.Mail.id
···
108
108
(List.length emails);
109
109
110
110
(* Display some basic information about the emails *)
111
-
List.iteri (fun i (email:Jmap_mail.Types.email) ->
111
+
List.iteri (fun i (email:Jmap.Proto.Types.email) ->
112
112
let subject = Option.value ~default:"<no subject>" email.Mail.subject in
113
113
Printf.printf " %d. %s\n" (i + 1) subject
114
114
) emails;
···
159
159
| Ok conn ->
160
160
(* Get the primary account ID *)
161
161
let primary_account_id =
162
-
let mail_capability = Jmap_mail.Capability.to_string Jmap_mail.Capability.Mail in
162
+
let mail_capability = Jmap.Proto.Capability.to_string Jmap.Proto.Capability.Mail in
163
163
match List.assoc_opt mail_capability conn.session.primary_accounts with
164
164
| Some id -> id
165
165
| None ->
···
220
220
if sender_filter <> "" then begin
221
221
Printf.printf "Filtering by sender: %s\n" sender_filter;
222
222
List.filter (fun email ->
223
-
Jmap_mail.email_matches_sender email sender_filter
223
+
Jmap.Proto.email_matches_sender email sender_filter
224
224
) filtered_by_unread
225
225
end else
226
226
filtered_by_unread
+7
-7
bin/fastmail_send.ml
+7
-7
bin/fastmail_send.ml
···
52
52
(* Initialize JMAP connection *)
53
53
let fastmail_uri = "https://api.fastmail.com/jmap/session" in
54
54
Lwt_main.run begin
55
-
let* conn_result = Jmap_mail.login_with_token ~uri:fastmail_uri ~api_token:token in
55
+
let* conn_result = Jmap.Proto.login_with_token ~uri:fastmail_uri ~api_token:token in
56
56
match conn_result with
57
57
| Error err ->
58
58
let msg = Jmap.Api.string_of_error err in
···
78
78
| Some email -> Lwt.return_ok email
79
79
| None ->
80
80
(* Get first available identity *)
81
-
let* identities_result = Jmap_mail.get_identities conn ~account_id in
81
+
let* identities_result = Jmap.Proto.get_identities conn ~account_id in
82
82
match identities_result with
83
83
| Ok [] ->
84
84
log_error "No identities found for account";
···
99
99
(String.concat ", " to_addresses);
100
100
101
101
let* submission_result =
102
-
Jmap_mail.create_and_submit_email
102
+
Jmap.Proto.create_and_submit_email
103
103
conn
104
104
~account_id
105
105
~from:from_email
···
118
118
log_success "Email sent successfully (Submission ID: %s)" submission_id;
119
119
(* Wait briefly then check submission status *)
120
120
let* () = Lwt_unix.sleep 1.0 in
121
-
let* status_result = Jmap_mail.get_submission_status
121
+
let* status_result = Jmap.Proto.get_submission_status
122
122
conn
123
123
~account_id
124
124
~submission_id
···
126
126
127
127
(match status_result with
128
128
| Ok status ->
129
-
let status_text = match status.Jmap_mail.Types.undo_status with
129
+
let status_text = match status.Jmap.Proto.Types.undo_status with
130
130
| Some `pending -> "Pending"
131
131
| Some `final -> "Final (delivered)"
132
132
| Some `canceled -> "Canceled"
···
134
134
in
135
135
log_info "Submission status: %s" status_text;
136
136
137
-
(match status.Jmap_mail.Types.delivery_status with
137
+
(match status.Jmap.Proto.Types.delivery_status with
138
138
| Some statuses ->
139
139
List.iter (fun (email, status) ->
140
-
let delivery = match status.Jmap_mail.Types.delivered with
140
+
let delivery = match status.Jmap.Proto.Types.delivered with
141
141
| Some "yes" -> "Delivered"
142
142
| Some "no" -> "Failed"
143
143
| Some "queued" -> "Queued"
-114
bin/flag_color_test.ml
-114
bin/flag_color_test.ml
···
1
-
(** Demo of message flags and mailbox attributes functionality *)
2
-
3
-
open Jmap_mail.Types
4
-
5
-
(** Demonstrate flag color functionality *)
6
-
let demo_flag_colors () =
7
-
Printf.printf "Flag Color Demo:\n";
8
-
Printf.printf "================\n";
9
-
10
-
(* Show all flag colors and their bit patterns *)
11
-
let colors = [Red; Orange; Yellow; Green; Blue; Purple; Gray] in
12
-
List.iter (fun color ->
13
-
let (bit0, bit1, bit2) = bits_of_flag_color color in
14
-
Printf.printf "Color: %-7s Bits: %d%d%d\n"
15
-
(match color with
16
-
| Red -> "Red"
17
-
| Orange -> "Orange"
18
-
| Yellow -> "Yellow"
19
-
| Green -> "Green"
20
-
| Blue -> "Blue"
21
-
| Purple -> "Purple"
22
-
| Gray -> "Gray")
23
-
(if bit0 then 1 else 0)
24
-
(if bit1 then 1 else 0)
25
-
(if bit2 then 1 else 0)
26
-
) colors;
27
-
28
-
Printf.printf "\n"
29
-
30
-
(** Demonstrate message keyword functionality *)
31
-
let demo_message_keywords () =
32
-
Printf.printf "Message Keywords Demo:\n";
33
-
Printf.printf "=====================\n";
34
-
35
-
(* Show all standard message keywords and their string representations *)
36
-
let keywords = [
37
-
Notify; Muted; Followed; Memo; HasMemo; HasAttachment; HasNoAttachment;
38
-
AutoSent; Unsubscribed; CanUnsubscribe; Imported; IsTrusted;
39
-
MaskedEmail; New; MailFlagBit0; MailFlagBit1; MailFlagBit2
40
-
] in
41
-
42
-
List.iter (fun kw ->
43
-
Printf.printf "%-15s -> %s\n"
44
-
(match kw with
45
-
| Notify -> "Notify"
46
-
| Muted -> "Muted"
47
-
| Followed -> "Followed"
48
-
| Memo -> "Memo"
49
-
| HasMemo -> "HasMemo"
50
-
| HasAttachment -> "HasAttachment"
51
-
| HasNoAttachment -> "HasNoAttachment"
52
-
| AutoSent -> "AutoSent"
53
-
| Unsubscribed -> "Unsubscribed"
54
-
| CanUnsubscribe -> "CanUnsubscribe"
55
-
| Imported -> "Imported"
56
-
| IsTrusted -> "IsTrusted"
57
-
| MaskedEmail -> "MaskedEmail"
58
-
| New -> "New"
59
-
| MailFlagBit0 -> "MailFlagBit0"
60
-
| MailFlagBit1 -> "MailFlagBit1"
61
-
| MailFlagBit2 -> "MailFlagBit2"
62
-
| OtherKeyword s -> "Other: " ^ s)
63
-
(string_of_message_keyword kw)
64
-
) keywords;
65
-
66
-
Printf.printf "\n"
67
-
68
-
(** Demonstrate mailbox attribute functionality *)
69
-
let demo_mailbox_attributes () =
70
-
Printf.printf "Mailbox Attributes Demo:\n";
71
-
Printf.printf "=======================\n";
72
-
73
-
(* Show all standard mailbox attributes and their string representations *)
74
-
let attributes = [Snoozed; Scheduled; Memos] in
75
-
76
-
List.iter (fun attr ->
77
-
Printf.printf "%-10s -> %s\n"
78
-
(match attr with
79
-
| Snoozed -> "Snoozed"
80
-
| Scheduled -> "Scheduled"
81
-
| Memos -> "Memos"
82
-
| OtherAttribute s -> "Other: " ^ s)
83
-
(string_of_mailbox_attribute attr)
84
-
) attributes;
85
-
86
-
Printf.printf "\n"
87
-
88
-
(** Demonstrate formatting functionality *)
89
-
let demo_formatting () =
90
-
Printf.printf "Keyword Formatting Demo:\n";
91
-
Printf.printf "======================\n";
92
-
93
-
(* Create a sample email with various keywords *)
94
-
let sample_keywords = [
95
-
(Flagged, true); (* Standard flag *)
96
-
(Custom "$MailFlagBit0", true); (* Flag color bit *)
97
-
(Custom "$MailFlagBit2", true); (* Flag color bit *)
98
-
(Custom "$notify", true); (* Message keyword *)
99
-
(Custom "$followed", true); (* Message keyword *)
100
-
(Custom "$hasattachment", true); (* Message keyword *)
101
-
(Seen, false); (* Inactive keyword *)
102
-
(Custom "$random", true); (* Unknown keyword *)
103
-
] in
104
-
105
-
(* Test formatted output *)
106
-
let formatted = format_email_keywords sample_keywords in
107
-
Printf.printf "Formatted keywords: %s\n\n" formatted
108
-
109
-
(** Main entry point *)
110
-
let () =
111
-
demo_flag_colors ();
112
-
demo_message_keywords ();
113
-
demo_mailbox_attributes ();
114
-
demo_formatting ()
+1552
bin/jmap.ml
+1552
bin/jmap.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAP command-line client *)
7
+
8
+
open Cmdliner
9
+
10
+
(** {1 Helpers} *)
11
+
12
+
let ptime_to_string t =
13
+
let (y, m, d), ((hh, mm, ss), _tz) = Ptime.to_date_time t in
14
+
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" y m d hh mm ss
15
+
16
+
let truncate_string max_len s =
17
+
if String.length s <= max_len then s
18
+
else String.sub s 0 (max_len - 3) ^ "..."
19
+
20
+
let format_email_address (addr : Jmap.Proto.Email_address.t) =
21
+
match addr.name with
22
+
| Some name -> Printf.sprintf "%s <%s>" name addr.email
23
+
| None -> addr.email
24
+
25
+
let format_email_addresses addrs =
26
+
String.concat ", " (List.map format_email_address addrs)
27
+
28
+
let format_keywords keywords =
29
+
keywords
30
+
|> List.filter_map (fun (k, v) -> if v then Some k else None)
31
+
|> String.concat " "
32
+
33
+
(* Helpers for optional Email fields *)
34
+
let email_id (e : Jmap.Proto.Email.t) =
35
+
match e.id with Some id -> Jmap.Proto.Id.to_string id | None -> "?"
36
+
37
+
let email_received_at (e : Jmap.Proto.Email.t) =
38
+
match e.received_at with Some t -> ptime_to_string t | None -> "?"
39
+
40
+
let email_keywords (e : Jmap.Proto.Email.t) =
41
+
Option.value ~default:[] e.keywords
42
+
43
+
let email_preview (e : Jmap.Proto.Email.t) =
44
+
Option.value ~default:"" e.preview
45
+
46
+
let email_thread_id (e : Jmap.Proto.Email.t) =
47
+
match e.thread_id with Some id -> Jmap.Proto.Id.to_string id | None -> "?"
48
+
49
+
let email_size (e : Jmap.Proto.Email.t) =
50
+
Option.value ~default:0L e.size
51
+
52
+
let email_mailbox_ids (e : Jmap.Proto.Email.t) =
53
+
Option.value ~default:[] e.mailbox_ids
54
+
55
+
(** {1 Session Command} *)
56
+
57
+
let session_cmd =
58
+
let run cfg =
59
+
Eio_main.run @@ fun env ->
60
+
Eio.Switch.run @@ fun sw ->
61
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
62
+
let session = Jmap_eio.Client.session client in
63
+
64
+
Fmt.pr "@[<v>%a@," Fmt.(styled `Bold string) "Session Information:";
65
+
Fmt.pr " Username: %a@," Fmt.(styled `Green string) session.username;
66
+
Fmt.pr " State: %s@," session.state;
67
+
Fmt.pr " API URL: %s@," session.api_url;
68
+
Fmt.pr " Upload URL: %s@," session.upload_url;
69
+
Fmt.pr " Download URL: %s@," session.download_url;
70
+
Fmt.pr "@, %a@," Fmt.(styled `Bold string) "Capabilities:";
71
+
List.iter (fun (cap, _) ->
72
+
Fmt.pr " %s@," cap
73
+
) session.capabilities;
74
+
Fmt.pr "@, %a@," Fmt.(styled `Bold string) "Accounts:";
75
+
List.iter (fun (id, acct) ->
76
+
let acct : Jmap.Proto.Session.Account.t = acct in
77
+
Fmt.pr " %a: %s (personal=%b, read_only=%b)@,"
78
+
Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string id)
79
+
acct.name acct.is_personal acct.is_read_only
80
+
) session.accounts;
81
+
Fmt.pr "@, %a@," Fmt.(styled `Bold string) "Primary Accounts:";
82
+
List.iter (fun (cap, id) ->
83
+
Fmt.pr " %s: %s@," cap (Jmap.Proto.Id.to_string id)
84
+
) session.primary_accounts;
85
+
Fmt.pr "@]@."
86
+
in
87
+
let doc = "Show JMAP session information" in
88
+
let info = Cmd.info "session" ~doc in
89
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term)
90
+
91
+
(** {1 Mailboxes Command} *)
92
+
93
+
let mailboxes_cmd =
94
+
let run cfg =
95
+
Eio_main.run @@ fun env ->
96
+
Eio.Switch.run @@ fun sw ->
97
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
98
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
99
+
100
+
Jmap_eio.Cli.debug cfg "Fetching mailboxes for account %s" (Jmap.Proto.Id.to_string account_id);
101
+
102
+
let req = Jmap_eio.Client.Build.(
103
+
make_request
104
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
105
+
[mailbox_get ~call_id:"m1" ~account_id ()]
106
+
) in
107
+
108
+
match Jmap_eio.Client.request client req with
109
+
| Error e ->
110
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
111
+
exit 1
112
+
| Ok response ->
113
+
match Jmap_eio.Client.Parse.parse_mailbox_get ~call_id:"m1" response with
114
+
| Error e ->
115
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
116
+
exit 1
117
+
| Ok result ->
118
+
Fmt.pr "@[<v>%a (state: %s)@,@,"
119
+
Fmt.(styled `Bold string) "Mailboxes"
120
+
result.state;
121
+
(* Sort by sort_order then name *)
122
+
let sorted = List.sort (fun (a : Jmap.Proto.Mailbox.t) (b : Jmap.Proto.Mailbox.t) ->
123
+
let sort_a = Option.value ~default:0L a.sort_order in
124
+
let sort_b = Option.value ~default:0L b.sort_order in
125
+
let cmp = Int64.compare sort_a sort_b in
126
+
let name_a = Option.value ~default:"" a.name in
127
+
let name_b = Option.value ~default:"" b.name in
128
+
if cmp <> 0 then cmp else String.compare name_a name_b
129
+
) result.list in
130
+
List.iter (fun (mbox : Jmap.Proto.Mailbox.t) ->
131
+
let role_str = match mbox.role with
132
+
| Some role -> Printf.sprintf " [%s]" (Jmap.Proto.Mailbox.role_to_string role)
133
+
| None -> ""
134
+
in
135
+
let id_str = match mbox.id with
136
+
| Some id -> Jmap.Proto.Id.to_string id
137
+
| None -> "?"
138
+
in
139
+
let name = Option.value ~default:"(unnamed)" mbox.name in
140
+
let total = Option.value ~default:0L mbox.total_emails in
141
+
let unread = Option.value ~default:0L mbox.unread_emails in
142
+
Fmt.pr " %a %s%a (%Ld total, %Ld unread)@,"
143
+
Fmt.(styled `Cyan string) id_str
144
+
name
145
+
Fmt.(styled `Yellow string) role_str
146
+
total unread
147
+
) sorted;
148
+
Fmt.pr "@]@."
149
+
in
150
+
let doc = "List mailboxes" in
151
+
let info = Cmd.info "mailboxes" ~doc in
152
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term)
153
+
154
+
(** {1 Emails Command} *)
155
+
156
+
let emails_cmd =
157
+
let limit_term =
158
+
let doc = "Maximum number of emails to list" in
159
+
Arg.(value & opt int 20 & info ["limit"; "n"] ~docv:"N" ~doc)
160
+
in
161
+
let mailbox_term =
162
+
let doc = "Mailbox ID to filter by" in
163
+
Arg.(value & opt (some string) None & info ["mailbox"; "m"] ~docv:"ID" ~doc)
164
+
in
165
+
let run cfg limit mailbox_id_str =
166
+
Eio_main.run @@ fun env ->
167
+
Eio.Switch.run @@ fun sw ->
168
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
169
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
170
+
171
+
Jmap_eio.Cli.debug cfg "Querying emails with limit %d" limit;
172
+
173
+
(* Build filter if mailbox specified *)
174
+
let filter = match mailbox_id_str with
175
+
| Some id_str ->
176
+
let mailbox_id = Jmap.Proto.Id.of_string_exn id_str in
177
+
let cond : Jmap.Proto.Email.Filter_condition.t = {
178
+
in_mailbox = Some mailbox_id;
179
+
in_mailbox_other_than = None;
180
+
before = None; after = None;
181
+
min_size = None; max_size = None;
182
+
all_in_thread_have_keyword = None;
183
+
some_in_thread_have_keyword = None;
184
+
none_in_thread_have_keyword = None;
185
+
has_keyword = None; not_keyword = None;
186
+
has_attachment = None;
187
+
text = None; from = None; to_ = None;
188
+
cc = None; bcc = None; subject = None;
189
+
body = None; header = None;
190
+
} in
191
+
Some (Jmap.Proto.Filter.Condition cond)
192
+
| None -> None
193
+
in
194
+
195
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
196
+
let query_inv = Jmap_eio.Client.Build.email_query
197
+
~call_id:"q1"
198
+
~account_id
199
+
?filter
200
+
~sort
201
+
~limit:(Int64.of_int limit)
202
+
()
203
+
in
204
+
205
+
let req = Jmap_eio.Client.Build.(
206
+
make_request
207
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
208
+
[query_inv]
209
+
) in
210
+
211
+
match Jmap_eio.Client.request client req with
212
+
| Error e ->
213
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
214
+
exit 1
215
+
| Ok response ->
216
+
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
217
+
| Error e ->
218
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
219
+
exit 1
220
+
| Ok query_result ->
221
+
let email_ids = query_result.ids in
222
+
Jmap_eio.Cli.debug cfg "Found %d email IDs" (List.length email_ids);
223
+
224
+
if List.length email_ids = 0 then (
225
+
Fmt.pr "No emails found.@.";
226
+
) else (
227
+
(* Fetch email details *)
228
+
let get_inv = Jmap_eio.Client.Build.email_get
229
+
~call_id:"g1"
230
+
~account_id
231
+
~ids:email_ids
232
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
233
+
"size"; "receivedAt"; "subject"; "from"; "preview"]
234
+
()
235
+
in
236
+
let req2 = Jmap_eio.Client.Build.(
237
+
make_request
238
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
239
+
[get_inv]
240
+
) in
241
+
242
+
match Jmap_eio.Client.request client req2 with
243
+
| Error e ->
244
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
245
+
exit 1
246
+
| Ok response2 ->
247
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
248
+
| Error e ->
249
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
250
+
exit 1
251
+
| Ok get_result ->
252
+
Fmt.pr "@[<v>%a (showing %d of %s)@,@,"
253
+
Fmt.(styled `Bold string) "Emails"
254
+
(List.length get_result.list)
255
+
(match query_result.total with
256
+
| Some n -> Int64.to_string n
257
+
| None -> "?");
258
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
259
+
let from_str = match email.from with
260
+
| Some addrs -> format_email_addresses addrs
261
+
| None -> "(unknown)"
262
+
in
263
+
let subject = Option.value email.subject ~default:"(no subject)" in
264
+
let keywords = Option.value ~default:[] email.keywords in
265
+
let flags = format_keywords keywords in
266
+
let flag_str = if flags = "" then "" else " [" ^ flags ^ "]" in
267
+
let id_str = match email.id with
268
+
| Some id -> Jmap.Proto.Id.to_string id
269
+
| None -> "?"
270
+
in
271
+
let received = match email.received_at with
272
+
| Some t -> ptime_to_string t
273
+
| None -> "?"
274
+
in
275
+
let preview = Option.value ~default:"" email.preview in
276
+
Fmt.pr " %a %s@,"
277
+
Fmt.(styled `Cyan string) id_str
278
+
received;
279
+
Fmt.pr " From: %s@," (truncate_string 60 from_str);
280
+
Fmt.pr " Subject: %a%s@,"
281
+
Fmt.(styled `White string) (truncate_string 60 subject)
282
+
flag_str;
283
+
Fmt.pr " Preview: %s@,@,"
284
+
(truncate_string 70 preview);
285
+
) get_result.list;
286
+
Fmt.pr "@]@."
287
+
)
288
+
in
289
+
let doc = "List emails" in
290
+
let info = Cmd.info "emails" ~doc in
291
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ limit_term $ mailbox_term)
292
+
293
+
(** {1 Search Command} *)
294
+
295
+
let search_cmd =
296
+
let query_term =
297
+
let doc = "Search query text" in
298
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"QUERY" ~doc)
299
+
in
300
+
let limit_term =
301
+
let doc = "Maximum number of results" in
302
+
Arg.(value & opt int 20 & info ["limit"; "n"] ~docv:"N" ~doc)
303
+
in
304
+
let run cfg query limit =
305
+
Eio_main.run @@ fun env ->
306
+
Eio.Switch.run @@ fun sw ->
307
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
308
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
309
+
310
+
Jmap_eio.Cli.debug cfg "Searching for: %s" query;
311
+
312
+
(* Build text filter *)
313
+
let cond : Jmap.Proto.Email.Filter_condition.t = {
314
+
in_mailbox = None; in_mailbox_other_than = None;
315
+
before = None; after = None;
316
+
min_size = None; max_size = None;
317
+
all_in_thread_have_keyword = None;
318
+
some_in_thread_have_keyword = None;
319
+
none_in_thread_have_keyword = None;
320
+
has_keyword = None; not_keyword = None;
321
+
has_attachment = None;
322
+
text = Some query;
323
+
from = None; to_ = None;
324
+
cc = None; bcc = None; subject = None;
325
+
body = None; header = None;
326
+
} in
327
+
let filter = Jmap.Proto.Filter.Condition cond in
328
+
329
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
330
+
let query_inv = Jmap_eio.Client.Build.email_query
331
+
~call_id:"q1"
332
+
~account_id
333
+
~filter
334
+
~sort
335
+
~limit:(Int64.of_int limit)
336
+
()
337
+
in
338
+
339
+
let req = Jmap_eio.Client.Build.(
340
+
make_request
341
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
342
+
[query_inv]
343
+
) in
344
+
345
+
match Jmap_eio.Client.request client req with
346
+
| Error e ->
347
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
348
+
exit 1
349
+
| Ok response ->
350
+
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
351
+
| Error e ->
352
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
353
+
exit 1
354
+
| Ok query_result ->
355
+
let email_ids = query_result.ids in
356
+
357
+
if List.length email_ids = 0 then (
358
+
Fmt.pr "No emails found matching: %s@." query;
359
+
) else (
360
+
(* Fetch email details *)
361
+
let get_inv = Jmap_eio.Client.Build.email_get
362
+
~call_id:"g1"
363
+
~account_id
364
+
~ids:email_ids
365
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
366
+
"size"; "receivedAt"; "subject"; "from"; "preview"]
367
+
()
368
+
in
369
+
let req2 = Jmap_eio.Client.Build.(
370
+
make_request
371
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
372
+
[get_inv]
373
+
) in
374
+
375
+
match Jmap_eio.Client.request client req2 with
376
+
| Error e ->
377
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
378
+
exit 1
379
+
| Ok response2 ->
380
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
381
+
| Error e ->
382
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
383
+
exit 1
384
+
| Ok get_result ->
385
+
Fmt.pr "@[<v>%a for \"%s\" (%d results)@,@,"
386
+
Fmt.(styled `Bold string) "Search results"
387
+
query
388
+
(List.length get_result.list);
389
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
390
+
let from_str = match email.from with
391
+
| Some addrs -> format_email_addresses addrs
392
+
| None -> "(unknown)"
393
+
in
394
+
let subject = Option.value email.subject ~default:"(no subject)" in
395
+
let id_str = match email.id with
396
+
| Some id -> Jmap.Proto.Id.to_string id
397
+
| None -> "?"
398
+
in
399
+
let received = match email.received_at with
400
+
| Some t -> ptime_to_string t
401
+
| None -> "?"
402
+
in
403
+
let preview = Option.value ~default:"" email.preview in
404
+
Fmt.pr " %a %s@,"
405
+
Fmt.(styled `Cyan string) id_str
406
+
received;
407
+
Fmt.pr " From: %s@," (truncate_string 60 from_str);
408
+
Fmt.pr " Subject: %a@,"
409
+
Fmt.(styled `White string) (truncate_string 60 subject);
410
+
Fmt.pr " Preview: %s@,@,"
411
+
(truncate_string 70 preview);
412
+
) get_result.list;
413
+
Fmt.pr "@]@."
414
+
)
415
+
in
416
+
let doc = "Search emails by text" in
417
+
let info = Cmd.info "search" ~doc in
418
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ query_term $ limit_term)
419
+
420
+
(** {1 Recent Command - chains query + get for detailed listing} *)
421
+
422
+
let recent_cmd =
423
+
let limit_term =
424
+
let doc = "Number of recent emails to show (max 100)" in
425
+
Arg.(value & opt int 100 & info ["limit"; "n"] ~docv:"N" ~doc)
426
+
in
427
+
let format_term =
428
+
let doc = "Output format: table, compact, or detailed" in
429
+
Arg.(value & opt (enum ["table", `Table; "compact", `Compact; "detailed", `Detailed])
430
+
`Table & info ["format"; "f"] ~docv:"FORMAT" ~doc)
431
+
in
432
+
let run cfg limit format =
433
+
let limit = min limit 100 in
434
+
Eio_main.run @@ fun env ->
435
+
Eio.Switch.run @@ fun sw ->
436
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
437
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
438
+
439
+
Jmap_eio.Cli.debug cfg "Fetching %d most recent emails" limit;
440
+
441
+
(* Query for recent emails *)
442
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
443
+
let query_inv = Jmap_eio.Client.Build.email_query
444
+
~call_id:"q1"
445
+
~account_id
446
+
~sort
447
+
~limit:(Int64.of_int limit)
448
+
()
449
+
in
450
+
451
+
let req = Jmap_eio.Client.Build.(
452
+
make_request
453
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
454
+
[query_inv]
455
+
) in
456
+
457
+
match Jmap_eio.Client.request client req with
458
+
| Error e ->
459
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
460
+
exit 1
461
+
| Ok response ->
462
+
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
463
+
| Error e ->
464
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
465
+
exit 1
466
+
| Ok query_result ->
467
+
let email_ids = query_result.ids in
468
+
Jmap_eio.Cli.debug cfg "Query returned %d email IDs" (List.length email_ids);
469
+
470
+
if List.length email_ids = 0 then (
471
+
Fmt.pr "No emails found.@."
472
+
) else (
473
+
(* Fetch full details for all emails *)
474
+
let properties = [
475
+
"id"; "blobId"; "threadId"; "mailboxIds"; "keywords"; "size";
476
+
"receivedAt"; "subject"; "from"; "to"; "cc"; "preview"
477
+
] in
478
+
let get_inv = Jmap_eio.Client.Build.email_get
479
+
~call_id:"g1"
480
+
~account_id
481
+
~ids:email_ids
482
+
~properties
483
+
()
484
+
in
485
+
let req2 = Jmap_eio.Client.Build.(
486
+
make_request
487
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
488
+
[get_inv]
489
+
) in
490
+
491
+
Jmap_eio.Cli.debug cfg "Fetching email details...";
492
+
493
+
match Jmap_eio.Client.request client req2 with
494
+
| Error e ->
495
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
496
+
exit 1
497
+
| Ok response2 ->
498
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
499
+
| Error e ->
500
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
501
+
exit 1
502
+
| Ok get_result ->
503
+
Jmap_eio.Cli.debug cfg "Got %d emails" (List.length get_result.list);
504
+
505
+
(* Output based on format *)
506
+
match format with
507
+
| `Compact ->
508
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
509
+
let from_str = match email.from with
510
+
| Some (addr :: _) ->
511
+
Option.value addr.name ~default:addr.email
512
+
| _ -> "?"
513
+
in
514
+
let subject = Option.value email.subject ~default:"(no subject)" in
515
+
let flags = format_keywords (email_keywords email) in
516
+
Printf.printf "%s\t%s\t%s\t%s\t%s\n"
517
+
(email_id email)
518
+
(email_received_at email)
519
+
(truncate_string 20 from_str)
520
+
(truncate_string 50 subject)
521
+
flags
522
+
) get_result.list
523
+
524
+
| `Table ->
525
+
Fmt.pr "@[<v>%a (%d emails, state: %s)@,@,"
526
+
Fmt.(styled `Bold string) "Recent Emails"
527
+
(List.length get_result.list)
528
+
get_result.state;
529
+
(* Header *)
530
+
Fmt.pr "%-12s %-19s %-20s %-40s %s@,"
531
+
"ID" "Date" "From" "Subject" "Flags";
532
+
Fmt.pr "%s@," (String.make 110 '-');
533
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
534
+
let from_str = match email.from with
535
+
| Some (addr :: _) ->
536
+
Option.value addr.name ~default:addr.email
537
+
| _ -> "?"
538
+
in
539
+
let subject = Option.value email.subject ~default:"(no subject)" in
540
+
let flags = format_keywords (email_keywords email) in
541
+
let id_short =
542
+
let id = email_id email in
543
+
if String.length id > 12 then String.sub id 0 12 else id
544
+
in
545
+
Fmt.pr "%-12s %s %-20s %-40s %s@,"
546
+
id_short
547
+
(email_received_at email)
548
+
(truncate_string 20 from_str)
549
+
(truncate_string 40 subject)
550
+
flags
551
+
) get_result.list;
552
+
Fmt.pr "@]@."
553
+
554
+
| `Detailed ->
555
+
Fmt.pr "@[<v>%a (%d emails)@,@,"
556
+
Fmt.(styled `Bold string) "Recent Emails"
557
+
(List.length get_result.list);
558
+
List.iteri (fun i (email : Jmap.Proto.Email.t) ->
559
+
let from_str = match email.from with
560
+
| Some addrs -> format_email_addresses addrs
561
+
| None -> "(unknown)"
562
+
in
563
+
let to_str = match email.to_ with
564
+
| Some addrs -> format_email_addresses addrs
565
+
| None -> ""
566
+
in
567
+
let cc_str = match email.cc with
568
+
| Some addrs -> format_email_addresses addrs
569
+
| None -> ""
570
+
in
571
+
let subject = Option.value email.subject ~default:"(no subject)" in
572
+
let flags = format_keywords (email_keywords email) in
573
+
let mailbox_count = List.length (email_mailbox_ids email) in
574
+
575
+
Fmt.pr "@[<v 2>%a Email %d of %d@,"
576
+
Fmt.(styled `Bold string) "---"
577
+
(i + 1) (List.length get_result.list);
578
+
Fmt.pr "ID: %a@,"
579
+
Fmt.(styled `Cyan string) (email_id email);
580
+
Fmt.pr "Thread: %s@," (email_thread_id email);
581
+
Fmt.pr "Date: %s@," (email_received_at email);
582
+
Fmt.pr "From: %s@," from_str;
583
+
if to_str <> "" then Fmt.pr "To: %s@," to_str;
584
+
if cc_str <> "" then Fmt.pr "Cc: %s@," cc_str;
585
+
Fmt.pr "Subject: %a@,"
586
+
Fmt.(styled `White string) subject;
587
+
Fmt.pr "Size: %Ld bytes@," (email_size email);
588
+
Fmt.pr "Mailboxes: %d@," mailbox_count;
589
+
if flags <> "" then Fmt.pr "Flags: %s@," flags;
590
+
Fmt.pr "Preview: %s@]@,@," (email_preview email);
591
+
) get_result.list;
592
+
Fmt.pr "@]@."
593
+
)
594
+
in
595
+
let doc = "List recent emails with full details (chains query + get)" in
596
+
let info = Cmd.info "recent" ~doc in
597
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ limit_term $ format_term)
598
+
599
+
(** {1 Threads Command} *)
600
+
601
+
let threads_cmd =
602
+
let email_id_term =
603
+
let doc = "Email ID to get thread for" in
604
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"EMAIL_ID" ~doc)
605
+
in
606
+
let run cfg email_id_str =
607
+
Eio_main.run @@ fun env ->
608
+
Eio.Switch.run @@ fun sw ->
609
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
610
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
611
+
612
+
let target_email_id = Jmap.Proto.Id.of_string_exn email_id_str in
613
+
614
+
(* First get the email to find its thread ID - include required properties *)
615
+
let get_inv = Jmap_eio.Client.Build.email_get
616
+
~call_id:"e1"
617
+
~account_id
618
+
~ids:[target_email_id]
619
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"]
620
+
()
621
+
in
622
+
let req = Jmap_eio.Client.Build.(
623
+
make_request
624
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
625
+
[get_inv]
626
+
) in
627
+
628
+
match Jmap_eio.Client.request client req with
629
+
| Error e ->
630
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
631
+
exit 1
632
+
| Ok response ->
633
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"e1" response with
634
+
| Error e ->
635
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
636
+
exit 1
637
+
| Ok email_result ->
638
+
match email_result.list with
639
+
| [] ->
640
+
Fmt.epr "Email not found: %s@." email_id_str;
641
+
exit 1
642
+
| email :: _ ->
643
+
let thread_id = match email.thread_id with
644
+
| Some id -> id
645
+
| None ->
646
+
Fmt.epr "Email has no thread ID@.";
647
+
exit 1
648
+
in
649
+
Jmap_eio.Cli.debug cfg "Thread ID: %s" (Jmap.Proto.Id.to_string thread_id);
650
+
651
+
(* Get the thread *)
652
+
let thread_inv = Jmap_eio.Client.Build.thread_get
653
+
~call_id:"t1"
654
+
~account_id
655
+
~ids:[thread_id]
656
+
()
657
+
in
658
+
let req2 = Jmap_eio.Client.Build.(
659
+
make_request
660
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
661
+
[thread_inv]
662
+
) in
663
+
664
+
match Jmap_eio.Client.request client req2 with
665
+
| Error e ->
666
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
667
+
exit 1
668
+
| Ok response2 ->
669
+
match Jmap_eio.Client.Parse.parse_thread_get ~call_id:"t1" response2 with
670
+
| Error e ->
671
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
672
+
exit 1
673
+
| Ok thread_result ->
674
+
match thread_result.list with
675
+
| [] ->
676
+
Fmt.epr "Thread not found@.";
677
+
exit 1
678
+
| thread :: _ ->
679
+
let thread_id_str = match thread.id with
680
+
| Some id -> Jmap.Proto.Id.to_string id
681
+
| None -> "?"
682
+
in
683
+
let email_ids = Option.value ~default:[] thread.email_ids in
684
+
Fmt.pr "@[<v>%a %s (%d emails)@,@,"
685
+
Fmt.(styled `Bold string) "Thread"
686
+
thread_id_str
687
+
(List.length email_ids);
688
+
689
+
(* Fetch all emails in thread *)
690
+
let get_inv2 = Jmap_eio.Client.Build.email_get
691
+
~call_id:"e2"
692
+
~account_id
693
+
~ids:email_ids
694
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
695
+
"size"; "receivedAt"; "subject"; "from"; "preview"]
696
+
()
697
+
in
698
+
let req3 = Jmap_eio.Client.Build.(
699
+
make_request
700
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
701
+
[get_inv2]
702
+
) in
703
+
704
+
match Jmap_eio.Client.request client req3 with
705
+
| Error e ->
706
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
707
+
exit 1
708
+
| Ok response3 ->
709
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"e2" response3 with
710
+
| Error e ->
711
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
712
+
exit 1
713
+
| Ok emails_result ->
714
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
715
+
let from_str = match email.from with
716
+
| Some addrs -> format_email_addresses addrs
717
+
| None -> "(unknown)"
718
+
in
719
+
let subject = Option.value email.subject ~default:"(no subject)" in
720
+
Fmt.pr " %a %s@,"
721
+
Fmt.(styled `Cyan string) (email_id email)
722
+
(email_received_at email);
723
+
Fmt.pr " From: %s@," (truncate_string 60 from_str);
724
+
Fmt.pr " Subject: %a@,@,"
725
+
Fmt.(styled `White string) (truncate_string 60 subject);
726
+
) emails_result.list;
727
+
Fmt.pr "@]@."
728
+
in
729
+
let doc = "Show email thread" in
730
+
let info = Cmd.info "thread" ~doc in
731
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_id_term)
732
+
733
+
(** {1 Identities Command} *)
734
+
735
+
let identities_cmd =
736
+
let run cfg =
737
+
Eio_main.run @@ fun env ->
738
+
Eio.Switch.run @@ fun sw ->
739
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
740
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
741
+
742
+
let req = Jmap_eio.Client.Build.(
743
+
make_request
744
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail;
745
+
Jmap.Proto.Capability.submission]
746
+
[identity_get ~call_id:"i1" ~account_id ()]
747
+
) in
748
+
749
+
match Jmap_eio.Client.request client req with
750
+
| Error e ->
751
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
752
+
exit 1
753
+
| Ok response ->
754
+
match Jmap_eio.Client.Parse.parse_response ~call_id:"i1"
755
+
(Jmap_eio.Client.Parse.get_response Jmap.Proto.Identity.jsont)
756
+
response with
757
+
| Error e ->
758
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
759
+
exit 1
760
+
| Ok result ->
761
+
Fmt.pr "@[<v>%a (state: %s)@,@,"
762
+
Fmt.(styled `Bold string) "Identities"
763
+
result.state;
764
+
List.iter (fun (ident : Jmap.Proto.Identity.t) ->
765
+
let ident_id = match ident.id with Some id -> Jmap.Proto.Id.to_string id | None -> "?" in
766
+
let ident_name = Option.value ~default:"(unnamed)" ident.name in
767
+
let ident_email = Option.value ~default:"(no email)" ident.email in
768
+
let ident_sig = Option.value ~default:"" ident.text_signature in
769
+
let ident_may_delete = Option.value ~default:false ident.may_delete in
770
+
Fmt.pr " %a@,"
771
+
Fmt.(styled `Cyan string) ident_id;
772
+
Fmt.pr " Name: %s@," ident_name;
773
+
Fmt.pr " Email: %a@,"
774
+
Fmt.(styled `Green string) ident_email;
775
+
if ident_sig <> "" then
776
+
Fmt.pr " Signature: %s@," (truncate_string 50 ident_sig);
777
+
Fmt.pr " May delete: %b@,@," ident_may_delete
778
+
) result.list;
779
+
Fmt.pr "@]@."
780
+
in
781
+
let doc = "List email identities" in
782
+
let info = Cmd.info "identities" ~doc in
783
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term)
784
+
785
+
(** {1 Chained Commands - Using the Chain monad} *)
786
+
787
+
(** Inbox command - demonstrates simple query+get chain *)
788
+
let inbox_cmd =
789
+
let limit_term =
790
+
let doc = "Maximum number of emails to show" in
791
+
Arg.(value & opt int 20 & info ["limit"; "n"] ~docv:"N" ~doc)
792
+
in
793
+
let run cfg limit =
794
+
Eio_main.run @@ fun env ->
795
+
Eio.Switch.run @@ fun sw ->
796
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
797
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
798
+
799
+
Jmap_eio.Cli.debug cfg "Fetching inbox emails using Chain API";
800
+
801
+
(* Find inbox mailbox first *)
802
+
let mbox_req = Jmap_eio.Client.Build.(
803
+
make_request
804
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
805
+
[mailbox_get ~call_id:"m1" ~account_id ()]
806
+
) in
807
+
808
+
match Jmap_eio.Client.request client mbox_req with
809
+
| Error e ->
810
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
811
+
exit 1
812
+
| Ok mbox_response ->
813
+
match Jmap_eio.Client.Parse.parse_mailbox_get ~call_id:"m1" mbox_response with
814
+
| Error e ->
815
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
816
+
exit 1
817
+
| Ok mbox_result ->
818
+
(* Find inbox *)
819
+
let inbox =
820
+
List.find_opt (fun (m : Jmap.Proto.Mailbox.t) ->
821
+
m.role = Some `Inbox
822
+
) mbox_result.list
823
+
in
824
+
match inbox with
825
+
| None ->
826
+
Fmt.epr "No inbox found@.";
827
+
exit 1
828
+
| Some inbox ->
829
+
let inbox_id = match inbox.id with
830
+
| Some id -> id
831
+
| None ->
832
+
Fmt.epr "Inbox has no ID@.";
833
+
exit 1
834
+
in
835
+
Jmap_eio.Cli.debug cfg "Found inbox: %s" (Jmap.Proto.Id.to_string inbox_id);
836
+
837
+
(* Now use Chain API to query and get emails in one request *)
838
+
let open Jmap_eio.Chain in
839
+
let filter_cond : Jmap.Proto.Email.Filter_condition.t = {
840
+
in_mailbox = Some inbox_id;
841
+
in_mailbox_other_than = None;
842
+
before = None; after = None;
843
+
min_size = None; max_size = None;
844
+
all_in_thread_have_keyword = None;
845
+
some_in_thread_have_keyword = None;
846
+
none_in_thread_have_keyword = None;
847
+
has_keyword = None; not_keyword = None;
848
+
has_attachment = None;
849
+
text = None; from = None; to_ = None;
850
+
cc = None; bcc = None; subject = None;
851
+
body = None; header = None;
852
+
} in
853
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
854
+
855
+
let request, email_handle = build
856
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
857
+
begin
858
+
let* query = email_query ~account_id
859
+
~filter:(Jmap.Proto.Filter.Condition filter_cond)
860
+
~sort
861
+
~limit:(Int64.of_int limit)
862
+
()
863
+
in
864
+
let* emails = email_get ~account_id
865
+
~ids:(from_query query)
866
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "preview"; "keywords"]
867
+
()
868
+
in
869
+
return emails
870
+
end in
871
+
872
+
Jmap_eio.Cli.debug cfg "Sending chained request (query + get in one round trip)";
873
+
874
+
match Jmap_eio.Client.request client request with
875
+
| Error e ->
876
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
877
+
exit 1
878
+
| Ok response ->
879
+
match parse email_handle response with
880
+
| Error e ->
881
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
882
+
exit 1
883
+
| Ok result ->
884
+
Fmt.pr "@[<v>%a (%d emails in inbox)@,@,"
885
+
Fmt.(styled `Bold string) "Inbox"
886
+
(List.length result.list);
887
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
888
+
let from_str = match email.from with
889
+
| Some (addr :: _) ->
890
+
Option.value addr.name ~default:addr.email
891
+
| _ -> "?"
892
+
in
893
+
let subject = Option.value email.subject ~default:"(no subject)" in
894
+
let flags = format_keywords (email_keywords email) in
895
+
Fmt.pr " %a %s@,"
896
+
Fmt.(styled `Cyan string) (email_id email)
897
+
(email_received_at email);
898
+
Fmt.pr " From: %s@," (truncate_string 40 from_str);
899
+
Fmt.pr " Subject: %a%s@,"
900
+
Fmt.(styled `White string) (truncate_string 50 subject)
901
+
(if flags = "" then "" else " [" ^ flags ^ "]");
902
+
Fmt.pr "@,"
903
+
) result.list;
904
+
Fmt.pr "@]@."
905
+
in
906
+
let doc = "List inbox emails (uses Chain API for query+get in single request)" in
907
+
let info = Cmd.info "inbox" ~doc in
908
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ limit_term)
909
+
910
+
(** Thread-view command - demonstrates multi-step chaining (RFC 8620 example) *)
911
+
let thread_view_cmd =
912
+
let limit_term =
913
+
let doc = "Number of threads to show" in
914
+
Arg.(value & opt int 10 & info ["limit"; "n"] ~docv:"N" ~doc)
915
+
in
916
+
let run cfg limit =
917
+
Eio_main.run @@ fun env ->
918
+
Eio.Switch.run @@ fun sw ->
919
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
920
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
921
+
922
+
Jmap_eio.Cli.debug cfg "Fetching threaded view using multi-step Chain API";
923
+
924
+
(*
925
+
This implements the RFC 8620 example:
926
+
1. Email/query with collapseThreads to get one email per thread
927
+
2. Email/get to fetch threadId for each
928
+
3. Thread/get to fetch all emailIds in each thread
929
+
4. Email/get to fetch details for all emails in those threads
930
+
*)
931
+
let open Jmap_eio.Chain in
932
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
933
+
934
+
let request, (query_h, final_emails_h) = build
935
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
936
+
begin
937
+
(* Step 1: Query for recent emails, collapsing threads *)
938
+
let* query = email_query ~account_id
939
+
~sort
940
+
~collapse_threads:true
941
+
~limit:(Int64.of_int limit)
942
+
()
943
+
in
944
+
(* Step 2: Get just threadId for those emails *)
945
+
let* emails1 = email_get ~account_id
946
+
~ids:(from_query query)
947
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"]
948
+
()
949
+
in
950
+
(* Step 3: Get threads using threadIds from step 2 *)
951
+
let* threads = thread_get ~account_id
952
+
~ids:(from_get_field emails1 "threadId")
953
+
()
954
+
in
955
+
(* Step 4: Get all emails in those threads *)
956
+
let* emails2 = email_get ~account_id
957
+
~ids:(from_get_field threads "emailIds")
958
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "preview"]
959
+
()
960
+
in
961
+
return (query, emails2)
962
+
end in
963
+
964
+
Jmap_eio.Cli.debug cfg "Sending 4-step chained request in single round trip";
965
+
966
+
match Jmap_eio.Client.request client request with
967
+
| Error e ->
968
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
969
+
exit 1
970
+
| Ok response ->
971
+
let query_result = parse_exn query_h response in
972
+
let emails_result = parse_exn final_emails_h response in
973
+
974
+
(* Group emails by thread *)
975
+
let threads_map = Hashtbl.create 16 in
976
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
977
+
let tid = email_thread_id email in
978
+
let existing = try Hashtbl.find threads_map tid with Not_found -> [] in
979
+
Hashtbl.replace threads_map tid (email :: existing)
980
+
) emails_result.list;
981
+
982
+
Fmt.pr "@[<v>%a (%d threads, %d total emails)@,@,"
983
+
Fmt.(styled `Bold string) "Threaded View"
984
+
(Hashtbl.length threads_map)
985
+
(List.length emails_result.list);
986
+
Fmt.pr "Query found %s total matching emails@,@,"
987
+
(match query_result.total with Some n -> Int64.to_string n | None -> "?");
988
+
989
+
(* Print threads *)
990
+
Hashtbl.iter (fun _tid emails ->
991
+
let emails = List.sort (fun (a : Jmap.Proto.Email.t) (b : Jmap.Proto.Email.t) ->
992
+
let a_time = Option.value ~default:Ptime.epoch a.received_at in
993
+
let b_time = Option.value ~default:Ptime.epoch b.received_at in
994
+
Ptime.compare a_time b_time
995
+
) emails in
996
+
let first_email = List.hd emails in
997
+
let subject = Option.value first_email.subject ~default:"(no subject)" in
998
+
Fmt.pr " %a Thread: %s (%d emails)@,"
999
+
Fmt.(styled `Bold string) "โธ"
1000
+
(truncate_string 50 subject)
1001
+
(List.length emails);
1002
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
1003
+
let from_str = match email.from with
1004
+
| Some (addr :: _) -> Option.value addr.name ~default:addr.email
1005
+
| _ -> "?"
1006
+
in
1007
+
Fmt.pr " %s %s %s@,"
1008
+
(email_id email |> truncate_string 12)
1009
+
(email_received_at email)
1010
+
(truncate_string 30 from_str)
1011
+
) emails;
1012
+
Fmt.pr "@,"
1013
+
) threads_map;
1014
+
Fmt.pr "@]@."
1015
+
in
1016
+
let doc = "Show threaded view (demonstrates RFC 8620 multi-step chain)" in
1017
+
let info = Cmd.info "thread-view" ~doc in
1018
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ limit_term)
1019
+
1020
+
(** Mark-read command - demonstrates email_set for updating keywords *)
1021
+
let mark_read_cmd =
1022
+
let email_id_term =
1023
+
let doc = "Email ID to mark as read" in
1024
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"EMAIL_ID" ~doc)
1025
+
in
1026
+
let unread_term =
1027
+
let doc = "Mark as unread instead of read" in
1028
+
Arg.(value & flag & info ["unread"; "u"] ~doc)
1029
+
in
1030
+
let run cfg email_id_str unread =
1031
+
Eio_main.run @@ fun env ->
1032
+
Eio.Switch.run @@ fun sw ->
1033
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1034
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1035
+
let email_id = Jmap.Proto.Id.of_string_exn email_id_str in
1036
+
1037
+
Jmap_eio.Cli.debug cfg "%s email %s"
1038
+
(if unread then "Marking as unread" else "Marking as read")
1039
+
email_id_str;
1040
+
1041
+
(* Build the patch object - set or unset $seen keyword *)
1042
+
let patch =
1043
+
let open Jmap_eio.Chain in
1044
+
if unread then
1045
+
json_obj [("keywords/$seen", json_null)]
1046
+
else
1047
+
json_obj [("keywords/$seen", json_bool true)]
1048
+
in
1049
+
1050
+
let open Jmap_eio.Chain in
1051
+
let request, set_h = build
1052
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1053
+
begin
1054
+
email_set ~account_id
1055
+
~update:[(email_id, patch)]
1056
+
()
1057
+
end in
1058
+
1059
+
match Jmap_eio.Client.request client request with
1060
+
| Error e ->
1061
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1062
+
exit 1
1063
+
| Ok response ->
1064
+
match parse set_h response with
1065
+
| Error e ->
1066
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1067
+
exit 1
1068
+
| Ok result ->
1069
+
(* Check if update succeeded *)
1070
+
let updated_ids =
1071
+
result.updated
1072
+
|> Option.value ~default:[]
1073
+
|> List.map (fun (id, _) -> Jmap.Proto.Id.to_string id)
1074
+
in
1075
+
if List.mem email_id_str updated_ids then
1076
+
Fmt.pr "Email %s marked as %s@."
1077
+
email_id_str
1078
+
(if unread then "unread" else "read")
1079
+
else (
1080
+
Fmt.epr "Failed to update email. ";
1081
+
let not_updated = Option.value ~default:[] result.not_updated in
1082
+
(match List.find_opt (fun (id, _) -> Jmap.Proto.Id.to_string id = email_id_str) not_updated with
1083
+
| Some (_, err) ->
1084
+
let open Jmap.Proto.Error in
1085
+
let err_type = set_error_type_to_string err.type_ in
1086
+
let err_desc = Option.value ~default:"" err.description in
1087
+
Fmt.epr "Error: %s (%s)@." err_type err_desc
1088
+
| None ->
1089
+
Fmt.epr "Unknown error@.");
1090
+
exit 1
1091
+
)
1092
+
in
1093
+
let doc = "Mark an email as read/unread (demonstrates Email/set)" in
1094
+
let info = Cmd.info "mark-read" ~doc in
1095
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_id_term $ unread_term)
1096
+
1097
+
(** Delete email command - demonstrates email_set destroy *)
1098
+
let delete_email_cmd =
1099
+
let email_ids_term =
1100
+
let doc = "Email IDs to delete" in
1101
+
Arg.(non_empty & pos_all string [] & info [] ~docv:"EMAIL_ID" ~doc)
1102
+
in
1103
+
let run cfg email_id_strs =
1104
+
Eio_main.run @@ fun env ->
1105
+
Eio.Switch.run @@ fun sw ->
1106
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1107
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1108
+
let email_ids = List.map Jmap.Proto.Id.of_string_exn email_id_strs in
1109
+
1110
+
Jmap_eio.Cli.debug cfg "Deleting %d email(s)" (List.length email_ids);
1111
+
1112
+
let open Jmap_eio.Chain in
1113
+
let request, set_h = build
1114
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1115
+
begin
1116
+
email_set ~account_id
1117
+
~destroy:(ids email_ids)
1118
+
()
1119
+
end in
1120
+
1121
+
match Jmap_eio.Client.request client request with
1122
+
| Error e ->
1123
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1124
+
exit 1
1125
+
| Ok response ->
1126
+
match parse set_h response with
1127
+
| Error e ->
1128
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1129
+
exit 1
1130
+
| Ok result ->
1131
+
let destroyed = Option.value ~default:[] result.destroyed in
1132
+
let destroyed_ids = List.map Jmap.Proto.Id.to_string destroyed in
1133
+
Fmt.pr "Deleted %d email(s):@." (List.length destroyed_ids);
1134
+
List.iter (fun id -> Fmt.pr " %s@." id) destroyed_ids;
1135
+
(* Report any failures *)
1136
+
let not_destroyed = Option.value ~default:[] result.not_destroyed in
1137
+
if not_destroyed <> [] then begin
1138
+
Fmt.epr "Failed to delete %d email(s):@." (List.length not_destroyed);
1139
+
List.iter (fun (id, err) ->
1140
+
let open Jmap.Proto.Error in
1141
+
let err_type = set_error_type_to_string err.type_ in
1142
+
Fmt.epr " %s: %s@."
1143
+
(Jmap.Proto.Id.to_string id)
1144
+
err_type
1145
+
) not_destroyed
1146
+
end
1147
+
in
1148
+
let doc = "Delete emails (demonstrates Email/set destroy)" in
1149
+
let info = Cmd.info "delete" ~doc in
1150
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_ids_term)
1151
+
1152
+
(** Changes command - demonstrates email_changes for sync *)
1153
+
let changes_cmd =
1154
+
let state_term =
1155
+
let doc = "State to get changes since (use 'current' to just show current state)" in
1156
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"STATE" ~doc)
1157
+
in
1158
+
let run cfg state_str =
1159
+
Eio_main.run @@ fun env ->
1160
+
Eio.Switch.run @@ fun sw ->
1161
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1162
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1163
+
1164
+
if state_str = "current" then (
1165
+
(* Just get current state by doing a minimal query *)
1166
+
let open Jmap_eio.Chain in
1167
+
let request, get_h = build
1168
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1169
+
begin
1170
+
(* Get empty list just to see state *)
1171
+
email_get ~account_id ~ids:(ids []) ()
1172
+
end in
1173
+
1174
+
match Jmap_eio.Client.request client request with
1175
+
| Error e ->
1176
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1177
+
exit 1
1178
+
| Ok response ->
1179
+
match parse get_h response with
1180
+
| Error e ->
1181
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1182
+
exit 1
1183
+
| Ok result ->
1184
+
Fmt.pr "Current email state: %a@."
1185
+
Fmt.(styled `Cyan string) result.state
1186
+
) else (
1187
+
Jmap_eio.Cli.debug cfg "Getting changes since state: %s" state_str;
1188
+
1189
+
let open Jmap_eio.Chain in
1190
+
let request, changes_h = build
1191
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1192
+
begin
1193
+
email_changes ~account_id ~since_state:state_str ()
1194
+
end in
1195
+
1196
+
match Jmap_eio.Client.request client request with
1197
+
| Error e ->
1198
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1199
+
exit 1
1200
+
| Ok response ->
1201
+
match parse changes_h response with
1202
+
| Error e ->
1203
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1204
+
exit 1
1205
+
| Ok result ->
1206
+
Fmt.pr "@[<v>%a@,@,"
1207
+
Fmt.(styled `Bold string) "Email Changes";
1208
+
Fmt.pr "Old state: %s@," result.old_state;
1209
+
Fmt.pr "New state: %a@," Fmt.(styled `Cyan string) result.new_state;
1210
+
Fmt.pr "Has more changes: %b@,@," result.has_more_changes;
1211
+
Fmt.pr "Created: %d email(s)@," (List.length result.created);
1212
+
List.iter (fun id ->
1213
+
Fmt.pr " + %s@," (Jmap.Proto.Id.to_string id)
1214
+
) result.created;
1215
+
Fmt.pr "Updated: %d email(s)@," (List.length result.updated);
1216
+
List.iter (fun id ->
1217
+
Fmt.pr " ~ %s@," (Jmap.Proto.Id.to_string id)
1218
+
) result.updated;
1219
+
Fmt.pr "Destroyed: %d email(s)@," (List.length result.destroyed);
1220
+
List.iter (fun id ->
1221
+
Fmt.pr " - %s@," (Jmap.Proto.Id.to_string id)
1222
+
) result.destroyed;
1223
+
Fmt.pr "@]@."
1224
+
)
1225
+
in
1226
+
let doc = "Show email changes since a state (demonstrates Email/changes)" in
1227
+
let info = Cmd.info "changes" ~doc in
1228
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ state_term)
1229
+
1230
+
(** Sync command - demonstrates changes + get pattern for incremental sync *)
1231
+
let sync_cmd =
1232
+
let state_term =
1233
+
let doc = "State to sync from" in
1234
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"STATE" ~doc)
1235
+
in
1236
+
let run cfg state_str =
1237
+
Eio_main.run @@ fun env ->
1238
+
Eio.Switch.run @@ fun sw ->
1239
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1240
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1241
+
1242
+
Jmap_eio.Cli.debug cfg "Syncing from state: %s" state_str;
1243
+
1244
+
(* Chain: changes โ get created โ get updated *)
1245
+
let open Jmap_eio.Chain in
1246
+
let request, (changes_h, created_h, updated_h) = build
1247
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1248
+
begin
1249
+
let* changes = email_changes ~account_id ~since_state:state_str () in
1250
+
let* created = email_get ~account_id
1251
+
~ids:(from_changes_created changes)
1252
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "preview"]
1253
+
()
1254
+
in
1255
+
let* updated = email_get ~account_id
1256
+
~ids:(from_changes_updated changes)
1257
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "keywords"]
1258
+
()
1259
+
in
1260
+
return (changes, created, updated)
1261
+
end in
1262
+
1263
+
Jmap_eio.Cli.debug cfg "Sending chained sync request";
1264
+
1265
+
match Jmap_eio.Client.request client request with
1266
+
| Error e ->
1267
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1268
+
exit 1
1269
+
| Ok response ->
1270
+
let changes_result = parse_exn changes_h response in
1271
+
let created_result = parse_exn created_h response in
1272
+
let updated_result = parse_exn updated_h response in
1273
+
1274
+
Fmt.pr "@[<v>%a (state: %s โ %s)@,@,"
1275
+
Fmt.(styled `Bold string) "Sync Results"
1276
+
changes_result.old_state
1277
+
changes_result.new_state;
1278
+
1279
+
if List.length created_result.list > 0 then begin
1280
+
Fmt.pr "%a (%d)@,"
1281
+
Fmt.(styled `Green string) "New emails"
1282
+
(List.length created_result.list);
1283
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
1284
+
let from_str = match email.from with
1285
+
| Some (addr :: _) -> Option.value addr.name ~default:addr.email
1286
+
| _ -> "?"
1287
+
in
1288
+
let subject = Option.value email.subject ~default:"(no subject)" in
1289
+
Fmt.pr " + %s %s %s@,"
1290
+
(email_id email |> truncate_string 12)
1291
+
(truncate_string 20 from_str)
1292
+
(truncate_string 40 subject)
1293
+
) created_result.list;
1294
+
Fmt.pr "@,"
1295
+
end;
1296
+
1297
+
if List.length updated_result.list > 0 then begin
1298
+
Fmt.pr "%a (%d)@,"
1299
+
Fmt.(styled `Yellow string) "Updated emails"
1300
+
(List.length updated_result.list);
1301
+
List.iter (fun (email : Jmap.Proto.Email.t) ->
1302
+
let flags = format_keywords (email_keywords email) in
1303
+
Fmt.pr " ~ %s [%s]@,"
1304
+
(email_id email |> truncate_string 12)
1305
+
flags
1306
+
) updated_result.list;
1307
+
Fmt.pr "@,"
1308
+
end;
1309
+
1310
+
if List.length changes_result.destroyed > 0 then begin
1311
+
Fmt.pr "%a (%d)@,"
1312
+
Fmt.(styled `Red string) "Deleted emails"
1313
+
(List.length changes_result.destroyed);
1314
+
List.iter (fun id ->
1315
+
Fmt.pr " - %s@," (Jmap.Proto.Id.to_string id)
1316
+
) changes_result.destroyed;
1317
+
Fmt.pr "@,"
1318
+
end;
1319
+
1320
+
if changes_result.has_more_changes then
1321
+
Fmt.pr "%a - call sync again with state %s@,"
1322
+
Fmt.(styled `Bold string) "More changes available"
1323
+
changes_result.new_state;
1324
+
1325
+
Fmt.pr "@]@."
1326
+
in
1327
+
let doc = "Incremental sync (demonstrates changes + get chain)" in
1328
+
let info = Cmd.info "sync" ~doc in
1329
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ state_term)
1330
+
1331
+
(** Headers command - demonstrates RFC 8621 ยง4.1 header property queries *)
1332
+
let headers_cmd =
1333
+
let email_id_term =
1334
+
let doc = "Email ID to get headers for" in
1335
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"EMAIL_ID" ~doc)
1336
+
in
1337
+
1338
+
(* Format a header value for display *)
1339
+
let format_header_value = function
1340
+
| Jmap.Proto.Email_header.String_single None -> "(null)"
1341
+
| Jmap.Proto.Email_header.String_single (Some s) -> s
1342
+
| Jmap.Proto.Email_header.String_all [] -> "(empty list)"
1343
+
| Jmap.Proto.Email_header.String_all strs -> String.concat "; " strs
1344
+
| Jmap.Proto.Email_header.Addresses_single None -> "(null)"
1345
+
| Jmap.Proto.Email_header.Addresses_single (Some []) -> "(empty)"
1346
+
| Jmap.Proto.Email_header.Addresses_single (Some addrs) ->
1347
+
String.concat ", " (List.map (fun a ->
1348
+
match a.Jmap.Proto.Email_address.name with
1349
+
| Some n -> Printf.sprintf "%s <%s>" n a.email
1350
+
| None -> a.email
1351
+
) addrs)
1352
+
| Jmap.Proto.Email_header.Addresses_all [] -> "(empty list)"
1353
+
| Jmap.Proto.Email_header.Addresses_all groups ->
1354
+
String.concat " | " (List.map (fun addrs ->
1355
+
String.concat ", " (List.map (fun a ->
1356
+
match a.Jmap.Proto.Email_address.name with
1357
+
| Some n -> Printf.sprintf "%s <%s>" n a.email
1358
+
| None -> a.email
1359
+
) addrs)
1360
+
) groups)
1361
+
| Jmap.Proto.Email_header.Grouped_single None -> "(null)"
1362
+
| Jmap.Proto.Email_header.Grouped_single (Some groups) ->
1363
+
String.concat "; " (List.map (fun g ->
1364
+
let name = Option.value ~default:"(ungrouped)" g.Jmap.Proto.Email_address.Group.name in
1365
+
let addrs = String.concat ", " (List.map (fun a ->
1366
+
match a.Jmap.Proto.Email_address.name with
1367
+
| Some n -> Printf.sprintf "%s <%s>" n a.email
1368
+
| None -> a.email
1369
+
) g.addresses) in
1370
+
Printf.sprintf "%s: %s" name addrs
1371
+
) groups)
1372
+
| Jmap.Proto.Email_header.Grouped_all _ -> "(grouped addresses list)"
1373
+
| Jmap.Proto.Email_header.Date_single None -> "(null)"
1374
+
| Jmap.Proto.Email_header.Date_single (Some t) -> ptime_to_string t
1375
+
| Jmap.Proto.Email_header.Date_all [] -> "(empty list)"
1376
+
| Jmap.Proto.Email_header.Date_all dates ->
1377
+
String.concat "; " (List.map (function
1378
+
| None -> "(null)"
1379
+
| Some t -> ptime_to_string t
1380
+
) dates)
1381
+
| Jmap.Proto.Email_header.Strings_single None -> "(null)"
1382
+
| Jmap.Proto.Email_header.Strings_single (Some []) -> "(empty)"
1383
+
| Jmap.Proto.Email_header.Strings_single (Some strs) -> String.concat ", " strs
1384
+
| Jmap.Proto.Email_header.Strings_all [] -> "(empty list)"
1385
+
| Jmap.Proto.Email_header.Strings_all groups ->
1386
+
String.concat " | " (List.map (function
1387
+
| None -> "(null)"
1388
+
| Some strs -> String.concat ", " strs
1389
+
) groups)
1390
+
in
1391
+
1392
+
let run cfg email_id_str =
1393
+
Eio_main.run @@ fun env ->
1394
+
Eio.Switch.run @@ fun sw ->
1395
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1396
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1397
+
let target_email_id = Jmap.Proto.Id.of_string_exn email_id_str in
1398
+
1399
+
Jmap_eio.Cli.debug cfg "Fetching headers for email %s" email_id_str;
1400
+
1401
+
(* Demonstrate various header forms from RFC 8621 ยง4.1.2:
1402
+
- header:name - Raw value
1403
+
- header:name:asText - Text decoded
1404
+
- header:name:asAddresses - Address list
1405
+
- header:name:asGroupedAddresses - Address groups
1406
+
- header:name:asMessageIds - Message-ID list
1407
+
- header:name:asDate - RFC 3339 date
1408
+
- header:name:asURLs - URL list
1409
+
- header:name:all - All values (not just first)
1410
+
*)
1411
+
let header_props = [
1412
+
(* Raw and text forms *)
1413
+
"header:Subject";
1414
+
"header:Subject:asText";
1415
+
(* Address headers *)
1416
+
"header:From:asAddresses";
1417
+
"header:To:asAddresses";
1418
+
"header:Cc:asAddresses";
1419
+
"header:Bcc:asAddresses";
1420
+
"header:Reply-To:asAddresses";
1421
+
"header:Sender:asAddresses";
1422
+
(* Grouped addresses *)
1423
+
"header:From:asGroupedAddresses";
1424
+
(* Message ID headers *)
1425
+
"header:Message-ID:asMessageIds";
1426
+
"header:In-Reply-To:asMessageIds";
1427
+
"header:References:asMessageIds";
1428
+
(* Date header *)
1429
+
"header:Date:asDate";
1430
+
(* List headers as URLs *)
1431
+
"header:List-Unsubscribe:asURLs";
1432
+
"header:List-Post:asURLs";
1433
+
"header:List-Archive:asURLs";
1434
+
(* Custom headers *)
1435
+
"header:X-Mailer:asText";
1436
+
"header:X-Priority";
1437
+
"header:X-Spam-Status:asText";
1438
+
"header:Content-Type";
1439
+
"header:MIME-Version";
1440
+
(* Get all Received headers (typically multiple) *)
1441
+
"header:Received:all";
1442
+
] in
1443
+
1444
+
let properties = "id" :: "threadId" :: "subject" :: header_props in
1445
+
1446
+
let get_inv = Jmap_eio.Client.Build.email_get
1447
+
~call_id:"h1"
1448
+
~account_id
1449
+
~ids:[target_email_id]
1450
+
~properties
1451
+
()
1452
+
in
1453
+
let req = Jmap_eio.Client.Build.(
1454
+
make_request
1455
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1456
+
[get_inv]
1457
+
) in
1458
+
1459
+
match Jmap_eio.Client.request client req with
1460
+
| Error e ->
1461
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1462
+
exit 1
1463
+
| Ok response ->
1464
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"h1" response with
1465
+
| Error e ->
1466
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1467
+
exit 1
1468
+
| Ok email_result ->
1469
+
match email_result.list with
1470
+
| [] ->
1471
+
Fmt.epr "Email not found: %s@." email_id_str;
1472
+
exit 1
1473
+
| email :: _ ->
1474
+
Fmt.pr "@[<v>%a@," Fmt.(styled `Bold string) "Email Headers (RFC 8621 ยง4.1)";
1475
+
Fmt.pr "ID: %s@," (email_id email);
1476
+
Fmt.pr "Thread: %s@," (email_thread_id email);
1477
+
(match email.subject with
1478
+
| Some s -> Fmt.pr "Subject (convenience): %s@," s
1479
+
| None -> ());
1480
+
Fmt.pr "@,";
1481
+
1482
+
(* Print dynamic headers grouped by category *)
1483
+
let raw_headers = Jmap.Proto.Email.dynamic_headers_raw email in
1484
+
if raw_headers = [] then
1485
+
Fmt.pr "%a@," Fmt.(styled `Yellow string) "No dynamic headers returned"
1486
+
else begin
1487
+
Fmt.pr "%a (%d properties)@,@,"
1488
+
Fmt.(styled `Bold string) "Dynamic Header Properties"
1489
+
(List.length raw_headers);
1490
+
1491
+
List.iter (fun (name, json) ->
1492
+
match Jmap.Proto.Email.decode_header_value name json with
1493
+
| None ->
1494
+
Fmt.pr " %a: (decode failed)@,"
1495
+
Fmt.(styled `Red string) name
1496
+
| Some value ->
1497
+
let formatted = format_header_value value in
1498
+
if String.length formatted > 80 then
1499
+
Fmt.pr " %a:@, %s@,"
1500
+
Fmt.(styled `Cyan string) name
1501
+
formatted
1502
+
else
1503
+
Fmt.pr " %a: %s@,"
1504
+
Fmt.(styled `Cyan string) name
1505
+
formatted
1506
+
) raw_headers
1507
+
end;
1508
+
Fmt.pr "@]@."
1509
+
in
1510
+
let doc = "Show email headers in various forms (demonstrates RFC 8621 ยง4.1)" in
1511
+
let info = Cmd.info "headers" ~doc in
1512
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_id_term)
1513
+
1514
+
(** {1 Main Command Group} *)
1515
+
1516
+
let main_cmd =
1517
+
let doc = "JMAP command-line client" in
1518
+
let man = [
1519
+
`S Manpage.s_description;
1520
+
`P "A command-line client for JMAP (JSON Meta Application Protocol) email servers.";
1521
+
`S Manpage.s_environment;
1522
+
`P Jmap_eio.Cli.env_docs;
1523
+
`S Manpage.s_examples;
1524
+
`P "List mailboxes:";
1525
+
`Pre " jmap mailboxes --url https://api.fastmail.com/jmap/session -k YOUR_API_KEY";
1526
+
`P "Show recent emails:";
1527
+
`Pre " jmap recent -n 50 --format detailed";
1528
+
`P "Search emails:";
1529
+
`Pre " jmap search \"meeting notes\" -n 10";
1530
+
] in
1531
+
let info = Cmd.info "jmap" ~version:"0.1.0" ~doc ~man in
1532
+
Cmd.group info [
1533
+
session_cmd;
1534
+
mailboxes_cmd;
1535
+
emails_cmd;
1536
+
search_cmd;
1537
+
recent_cmd;
1538
+
threads_cmd;
1539
+
identities_cmd;
1540
+
headers_cmd;
1541
+
(* Chain API examples *)
1542
+
inbox_cmd;
1543
+
thread_view_cmd;
1544
+
mark_read_cmd;
1545
+
delete_email_cmd;
1546
+
changes_cmd;
1547
+
sync_cmd;
1548
+
]
1549
+
1550
+
let () =
1551
+
Fmt_tty.setup_std_outputs ();
1552
+
exit (Cmd.eval main_cmd)
+662
bin/jmapq.ml
+662
bin/jmapq.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JMAPQ - Specialist JMAP workflow commands *)
7
+
8
+
open Cmdliner
9
+
10
+
(** {1 Helpers} *)
11
+
12
+
let ptime_to_string t =
13
+
let (y, m, d), ((hh, mm, ss), _tz) = Ptime.to_date_time t in
14
+
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" y m d hh mm ss
15
+
16
+
let truncate_string max_len s =
17
+
if String.length s <= max_len then s
18
+
else String.sub s 0 (max_len - 3) ^ "..."
19
+
20
+
(** {1 Zulip Types and Codec} *)
21
+
22
+
(** Parsed information from a Zulip notification email subject.
23
+
Subject format: "#Channel > topic [Server Name]" *)
24
+
module Zulip_message = struct
25
+
type t = {
26
+
id : string;
27
+
date : Ptime.t;
28
+
thread_id : string;
29
+
channel : string;
30
+
topic : string;
31
+
server : string;
32
+
is_read : bool;
33
+
labels : string list;
34
+
}
35
+
36
+
(** Parse a Zulip subject line of the form "#Channel > topic [Server Name]" *)
37
+
let parse_subject subject =
38
+
(* Pattern: #<channel> > <topic> [<server>] *)
39
+
let channel_re = Re.Pcre.regexp {|^#(.+?)\s*>\s*(.+?)\s*\[(.+?)\]$|} in
40
+
match Re.exec_opt channel_re subject with
41
+
| Some groups ->
42
+
let channel = Re.Group.get groups 1 in
43
+
let topic = Re.Group.get groups 2 in
44
+
let server = Re.Group.get groups 3 in
45
+
Some (channel, topic, server)
46
+
| None -> None
47
+
48
+
(** Check if an email has the $seen keyword *)
49
+
let is_seen keywords =
50
+
List.exists (fun (k, v) -> k = "$seen" && v) keywords
51
+
52
+
(** Extract label strings from keywords, excluding standard JMAP keywords *)
53
+
let extract_labels keywords =
54
+
keywords
55
+
|> List.filter_map (fun (k, v) ->
56
+
if v && not (String.length k > 0 && k.[0] = '$') then
57
+
Some k
58
+
else if v && k = "$flagged" then
59
+
Some "flagged"
60
+
else
61
+
None)
62
+
63
+
(** Create a Zulip_message from a JMAP Email *)
64
+
let of_email (email : Jmap.Proto.Email.t) : t option =
65
+
let id = match email.id with
66
+
| Some id -> Jmap.Proto.Id.to_string id
67
+
| None -> ""
68
+
in
69
+
let date = match email.received_at with
70
+
| Some t -> t
71
+
| None -> Ptime.epoch
72
+
in
73
+
let thread_id = match email.thread_id with
74
+
| Some id -> Jmap.Proto.Id.to_string id
75
+
| None -> ""
76
+
in
77
+
let subject = Option.value ~default:"" email.subject in
78
+
match parse_subject subject with
79
+
| None -> None
80
+
| Some (channel, topic, server) ->
81
+
let keywords = Option.value ~default:[] email.keywords in
82
+
let is_read = is_seen keywords in
83
+
let labels = extract_labels keywords in
84
+
Some { id; date; thread_id; channel; topic; server; is_read; labels }
85
+
86
+
(** Jsont codec for Ptime.t - reuse the library's UTC date codec *)
87
+
let ptime_jsont : Ptime.t Jsont.t = Jmap.Proto.Date.Utc.jsont
88
+
89
+
(** Jsont codec for a single Zulip message *)
90
+
let jsont : t Jsont.t =
91
+
let kind = "ZulipMessage" in
92
+
let make id date thread_id channel topic server is_read labels =
93
+
{ id; date; thread_id; channel; topic; server; is_read; labels }
94
+
in
95
+
Jsont.Object.map ~kind make
96
+
|> Jsont.Object.mem "id" Jsont.string ~enc:(fun t -> t.id)
97
+
|> Jsont.Object.mem "date" ptime_jsont ~enc:(fun t -> t.date)
98
+
|> Jsont.Object.mem "thread_id" Jsont.string ~enc:(fun t -> t.thread_id)
99
+
|> Jsont.Object.mem "channel" Jsont.string ~enc:(fun t -> t.channel)
100
+
|> Jsont.Object.mem "topic" Jsont.string ~enc:(fun t -> t.topic)
101
+
|> Jsont.Object.mem "server" Jsont.string ~enc:(fun t -> t.server)
102
+
|> Jsont.Object.mem "is_read" Jsont.bool ~enc:(fun t -> t.is_read)
103
+
|> Jsont.Object.mem "labels" (Jsont.list Jsont.string) ~enc:(fun t -> t.labels)
104
+
|> Jsont.Object.finish
105
+
106
+
(** Jsont codec for a list of Zulip messages *)
107
+
let list_jsont : t list Jsont.t = Jsont.list jsont
108
+
end
109
+
110
+
(** {1 Zulip List Command} *)
111
+
112
+
let zulip_list_cmd =
113
+
let json_term =
114
+
let doc = "Output as JSON" in
115
+
Arg.(value & flag & info ["json"] ~doc)
116
+
in
117
+
let limit_term =
118
+
let doc = "Maximum number of messages to fetch (default: all)" in
119
+
Arg.(value & opt (some int) None & info ["limit"; "n"] ~docv:"N" ~doc)
120
+
in
121
+
let run cfg json_output limit =
122
+
Eio_main.run @@ fun env ->
123
+
Eio.Switch.run @@ fun sw ->
124
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
125
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
126
+
127
+
Jmap_eio.Cli.debug cfg "Searching for Zulip notification emails";
128
+
129
+
(* Build filter for emails from noreply@zulip.com *)
130
+
let cond : Jmap.Proto.Email.Filter_condition.t = {
131
+
in_mailbox = None; in_mailbox_other_than = None;
132
+
before = None; after = None;
133
+
min_size = None; max_size = None;
134
+
all_in_thread_have_keyword = None;
135
+
some_in_thread_have_keyword = None;
136
+
none_in_thread_have_keyword = None;
137
+
has_keyword = None; not_keyword = None;
138
+
has_attachment = None;
139
+
text = None;
140
+
from = Some "noreply@zulip.com";
141
+
to_ = None;
142
+
cc = None; bcc = None; subject = None;
143
+
body = None; header = None;
144
+
} in
145
+
let filter = Jmap.Proto.Filter.Condition cond in
146
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
147
+
148
+
(* Query for all Zulip emails *)
149
+
let query_limit = match limit with
150
+
| Some n -> Int64.of_int n
151
+
| None -> Int64.of_int 10000 (* Large default to get "all" *)
152
+
in
153
+
let query_inv = Jmap_eio.Client.Build.email_query
154
+
~call_id:"q1"
155
+
~account_id
156
+
~filter
157
+
~sort
158
+
~limit:query_limit
159
+
()
160
+
in
161
+
162
+
let req = Jmap_eio.Client.Build.(
163
+
make_request
164
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
165
+
[query_inv]
166
+
) in
167
+
168
+
match Jmap_eio.Client.request client req with
169
+
| Error e ->
170
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
171
+
exit 1
172
+
| Ok response ->
173
+
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
174
+
| Error e ->
175
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
176
+
exit 1
177
+
| Ok query_result ->
178
+
let email_ids = query_result.ids in
179
+
Jmap_eio.Cli.debug cfg "Found %d Zulip email IDs" (List.length email_ids);
180
+
181
+
if List.length email_ids = 0 then (
182
+
if json_output then
183
+
Fmt.pr "[]@."
184
+
else
185
+
Fmt.pr "No Zulip notification emails found.@."
186
+
) else (
187
+
(* Fetch email details *)
188
+
let get_inv = Jmap_eio.Client.Build.email_get
189
+
~call_id:"g1"
190
+
~account_id
191
+
~ids:email_ids
192
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
193
+
"size"; "receivedAt"; "subject"; "from"]
194
+
()
195
+
in
196
+
let req2 = Jmap_eio.Client.Build.(
197
+
make_request
198
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
199
+
[get_inv]
200
+
) in
201
+
202
+
match Jmap_eio.Client.request client req2 with
203
+
| Error e ->
204
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
205
+
exit 1
206
+
| Ok response2 ->
207
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
208
+
| Error e ->
209
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
210
+
exit 1
211
+
| Ok get_result ->
212
+
(* Parse Zulip subjects and filter successful parses *)
213
+
let zulip_messages =
214
+
get_result.list
215
+
|> List.filter_map Zulip_message.of_email
216
+
in
217
+
218
+
Jmap_eio.Cli.debug cfg "Parsed %d Zulip messages from %d emails"
219
+
(List.length zulip_messages)
220
+
(List.length get_result.list);
221
+
222
+
if json_output then (
223
+
(* Output as JSON *)
224
+
match Jsont_bytesrw.encode_string' ~format:Jsont.Indent Zulip_message.list_jsont zulip_messages with
225
+
| Ok json_str -> Fmt.pr "%s@." json_str
226
+
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e)
227
+
) else (
228
+
(* Human-readable output *)
229
+
Fmt.pr "@[<v>%a (%d messages)@,@,"
230
+
Fmt.(styled `Bold string) "Zulip Notifications"
231
+
(List.length zulip_messages);
232
+
233
+
(* Group by server, then by channel *)
234
+
let by_server = Hashtbl.create 8 in
235
+
List.iter (fun (msg : Zulip_message.t) ->
236
+
let existing = try Hashtbl.find by_server msg.server with Not_found -> [] in
237
+
Hashtbl.replace by_server msg.server (msg :: existing)
238
+
) zulip_messages;
239
+
240
+
Hashtbl.iter (fun server msgs ->
241
+
Fmt.pr "%a [%s]@,"
242
+
Fmt.(styled `Bold string) "Server:"
243
+
server;
244
+
245
+
(* Group by channel within server *)
246
+
let by_channel = Hashtbl.create 8 in
247
+
List.iter (fun (msg : Zulip_message.t) ->
248
+
let existing = try Hashtbl.find by_channel msg.channel with Not_found -> [] in
249
+
Hashtbl.replace by_channel msg.channel (msg :: existing)
250
+
) msgs;
251
+
252
+
Hashtbl.iter (fun channel channel_msgs ->
253
+
Fmt.pr " %a #%s (%d)@,"
254
+
Fmt.(styled `Cyan string) "Channel:"
255
+
channel
256
+
(List.length channel_msgs);
257
+
258
+
(* Sort by date descending *)
259
+
let sorted = List.sort (fun a b ->
260
+
Ptime.compare b.Zulip_message.date a.Zulip_message.date
261
+
) channel_msgs in
262
+
263
+
List.iter (fun (msg : Zulip_message.t) ->
264
+
let read_marker = if msg.is_read then " " else "*" in
265
+
let labels_str = match msg.labels with
266
+
| [] -> ""
267
+
| ls -> " [" ^ String.concat ", " ls ^ "]"
268
+
in
269
+
Fmt.pr " %s %s %a %s%s@,"
270
+
read_marker
271
+
(ptime_to_string msg.date)
272
+
Fmt.(styled `Yellow string) (truncate_string 40 msg.topic)
273
+
(truncate_string 12 msg.id)
274
+
labels_str
275
+
) sorted;
276
+
Fmt.pr "@,"
277
+
) by_channel
278
+
) by_server;
279
+
280
+
Fmt.pr "@]@."
281
+
)
282
+
)
283
+
in
284
+
let doc = "List Zulip notification emails with parsed channel/topic info" in
285
+
let man = [
286
+
`S Manpage.s_description;
287
+
`P "Lists all emails from noreply@zulip.com and parses the subject line to extract \
288
+
the Zulip channel, topic, and server name.";
289
+
`P "Subject format expected: \"#Channel > topic [Server Name]\"";
290
+
`S Manpage.s_examples;
291
+
`P "List all Zulip notifications:";
292
+
`Pre " jmapq zulip-list";
293
+
`P "Output as JSON:";
294
+
`Pre " jmapq zulip-list --json";
295
+
`P "Limit to 50 most recent:";
296
+
`Pre " jmapq zulip-list -n 50";
297
+
] in
298
+
let info = Cmd.info "zulip-list" ~doc ~man in
299
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ json_term $ limit_term)
300
+
301
+
(** {1 Zulip Timeout Command} *)
302
+
303
+
(** The keyword used to mark Zulip notifications as processed *)
304
+
let zulip_processed_keyword = "zulip-processed"
305
+
306
+
let zulip_timeout_cmd =
307
+
let email_ids_term =
308
+
let doc = "Email IDs to mark as processed" in
309
+
Arg.(non_empty & pos_all string [] & info [] ~docv:"EMAIL_ID" ~doc)
310
+
in
311
+
let verbose_term =
312
+
let doc = "Show the raw JMAP server response" in
313
+
Arg.(value & flag & info ["v"; "verbose"] ~doc)
314
+
in
315
+
let run cfg verbose email_id_strs =
316
+
Eio_main.run @@ fun env ->
317
+
Eio.Switch.run @@ fun sw ->
318
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
319
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
320
+
let email_ids = List.map Jmap.Proto.Id.of_string_exn email_id_strs in
321
+
322
+
Jmap_eio.Cli.debug cfg "Marking %d email(s) with '%s' keyword"
323
+
(List.length email_ids) zulip_processed_keyword;
324
+
325
+
(* Build patch to add the zulip-processed keyword and mark as read *)
326
+
let patch =
327
+
let open Jmap_eio.Chain in
328
+
json_obj [
329
+
("keywords/" ^ zulip_processed_keyword, json_bool true);
330
+
("keywords/$seen", json_bool true);
331
+
]
332
+
in
333
+
334
+
(* Build updates list: each email ID gets the same patch *)
335
+
let updates = List.map (fun id -> (id, patch)) email_ids in
336
+
337
+
let open Jmap_eio.Chain in
338
+
let request, set_h = build
339
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
340
+
begin
341
+
email_set ~account_id
342
+
~update:updates
343
+
()
344
+
end in
345
+
346
+
match Jmap_eio.Client.request client request with
347
+
| Error e ->
348
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
349
+
exit 1
350
+
| Ok response ->
351
+
(* Print raw response if verbose *)
352
+
if verbose then begin
353
+
Fmt.pr "@[<v>%a:@," Fmt.(styled `Bold string) "Server Response";
354
+
(match Jsont_bytesrw.encode_string' ~format:Jsont.Indent
355
+
Jmap.Proto.Response.jsont response with
356
+
| Ok json_str -> Fmt.pr "%s@,@]@." json_str
357
+
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e))
358
+
end;
359
+
(* Check for JMAP method-level errors first *)
360
+
let call_id = Jmap_eio.Chain.call_id set_h in
361
+
(match Jmap.Proto.Response.find_response call_id response with
362
+
| None ->
363
+
Fmt.epr "Error: No response found for call_id %s@." call_id;
364
+
exit 1
365
+
| Some inv when Jmap.Proto.Response.is_error inv ->
366
+
(match Jmap.Proto.Response.get_error inv with
367
+
| Some err ->
368
+
Fmt.epr "JMAP Error: %s%s@."
369
+
(Jmap.Proto.Error.method_error_type_to_string err.type_)
370
+
(match err.description with Some d -> " - " ^ d | None -> "");
371
+
exit 1
372
+
| None ->
373
+
Fmt.epr "JMAP Error: Unknown error@.";
374
+
exit 1)
375
+
| Some _ ->
376
+
match parse set_h response with
377
+
| Error e ->
378
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
379
+
exit 1
380
+
| Ok result ->
381
+
(* Report successes *)
382
+
let updated_ids =
383
+
result.updated
384
+
|> Option.value ~default:[]
385
+
|> List.map (fun (id, _) -> Jmap.Proto.Id.to_string id)
386
+
in
387
+
if List.length updated_ids > 0 then begin
388
+
Fmt.pr "@[<v>%a %d email(s) as read with '%s':@,"
389
+
Fmt.(styled `Green string) "Marked"
390
+
(List.length updated_ids)
391
+
zulip_processed_keyword;
392
+
List.iter (fun id -> Fmt.pr " %s@," id) updated_ids;
393
+
Fmt.pr "@]@."
394
+
end;
395
+
396
+
(* Report failures *)
397
+
let not_updated = Option.value ~default:[] result.not_updated in
398
+
if not_updated <> [] then begin
399
+
Fmt.epr "@[<v>%a to mark %d email(s):@,"
400
+
Fmt.(styled `Red string) "Failed"
401
+
(List.length not_updated);
402
+
List.iter (fun (id, err) ->
403
+
let open Jmap.Proto.Error in
404
+
let err_type = set_error_type_to_string err.type_ in
405
+
let err_desc = Option.value ~default:"" err.description in
406
+
Fmt.epr " %s: %s%s@,"
407
+
(Jmap.Proto.Id.to_string id)
408
+
err_type
409
+
(if err_desc = "" then "" else " - " ^ err_desc)
410
+
) not_updated;
411
+
Fmt.epr "@]@.";
412
+
exit 1
413
+
end)
414
+
in
415
+
let doc = "Mark Zulip notification emails as processed" in
416
+
let man = [
417
+
`S Manpage.s_description;
418
+
`P (Printf.sprintf "Adds the '%s' keyword to the specified email(s). \
419
+
This keyword can be used to filter processed Zulip notifications \
420
+
or set up server-side rules to auto-archive them."
421
+
zulip_processed_keyword);
422
+
`S Manpage.s_examples;
423
+
`P "Mark a single email as processed:";
424
+
`Pre " jmapq zulip-timeout StrrDTS_WEa3";
425
+
`P "Mark multiple emails as processed:";
426
+
`Pre " jmapq zulip-timeout StrrDTS_WEa3 StrsGZ7P8Dpc StrsGuCSXJ3Z";
427
+
] in
428
+
let info = Cmd.info "zulip-timeout" ~doc ~man in
429
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ verbose_term $ email_ids_term)
430
+
431
+
(** {1 Zulip View Command} *)
432
+
433
+
let zulip_view_cmd =
434
+
let json_term =
435
+
let doc = "Output as JSON" in
436
+
Arg.(value & flag & info ["json"] ~doc)
437
+
in
438
+
let limit_term =
439
+
let doc = "Maximum number of messages to fetch (default: all)" in
440
+
Arg.(value & opt (some int) None & info ["limit"; "n"] ~docv:"N" ~doc)
441
+
in
442
+
let verbose_term =
443
+
let doc = "Show the raw JMAP request and response" in
444
+
Arg.(value & flag & info ["v"; "verbose"] ~doc)
445
+
in
446
+
let run cfg json_output limit verbose =
447
+
Eio_main.run @@ fun env ->
448
+
Eio.Switch.run @@ fun sw ->
449
+
let client = Jmap_eio.Cli.create_client ~sw env cfg in
450
+
let account_id = Jmap_eio.Cli.get_account_id cfg client in
451
+
452
+
Jmap_eio.Cli.debug cfg "Searching for Zulip emails marked as processed";
453
+
454
+
(* Build filter for emails from noreply@zulip.com with zulip-processed keyword *)
455
+
let cond : Jmap.Proto.Email.Filter_condition.t = {
456
+
in_mailbox = None; in_mailbox_other_than = None;
457
+
before = None; after = None;
458
+
min_size = None; max_size = None;
459
+
all_in_thread_have_keyword = None;
460
+
some_in_thread_have_keyword = None;
461
+
none_in_thread_have_keyword = None;
462
+
has_keyword = Some zulip_processed_keyword;
463
+
not_keyword = None;
464
+
has_attachment = None;
465
+
text = None;
466
+
from = Some "noreply@zulip.com";
467
+
to_ = None;
468
+
cc = None; bcc = None; subject = None;
469
+
body = None; header = None;
470
+
} in
471
+
let filter = Jmap.Proto.Filter.Condition cond in
472
+
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
473
+
474
+
(* Query for processed Zulip emails *)
475
+
let query_limit = match limit with
476
+
| Some n -> Int64.of_int n
477
+
| None -> Int64.of_int 10000
478
+
in
479
+
let query_inv = Jmap_eio.Client.Build.email_query
480
+
~call_id:"q1"
481
+
~account_id
482
+
~filter
483
+
~sort
484
+
~limit:query_limit
485
+
()
486
+
in
487
+
488
+
let req = Jmap_eio.Client.Build.(
489
+
make_request
490
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
491
+
[query_inv]
492
+
) in
493
+
494
+
(* Print request if verbose *)
495
+
if verbose then begin
496
+
Fmt.pr "@[<v>%a:@," Fmt.(styled `Bold string) "Request";
497
+
(match Jsont_bytesrw.encode_string' ~format:Jsont.Indent
498
+
Jmap.Proto.Request.jsont req with
499
+
| Ok json_str -> Fmt.pr "%s@,@]@." json_str
500
+
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e))
501
+
end;
502
+
503
+
match Jmap_eio.Client.request client req with
504
+
| Error e ->
505
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
506
+
exit 1
507
+
| Ok response ->
508
+
(* Print response if verbose *)
509
+
if verbose then begin
510
+
Fmt.pr "@[<v>%a:@," Fmt.(styled `Bold string) "Response";
511
+
(match Jsont_bytesrw.encode_string' ~format:Jsont.Indent
512
+
Jmap.Proto.Response.jsont response with
513
+
| Ok json_str -> Fmt.pr "%s@,@]@." json_str
514
+
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e))
515
+
end;
516
+
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
517
+
| Error e ->
518
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
519
+
exit 1
520
+
| Ok query_result ->
521
+
let email_ids = query_result.ids in
522
+
Jmap_eio.Cli.debug cfg "Found %d processed Zulip email IDs" (List.length email_ids);
523
+
524
+
if List.length email_ids = 0 then (
525
+
if json_output then
526
+
Fmt.pr "[]@."
527
+
else
528
+
Fmt.pr "No Zulip emails marked as processed.@."
529
+
) else (
530
+
(* Fetch email details *)
531
+
let get_inv = Jmap_eio.Client.Build.email_get
532
+
~call_id:"g1"
533
+
~account_id
534
+
~ids:email_ids
535
+
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
536
+
"size"; "receivedAt"; "subject"; "from"]
537
+
()
538
+
in
539
+
let req2 = Jmap_eio.Client.Build.(
540
+
make_request
541
+
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
542
+
[get_inv]
543
+
) in
544
+
545
+
match Jmap_eio.Client.request client req2 with
546
+
| Error e ->
547
+
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
548
+
exit 1
549
+
| Ok response2 ->
550
+
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
551
+
| Error e ->
552
+
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
553
+
exit 1
554
+
| Ok get_result ->
555
+
(* Parse Zulip subjects and filter successful parses *)
556
+
let zulip_messages =
557
+
get_result.list
558
+
|> List.filter_map Zulip_message.of_email
559
+
in
560
+
561
+
Jmap_eio.Cli.debug cfg "Parsed %d Zulip messages from %d emails"
562
+
(List.length zulip_messages)
563
+
(List.length get_result.list);
564
+
565
+
if json_output then (
566
+
(* Output as JSON *)
567
+
match Jsont_bytesrw.encode_string' ~format:Jsont.Indent Zulip_message.list_jsont zulip_messages with
568
+
| Ok json_str -> Fmt.pr "%s@." json_str
569
+
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e)
570
+
) else (
571
+
(* Human-readable output *)
572
+
Fmt.pr "@[<v>%a (%d messages)@,@,"
573
+
Fmt.(styled `Bold string) "Processed Zulip Notifications"
574
+
(List.length zulip_messages);
575
+
576
+
(* Group by server, then by channel *)
577
+
let by_server = Hashtbl.create 8 in
578
+
List.iter (fun (msg : Zulip_message.t) ->
579
+
let existing = try Hashtbl.find by_server msg.server with Not_found -> [] in
580
+
Hashtbl.replace by_server msg.server (msg :: existing)
581
+
) zulip_messages;
582
+
583
+
Hashtbl.iter (fun server msgs ->
584
+
Fmt.pr "%a [%s]@,"
585
+
Fmt.(styled `Bold string) "Server:"
586
+
server;
587
+
588
+
(* Group by channel within server *)
589
+
let by_channel = Hashtbl.create 8 in
590
+
List.iter (fun (msg : Zulip_message.t) ->
591
+
let existing = try Hashtbl.find by_channel msg.channel with Not_found -> [] in
592
+
Hashtbl.replace by_channel msg.channel (msg :: existing)
593
+
) msgs;
594
+
595
+
Hashtbl.iter (fun channel channel_msgs ->
596
+
Fmt.pr " %a #%s (%d)@,"
597
+
Fmt.(styled `Cyan string) "Channel:"
598
+
channel
599
+
(List.length channel_msgs);
600
+
601
+
(* Sort by date descending *)
602
+
let sorted = List.sort (fun a b ->
603
+
Ptime.compare b.Zulip_message.date a.Zulip_message.date
604
+
) channel_msgs in
605
+
606
+
List.iter (fun (msg : Zulip_message.t) ->
607
+
let read_marker = if msg.is_read then " " else "*" in
608
+
let labels_str = match msg.labels with
609
+
| [] -> ""
610
+
| ls -> " [" ^ String.concat ", " ls ^ "]"
611
+
in
612
+
Fmt.pr " %s %s %a %s%s@,"
613
+
read_marker
614
+
(ptime_to_string msg.date)
615
+
Fmt.(styled `Yellow string) (truncate_string 40 msg.topic)
616
+
(truncate_string 12 msg.id)
617
+
labels_str
618
+
) sorted;
619
+
Fmt.pr "@,"
620
+
) by_channel
621
+
) by_server;
622
+
623
+
Fmt.pr "@]@."
624
+
)
625
+
)
626
+
in
627
+
let doc = "List Zulip emails that have been marked as processed" in
628
+
let man = [
629
+
`S Manpage.s_description;
630
+
`P (Printf.sprintf "Lists all Zulip notification emails that have the '%s' keyword."
631
+
zulip_processed_keyword);
632
+
`S Manpage.s_examples;
633
+
`P "List all processed Zulip notifications:";
634
+
`Pre " jmapq zulip-view";
635
+
`P "Output as JSON:";
636
+
`Pre " jmapq zulip-view --json";
637
+
`P "Limit to 50 most recent:";
638
+
`Pre " jmapq zulip-view -n 50";
639
+
] in
640
+
let info = Cmd.info "zulip-view" ~doc ~man in
641
+
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ json_term $ limit_term $ verbose_term)
642
+
643
+
(** {1 Main Command Group} *)
644
+
645
+
let main_cmd =
646
+
let doc = "JMAPQ - Specialist JMAP workflow commands" in
647
+
let man = [
648
+
`S Manpage.s_description;
649
+
`P "A collection of specialist workflow commands for JMAP email processing.";
650
+
`S Manpage.s_environment;
651
+
`P Jmap_eio.Cli.env_docs;
652
+
] in
653
+
let info = Cmd.info "jmapq" ~version:"0.1.0" ~doc ~man in
654
+
Cmd.group info [
655
+
zulip_list_cmd;
656
+
zulip_timeout_cmd;
657
+
zulip_view_cmd;
658
+
]
659
+
660
+
let () =
661
+
Fmt_tty.setup_std_outputs ();
662
+
exit (Cmd.eval main_cmd)
+8
-8
bin/tutorial_examples.ml
+8
-8
bin/tutorial_examples.ml
···
2
2
3
3
open Lwt.Syntax
4
4
open Jmap
5
-
open Jmap_mail
5
+
open Jmap.Mail
6
6
7
7
(* Example: Authentication *)
8
8
let auth_example () =
···
13
13
Printf.eprintf "Error: JMAP_API_TOKEN environment variable not set\n";
14
14
Lwt.return_none
15
15
| Some token ->
16
-
let+ result = Jmap_mail.login_with_token
16
+
let+ result = Jmap.Proto.login_with_token
17
17
~uri:"https://api.fastmail.com/jmap/session"
18
18
~api_token:token
19
19
in
···
23
23
| Ok conn ->
24
24
(* Get the primary account ID *)
25
25
let account_id =
26
-
let mail_capability = Jmap_mail.Capability.to_string Jmap_mail.Capability.Mail in
26
+
let mail_capability = Jmap.Proto.Capability.to_string Jmap.Proto.Capability.Mail in
27
27
match List.assoc_opt mail_capability conn.session.primary_accounts with
28
28
| Some id -> id
29
29
| None ->
···
45
45
(* Example: Working with Mailboxes *)
46
46
let mailbox_example (conn, account_id) =
47
47
(* Get all mailboxes *)
48
-
let+ mailboxes_result = Jmap_mail.get_mailboxes conn ~account_id in
48
+
let+ mailboxes_result = Jmap.Proto.get_mailboxes conn ~account_id in
49
49
50
50
match mailboxes_result with
51
51
| Ok mailboxes ->
···
78
78
(* Example: Working with Emails *)
79
79
let email_example (conn, account_id, mailbox_id) =
80
80
(* Get emails from mailbox *)
81
-
let+ emails_result = Jmap_mail.get_messages_in_mailbox
81
+
let+ emails_result = Jmap.Proto.get_messages_in_mailbox
82
82
conn
83
83
~account_id
84
84
~mailbox_id
···
91
91
Printf.printf "Found %d emails\n" (List.length emails);
92
92
93
93
(* Display emails *)
94
-
List.iter (fun (email:Jmap_mail.Types.email) ->
94
+
List.iter (fun (email:Jmap.Proto.Types.email) ->
95
95
(* Using explicit module path for Types to avoid ambiguity *)
96
-
let module Mail = Jmap_mail.Types in
96
+
let module Mail = Jmap.Proto.Types in
97
97
98
98
(* Get sender info *)
99
99
let from = match email.Mail.from with
···
127
127
128
128
match emails with
129
129
| [] -> None
130
-
| hd::_ -> Some (conn, account_id, hd.Jmap_mail.Types.id)
130
+
| hd::_ -> Some (conn, account_id, hd.Jmap.Proto.Types.id)
131
131
end
132
132
| Error e ->
133
133
Printf.eprintf "Error getting emails: %s\n"
+7
doc/dune
+7
doc/dune
+13
doc/index.mld
+13
doc/index.mld
···
1
+
{0 jmap}
2
+
3
+
{!modules: Jmap Jmap_top}
4
+
5
+
{1 Tutorial}
6
+
7
+
See the {!page-tutorial} for a comprehensive guide to using JMAP with OCaml,
8
+
including how types map to JSON and practical examples.
9
+
10
+
{1 Browser Support}
11
+
12
+
For browser-based applications, see the [jmap-brr] package which provides
13
+
a JMAP client using the Brr library and js_of_ocaml.
+494
doc/tutorial.mld
+494
doc/tutorial.mld
···
1
+
{0 JMAP Tutorial}
2
+
3
+
This tutorial introduces JMAP (JSON Meta Application Protocol) and
4
+
demonstrates the [jmap] OCaml library through interactive examples. JMAP
5
+
is defined in {{:https://www.rfc-editor.org/rfc/rfc8620}RFC 8620} (core)
6
+
and {{:https://www.rfc-editor.org/rfc/rfc8621}RFC 8621} (mail).
7
+
8
+
{1 What is JMAP?}
9
+
10
+
JMAP is a modern, efficient protocol for synchronizing mail and other
11
+
data. It's designed as a better alternative to IMAP, addressing many of
12
+
IMAP's limitations:
13
+
14
+
{ul
15
+
{- {b Stateless over HTTP}: Unlike IMAP's persistent TCP connections, JMAP
16
+
uses standard HTTP POST requests with JSON payloads.}
17
+
{- {b Efficient batching}: Multiple operations can be combined into a single
18
+
request, reducing round-trips.}
19
+
{- {b Result references}: The output of one method call can be used as input
20
+
to another in the same request.}
21
+
{- {b Push support}: Built-in mechanisms for real-time notifications.}
22
+
{- {b Binary data handling}: Separate upload/download endpoints for large
23
+
attachments.}}
24
+
25
+
The core protocol (RFC 8620) defines the general structure, while RFC 8621
26
+
extends it specifically for email, mailboxes, threads, and related objects.
27
+
28
+
{1 Setup}
29
+
30
+
First, let's set up our environment. In the toplevel, load the library
31
+
with [#require "jmap.top";;] which will automatically install pretty
32
+
printers.
33
+
34
+
{@ocaml[
35
+
# Jmap_top.install ();;
36
+
- : unit = ()
37
+
# open Jmap;;
38
+
]}
39
+
40
+
For parsing and encoding JSON, we'll use some helper functions:
41
+
42
+
{@ocaml[
43
+
# let parse_json s =
44
+
match Jsont_bytesrw.decode_string Jsont.json s with
45
+
| Ok json -> json
46
+
| Error e -> failwith e;;
47
+
val parse_json : string -> Jsont.json = <fun>
48
+
# let json_to_string json =
49
+
match Jsont_bytesrw.encode_string ~format:Jsont.Indent Jsont.json json with
50
+
| Ok s -> s
51
+
| Error e -> failwith e;;
52
+
val json_to_string : Jsont.json -> string = <fun>
53
+
]}
54
+
55
+
{1 JMAP Identifiers}
56
+
57
+
From {{:https://www.rfc-editor.org/rfc/rfc8620#section-1.2}RFC 8620 Section 1.2}:
58
+
59
+
{i An "Id" is a String of at least 1 and a maximum of 255 octets in size,
60
+
and it MUST only contain characters from the "URL and Filename Safe"
61
+
base64 alphabet.}
62
+
63
+
The {!Jmap.Id} module provides type-safe identifiers:
64
+
65
+
{@ocaml[
66
+
# let id = Id.of_string_exn "abc123";;
67
+
val id : Id.t = abc123
68
+
# Id.to_string id;;
69
+
- : string = "abc123"
70
+
]}
71
+
72
+
Invalid identifiers are rejected:
73
+
74
+
{@ocaml[
75
+
# Id.of_string "";;
76
+
- : (Id.t, string) result = Error "Id cannot be empty"
77
+
# Id.of_string (String.make 256 'x');;
78
+
- : (Id.t, string) result = Error "Id cannot exceed 255 characters"
79
+
]}
80
+
81
+
{1 Keywords}
82
+
83
+
Email keywords are string flags that indicate message state. RFC 8621
84
+
defines standard keywords, and the library represents them as polymorphic
85
+
variants for type safety.
86
+
87
+
{2 Standard Keywords}
88
+
89
+
From {{:https://www.rfc-editor.org/rfc/rfc8621#section-4.1.1}RFC 8621
90
+
Section 4.1.1}:
91
+
92
+
{@ocaml[
93
+
# Keyword.of_string "$seen";;
94
+
- : Keyword.t = $seen
95
+
# Keyword.of_string "$flagged";;
96
+
- : Keyword.t = $flagged
97
+
# Keyword.of_string "$draft";;
98
+
- : Keyword.t = $draft
99
+
# Keyword.of_string "$answered";;
100
+
- : Keyword.t = $answered
101
+
]}
102
+
103
+
The standard keywords are:
104
+
105
+
{ul
106
+
{- [`Seen] - The email has been read}
107
+
{- [`Flagged] - The email has been flagged for attention}
108
+
{- [`Draft] - The email is a draft being composed}
109
+
{- [`Answered] - The email has been replied to}
110
+
{- [`Forwarded] - The email has been forwarded}
111
+
{- [`Phishing] - The email is likely phishing}
112
+
{- [`Junk] - The email is spam}
113
+
{- [`NotJunk] - The email is definitely not spam}}
114
+
115
+
{2 Extended Keywords}
116
+
117
+
The library also supports draft-ietf-mailmaint extended keywords:
118
+
119
+
{@ocaml[
120
+
# Keyword.of_string "$notify";;
121
+
- : Keyword.t = $notify
122
+
# Keyword.of_string "$muted";;
123
+
- : Keyword.t = $muted
124
+
# Keyword.of_string "$hasattachment";;
125
+
- : Keyword.t = $hasattachment
126
+
]}
127
+
128
+
{2 Custom Keywords}
129
+
130
+
Unknown keywords are preserved as [`Custom]:
131
+
132
+
{@ocaml[
133
+
# Keyword.of_string "$my_custom_flag";;
134
+
- : Keyword.t = $my_custom_flag
135
+
]}
136
+
137
+
{2 Converting Back to Strings}
138
+
139
+
{@ocaml[
140
+
# Keyword.to_string `Seen;;
141
+
- : string = "$seen"
142
+
# Keyword.to_string `Flagged;;
143
+
- : string = "$flagged"
144
+
# Keyword.to_string (`Custom "$important");;
145
+
- : string = "$important"
146
+
]}
147
+
148
+
{1 Mailbox Roles}
149
+
150
+
Mailboxes can have special roles that indicate their purpose. From
151
+
{{:https://www.rfc-editor.org/rfc/rfc8621#section-2}RFC 8621 Section 2}:
152
+
153
+
{@ocaml[
154
+
# Role.of_string "inbox";;
155
+
- : Role.t = inbox
156
+
# Role.of_string "sent";;
157
+
- : Role.t = sent
158
+
# Role.of_string "drafts";;
159
+
- : Role.t = drafts
160
+
# Role.of_string "trash";;
161
+
- : Role.t = trash
162
+
# Role.of_string "junk";;
163
+
- : Role.t = junk
164
+
# Role.of_string "archive";;
165
+
- : Role.t = archive
166
+
]}
167
+
168
+
Custom roles are also supported:
169
+
170
+
{@ocaml[
171
+
# Role.of_string "receipts";;
172
+
- : Role.t = receipts
173
+
]}
174
+
175
+
{1 Capabilities}
176
+
177
+
JMAP uses capability URIs to indicate supported features. From
178
+
{{:https://www.rfc-editor.org/rfc/rfc8620#section-2}RFC 8620 Section 2}:
179
+
180
+
{@ocaml[
181
+
# Capability.core_uri;;
182
+
- : string = "urn:ietf:params:jmap:core"
183
+
# Capability.mail_uri;;
184
+
- : string = "urn:ietf:params:jmap:mail"
185
+
# Capability.submission_uri;;
186
+
- : string = "urn:ietf:params:jmap:submission"
187
+
]}
188
+
189
+
{@ocaml[
190
+
# Capability.of_string Capability.core_uri;;
191
+
- : Capability.t = urn:ietf:params:jmap:core
192
+
# Capability.of_string Capability.mail_uri;;
193
+
- : Capability.t = urn:ietf:params:jmap:mail
194
+
# Capability.of_string "urn:example:custom";;
195
+
- : Capability.t = urn:example:custom
196
+
]}
197
+
198
+
{1 Understanding JMAP JSON Structure}
199
+
200
+
One of the key benefits of JMAP over IMAP is its use of JSON. Let's see
201
+
how OCaml types map to the wire format.
202
+
203
+
{2 Requests}
204
+
205
+
A JMAP request contains:
206
+
- [using]: List of capability URIs required
207
+
- [methodCalls]: Array of method invocations
208
+
209
+
Each method invocation is a triple: [methodName], [arguments], [callId].
210
+
211
+
Here's how a simple request is structured:
212
+
213
+
{x@ocaml[
214
+
# let req = Jmap.Proto.Request.create
215
+
~using:[Capability.core_uri; Capability.mail_uri]
216
+
~method_calls:[
217
+
Jmap.Proto.Invocation.create
218
+
~name:"Mailbox/get"
219
+
~arguments:(parse_json {|{"accountId": "abc123"}|})
220
+
~call_id:"c0"
221
+
]
222
+
();;
223
+
Line 7, characters 18-22:
224
+
Error: The function applied to this argument has type
225
+
method_call_id:string -> Proto.Invocation.t
226
+
This argument cannot be applied with label ~call_id
227
+
# Jmap_top.encode Jmap.Proto.Request.jsont req |> json_to_string |> print_endline;;
228
+
Line 1, characters 42-45:
229
+
Error: Unbound value req
230
+
Hint: Did you mean ref?
231
+
]x}
232
+
233
+
{2 Email Filter Conditions}
234
+
235
+
Filters demonstrate how complex query conditions map to JSON. From
236
+
{{:https://www.rfc-editor.org/rfc/rfc8621#section-4.4.1}RFC 8621
237
+
Section 4.4.1}:
238
+
239
+
{x@ocaml[
240
+
# let filter_condition : Jmap.Proto.Email.Filter_condition.t = {
241
+
in_mailbox = Some (Id.of_string_exn "inbox123");
242
+
in_mailbox_other_than = None;
243
+
before = None;
244
+
after = None;
245
+
min_size = None;
246
+
max_size = None;
247
+
all_in_thread_have_keyword = None;
248
+
some_in_thread_have_keyword = None;
249
+
none_in_thread_have_keyword = None;
250
+
has_keyword = Some "$flagged";
251
+
not_keyword = None;
252
+
has_attachment = Some true;
253
+
text = None;
254
+
from = Some "alice@";
255
+
to_ = None;
256
+
cc = None;
257
+
bcc = None;
258
+
subject = Some "urgent";
259
+
body = None;
260
+
header = None;
261
+
};;
262
+
Line 2, characters 23-52:
263
+
Error: This expression has type Id.t but an expression was expected of type
264
+
Proto.Id.t
265
+
# Jmap_top.encode Jmap.Proto.Email.Filter_condition.jsont filter_condition
266
+
|> json_to_string |> print_endline;;
267
+
Line 1, characters 57-73:
268
+
Error: Unbound value filter_condition
269
+
]x}
270
+
271
+
Notice how:
272
+
- OCaml record fields use [snake_case], but JSON uses [camelCase]
273
+
- [None] values are omitted from JSON (not sent as [null])
274
+
- The filter only includes non-empty conditions
275
+
276
+
{2 Filter Operators}
277
+
278
+
Filters can be combined with AND, OR, and NOT operators:
279
+
280
+
{x@ocaml[
281
+
# let combined_filter = Jmap.Proto.Filter.Operator {
282
+
operator = `And;
283
+
conditions = [
284
+
Condition filter_condition;
285
+
Condition { filter_condition with has_keyword = Some "$seen" }
286
+
]
287
+
};;
288
+
Line 4, characters 17-33:
289
+
Error: Unbound value filter_condition
290
+
]x}
291
+
292
+
{1 Method Chaining}
293
+
294
+
One of JMAP's most powerful features is result references - using the
295
+
output of one method as input to another. The {!Jmap.Chain} module
296
+
provides a monadic interface for building such requests.
297
+
298
+
From {{:https://www.rfc-editor.org/rfc/rfc8620#section-3.7}RFC 8620
299
+
Section 3.7}:
300
+
301
+
{i A method argument may use the result of a previous method invocation
302
+
in the same request.}
303
+
304
+
{2 Basic Example}
305
+
306
+
Query for emails, then fetch their details:
307
+
308
+
{[
309
+
open Jmap.Chain
310
+
311
+
let request, handle = build ~capabilities:[core; mail] begin
312
+
let* query = email_query ~account_id
313
+
~filter:(Condition { in_mailbox = Some inbox_id; (* ... *) })
314
+
~limit:50L ()
315
+
in
316
+
let* emails = email_get ~account_id
317
+
~ids:(from_query query) (* Reference query results! *)
318
+
~properties:["subject"; "from"; "receivedAt"]
319
+
()
320
+
in
321
+
return emails
322
+
end
323
+
][
324
+
{err@mdx-error[
325
+
Line 3, characters 46-50:
326
+
Error: Unbound value core
327
+
]err}]}
328
+
329
+
The key insight is [from_query query] - this creates a reference to the
330
+
[ids] array from the query response. The server processes both calls in
331
+
sequence, substituting the reference with actual IDs.
332
+
333
+
{2 Creation and Submission}
334
+
335
+
Create a draft and send it in one request:
336
+
337
+
{[
338
+
let* set_h, draft_cid = email_set ~account_id
339
+
~create:[("draft1", draft_email_json)]
340
+
()
341
+
in
342
+
let* _ = email_submission_set ~account_id
343
+
~create:[("sub1", submission_json
344
+
~email_id:(created_id_of_string "draft1") (* Reference creation! *)
345
+
~identity_id)]
346
+
()
347
+
in
348
+
return set_h
349
+
][
350
+
{err@mdx-error[
351
+
Line 1, characters 1-5:
352
+
Error: Unbound value ( let* )
353
+
]err}]}
354
+
355
+
{2 The RFC 8620 Example}
356
+
357
+
The RFC provides a complex example: fetch from/date/subject for all
358
+
emails in the first 10 threads in the inbox:
359
+
360
+
{[
361
+
let* q = email_query ~account_id
362
+
~filter:(Condition { in_mailbox = Some inbox_id; (* ... *) })
363
+
~sort:[comparator ~is_ascending:false "receivedAt"]
364
+
~collapse_threads:true ~limit:10L ()
365
+
in
366
+
let* e1 = email_get ~account_id
367
+
~ids:(from_query q)
368
+
~properties:["threadId"]
369
+
()
370
+
in
371
+
let* threads = thread_get ~account_id
372
+
~ids:(from_get_field e1 "threadId") (* Get threadIds from emails *)
373
+
()
374
+
in
375
+
let* e2 = email_get ~account_id
376
+
~ids:(from_get_field threads "emailIds") (* Get all emailIds in threads *)
377
+
~properties:["from"; "receivedAt"; "subject"]
378
+
()
379
+
in
380
+
return e2
381
+
][
382
+
{err@mdx-error[
383
+
Line 1, characters 1-5:
384
+
Error: Unbound value ( let* )
385
+
]err}]}
386
+
387
+
This entire flow executes in a {e single HTTP request}!
388
+
389
+
{1 Error Handling}
390
+
391
+
JMAP has a structured error system with three levels:
392
+
393
+
{2 Request-Level Errors}
394
+
395
+
These are returned with HTTP error status codes and RFC 7807 Problem
396
+
Details. From {{:https://www.rfc-editor.org/rfc/rfc8620#section-3.6.1}RFC
397
+
8620 Section 3.6.1}:
398
+
399
+
{@ocaml[
400
+
# Error.to_string (`Request {
401
+
Error.type_ = "urn:ietf:params:jmap:error:unknownCapability";
402
+
status = Some 400;
403
+
title = Some "Unknown Capability";
404
+
detail = Some "The server does not support 'urn:example:unsupported'";
405
+
limit = None;
406
+
});;
407
+
- : string =
408
+
"Request error: urn:ietf:params:jmap:error:unknownCapability (status 400): The server does not support 'urn:example:unsupported'"
409
+
]}
410
+
411
+
{2 Method-Level Errors}
412
+
413
+
Individual method calls can fail while others succeed:
414
+
415
+
{@ocaml[
416
+
# Error.to_string (`Method {
417
+
Error.type_ = "invalidArguments";
418
+
description = Some "The 'filter' argument is malformed";
419
+
});;
420
+
- : string =
421
+
"Method error: invalidArguments: The 'filter' argument is malformed"
422
+
]}
423
+
424
+
{2 SetError}
425
+
426
+
Object-level errors in /set responses:
427
+
428
+
{@ocaml[
429
+
# Error.to_string (`Set ("draft1", {
430
+
Error.type_ = "invalidProperties";
431
+
description = Some "Unknown property: foobar";
432
+
properties = Some ["foobar"];
433
+
}));;
434
+
- : string =
435
+
"Set error for draft1: invalidProperties: Unknown property: foobar"
436
+
]}
437
+
438
+
{1 Using with FastMail}
439
+
440
+
FastMail is a popular JMAP provider. Here's how to connect:
441
+
442
+
{[
443
+
(* Get a token from https://app.fastmail.com/settings/tokens *)
444
+
let token = "your-api-token"
445
+
446
+
(* The session URL for FastMail *)
447
+
let session_url = "https://api.fastmail.com/jmap/session"
448
+
449
+
(* For browser applications using jmap-brr: *)
450
+
let main () =
451
+
let open Fut.Syntax in
452
+
let* conn = Jmap_brr.get_session
453
+
~url:(Jstr.v session_url)
454
+
~token:(Jstr.v token)
455
+
in
456
+
match conn with
457
+
| Error e -> Brr.Console.(error [str "Error:"; e]); Fut.return ()
458
+
| Ok conn ->
459
+
let session = Jmap_brr.session conn in
460
+
Brr.Console.(log [str "Connected as:";
461
+
str (Jmap.Session.username session)]);
462
+
Fut.return ()
463
+
][
464
+
{err@mdx-error[
465
+
Line 9, characters 14-17:
466
+
Error: Unbound module Fut
467
+
Hint: Did you mean Fun?
468
+
]err}]}
469
+
470
+
{1 Summary}
471
+
472
+
JMAP (RFC 8620/8621) provides a modern, efficient protocol for email:
473
+
474
+
{ol
475
+
{- {b Sessions}: Discover capabilities and account information via GET request}
476
+
{- {b Batching}: Combine multiple method calls in one request}
477
+
{- {b References}: Use results from one method as input to another}
478
+
{- {b Type Safety}: The [jmap] library uses polymorphic variants for keywords and roles}
479
+
{- {b JSON Mapping}: OCaml types map cleanly to JMAP JSON structure}
480
+
{- {b Browser Support}: The [jmap-brr] package enables browser-based clients}}
481
+
482
+
The [jmap] library provides:
483
+
{ul
484
+
{- {!Jmap} - High-level interface with abstract types}
485
+
{- {!Jmap.Proto} - Low-level protocol types matching the RFCs}
486
+
{- {!Jmap.Chain} - Monadic interface for request chaining}
487
+
{- [Jmap_brr] - Browser support via Brr/js_of_ocaml (separate package)}}
488
+
489
+
{2 Key RFC References}
490
+
491
+
{ul
492
+
{- {{:https://www.rfc-editor.org/rfc/rfc8620}RFC 8620}: JMAP Core}
493
+
{- {{:https://www.rfc-editor.org/rfc/rfc8621}RFC 8621}: JMAP for Mail}
494
+
{- {{:https://www.rfc-editor.org/rfc/rfc7807}RFC 7807}: Problem Details for HTTP APIs}}
+25
-14
dune-project
+25
-14
dune-project
···
1
-
(lang dune 3.17)
1
+
(lang dune 3.20)
2
+
3
+
(using mdx 0.4)
2
4
3
5
(name jmap)
4
6
5
-
(source (github avsm/jmap))
7
+
(generate_opam_files true)
8
+
6
9
(license ISC)
7
-
(authors "Anil Madhavapeddy")
8
-
(maintainers "anil@recoil.org")
9
10
10
-
(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)")
11
20
12
21
(package
13
22
(name jmap)
14
-
(synopsis "JMAP protocol")
15
-
(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.")
16
26
(depends
17
-
(ocaml (>= "5.2.0"))
18
-
ptime
19
-
cohttp
20
-
cohttp-lwt-unix
21
-
ezjsonm
22
-
uri
23
-
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
-360
index.mld
-360
index.mld
···
1
-
{0 JMAP OCaml Client}
2
-
3
-
This library provides a type-safe OCaml interface to the JMAP protocol (RFC8620) and JMAP Mail extension (RFC8621).
4
-
5
-
{1 Overview}
6
-
7
-
JMAP (JSON Meta Application Protocol) is a modern protocol for synchronizing email, calendars, and contacts designed as a replacement for legacy protocols like IMAP. This OCaml implementation provides:
8
-
9
-
- Type-safe OCaml interfaces to the JMAP Core and Mail specifications
10
-
- Authentication with username/password or API tokens (Fastmail support)
11
-
- Convenient functions for common email and mailbox operations
12
-
- Support for composing complex multi-part requests with result references
13
-
- Typed handling of message flags, keywords, and mailbox attributes
14
-
15
-
{1 Getting Started}
16
-
17
-
{2 Core Modules}
18
-
19
-
The library is organized into two main packages:
20
-
21
-
- {!module:Jmap} - Core protocol functionality (RFC8620)
22
-
- {!module:Jmap_mail} - Mail-specific extensions (RFC8621)
23
-
24
-
{2 Authentication}
25
-
26
-
To begin working with JMAP, you first need to establish a session:
27
-
28
-
{[
29
-
(* Using username/password *)
30
-
let result = Jmap_mail.login
31
-
~uri:"https://jmap.example.com/jmap/session"
32
-
~credentials:{
33
-
username = "user@example.com";
34
-
password = "password";
35
-
}
36
-
37
-
(* Using a Fastmail API token *)
38
-
let token = Sys.getenv "JMAP_API_TOKEN" in
39
-
let result = Jmap_mail.login_with_token
40
-
~uri:"https://api.fastmail.com/jmap/session"
41
-
~api_token:token
42
-
()
43
-
44
-
(* Handle the result *)
45
-
match result with
46
-
| Ok conn ->
47
-
(* Get the primary account ID *)
48
-
let account_id =
49
-
let mail_capability = Jmap_mail.Capability.to_string Jmap_mail.Capability.Mail in
50
-
match List.assoc_opt mail_capability conn.session.primary_accounts with
51
-
| Some id -> id
52
-
| None -> (* Use first account or handle error *)
53
-
in
54
-
(* Use connection and account_id for further operations *)
55
-
| Error e -> (* Handle error *)
56
-
]}
57
-
58
-
{2 Working with Mailboxes}
59
-
60
-
Once authenticated, you can retrieve and manipulate mailboxes:
61
-
62
-
{[
63
-
(* Get all mailboxes *)
64
-
let get_mailboxes conn account_id =
65
-
Jmap_mail.get_mailboxes conn ~account_id
66
-
67
-
(* Find inbox by role *)
68
-
let find_inbox mailboxes =
69
-
List.find_opt
70
-
(fun m -> m.Jmap_mail.Types.role = Some Jmap_mail.Types.Inbox)
71
-
mailboxes
72
-
]}
73
-
74
-
{2 Working with Emails}
75
-
76
-
Retrieve and filter emails:
77
-
78
-
{[
79
-
(* Get emails from a mailbox *)
80
-
let get_emails conn account_id mailbox_id =
81
-
Jmap_mail.get_messages_in_mailbox
82
-
conn
83
-
~account_id
84
-
~mailbox_id
85
-
~limit:100
86
-
()
87
-
88
-
(* Get only unread emails *)
89
-
let is_unread email =
90
-
List.exists (fun (kw, active) ->
91
-
(kw = Jmap_mail.Types.Unread ||
92
-
kw = Jmap_mail.Types.Custom "$unread") && active
93
-
) email.Jmap_mail.Types.keywords
94
-
95
-
let get_unread_emails conn account_id mailbox_id =
96
-
let* result = get_emails conn account_id mailbox_id in
97
-
match result with
98
-
| Ok emails -> Lwt.return_ok (List.filter is_unread emails)
99
-
| Error e -> Lwt.return_error e
100
-
101
-
(* Filter by sender email *)
102
-
let filter_by_sender emails sender_pattern =
103
-
List.filter (fun email ->
104
-
Jmap_mail.email_matches_sender email sender_pattern
105
-
) emails
106
-
]}
107
-
108
-
{2 Message Flags and Keywords}
109
-
110
-
Work with email flags and keywords:
111
-
112
-
{[
113
-
(* Check if an email has a specific keyword *)
114
-
let has_keyword keyword email =
115
-
List.exists (fun (kw, active) ->
116
-
match kw, active with
117
-
| Jmap_mail.Types.Custom k, true when k = keyword -> true
118
-
| _ -> false
119
-
) email.Jmap_mail.Types.keywords
120
-
121
-
(* Add a keyword to an email *)
122
-
let add_keyword conn account_id email_id keyword =
123
-
(* This would typically involve creating an Email/set request
124
-
that updates the keywords property of the email *)
125
-
failwith "Not fully implemented in this example"
126
-
127
-
(* Get flag color *)
128
-
let get_flag_color email =
129
-
Jmap_mail.Types.get_flag_color email.Jmap_mail.Types.keywords
130
-
131
-
(* Set flag color *)
132
-
let set_flag_color conn account_id email_id color =
133
-
Jmap_mail.Types.set_flag_color conn account_id email_id color
134
-
]}
135
-
136
-
{2 Composing Requests with Result References}
137
-
138
-
JMAP allows composing multiple operations into a single request:
139
-
140
-
{[
141
-
(* Example demonstrating result references for chained requests *)
142
-
let demo_result_references conn account_id =
143
-
let open Jmap.Types in
144
-
145
-
(* Create method call IDs *)
146
-
let mailbox_get_id = "mailboxGet" in
147
-
let email_query_id = "emailQuery" in
148
-
let email_get_id = "emailGet" in
149
-
150
-
(* First call: Get mailboxes *)
151
-
let mailbox_get_call = {
152
-
name = "Mailbox/get";
153
-
arguments = `O [
154
-
("accountId", `String account_id);
155
-
];
156
-
method_call_id = mailbox_get_id;
157
-
} in
158
-
159
-
(* Second call: Query emails in the first mailbox using result reference *)
160
-
let mailbox_id_ref = Jmap.ResultReference.create
161
-
~result_of:mailbox_get_id
162
-
~name:"Mailbox/get"
163
-
~path:"/list/0/id" in
164
-
165
-
let (mailbox_id_ref_key, mailbox_id_ref_value) =
166
-
Jmap.ResultReference.reference_arg "inMailbox" mailbox_id_ref in
167
-
168
-
let email_query_call = {
169
-
name = "Email/query";
170
-
arguments = `O [
171
-
("accountId", `String account_id);
172
-
("filter", `O [
173
-
(mailbox_id_ref_key, mailbox_id_ref_value)
174
-
]);
175
-
("limit", `Float 10.0);
176
-
];
177
-
method_call_id = email_query_id;
178
-
} in
179
-
180
-
(* Third call: Get full email objects using the query result *)
181
-
let email_ids_ref = Jmap.ResultReference.create
182
-
~result_of:email_query_id
183
-
~name:"Email/query"
184
-
~path:"/ids" in
185
-
186
-
let (email_ids_ref_key, email_ids_ref_value) =
187
-
Jmap.ResultReference.reference_arg "ids" email_ids_ref in
188
-
189
-
let email_get_call = {
190
-
name = "Email/get";
191
-
arguments = `O [
192
-
("accountId", `String account_id);
193
-
(email_ids_ref_key, email_ids_ref_value)
194
-
];
195
-
method_call_id = email_get_id;
196
-
} in
197
-
198
-
(* Create the complete request with all three method calls *)
199
-
let request = {
200
-
using = [
201
-
Jmap.Capability.to_string Jmap.Capability.Core;
202
-
Jmap_mail.Capability.to_string Jmap_mail.Capability.Mail
203
-
];
204
-
method_calls = [
205
-
mailbox_get_call;
206
-
email_query_call;
207
-
email_get_call
208
-
];
209
-
created_ids = None;
210
-
} in
211
-
212
-
(* Execute the request *)
213
-
Jmap.Api.make_request conn.config request
214
-
]}
215
-
216
-
{1 Example: List Recent Emails}
217
-
218
-
Here's a complete example showing how to list recent emails from a mailbox:
219
-
220
-
{[
221
-
open Lwt.Syntax
222
-
open Jmap
223
-
open Jmap_mail
224
-
225
-
(* Main function that demonstrates JMAP functionality *)
226
-
let main () =
227
-
(* Initialize logging *)
228
-
Jmap.init_logging ~level:2 ~enable_logs:true ~redact_sensitive:true ();
229
-
230
-
(* Check for API token *)
231
-
match Sys.getenv_opt "JMAP_API_TOKEN" with
232
-
| None ->
233
-
Printf.eprintf "Error: JMAP_API_TOKEN environment variable not set\n";
234
-
Lwt.return 1
235
-
| Some token ->
236
-
(* Authentication example *)
237
-
let* login_result = Jmap_mail.login_with_token
238
-
~uri:"https://api.fastmail.com/jmap/session"
239
-
~api_token:token
240
-
in
241
-
242
-
match login_result with
243
-
| Error err ->
244
-
Printf.eprintf "Authentication failed\n";
245
-
Lwt.return 1
246
-
247
-
| Ok conn ->
248
-
(* Get primary account ID *)
249
-
let mail_capability = Jmap_mail.Capability.to_string Jmap_mail.Capability.Mail in
250
-
let account_id =
251
-
match List.assoc_opt mail_capability conn.session.primary_accounts with
252
-
| Some id -> id
253
-
| None ->
254
-
match conn.session.accounts with
255
-
| (id, _) :: _ -> id
256
-
| [] ->
257
-
Printf.eprintf "No accounts found\n";
258
-
exit 1
259
-
in
260
-
261
-
(* Get mailboxes example *)
262
-
let* mailboxes_result = Jmap_mail.get_mailboxes conn ~account_id in
263
-
264
-
match mailboxes_result with
265
-
| Error err ->
266
-
Printf.eprintf "Failed to get mailboxes\n";
267
-
Lwt.return 1
268
-
269
-
| Ok mailboxes ->
270
-
(* Use the first mailbox for simplicity *)
271
-
match mailboxes with
272
-
| [] ->
273
-
Printf.eprintf "No mailboxes found\n";
274
-
Lwt.return 1
275
-
276
-
| first_mailbox :: _ ->
277
-
(* Get emails example *)
278
-
let* emails_result = Jmap_mail.get_messages_in_mailbox
279
-
conn
280
-
~account_id
281
-
~mailbox_id:first_mailbox.Types.id
282
-
~limit:5
283
-
()
284
-
in
285
-
286
-
match emails_result with
287
-
| Error err ->
288
-
Printf.eprintf "Failed to get emails\n";
289
-
Lwt.return 1
290
-
291
-
| Ok emails ->
292
-
(* Display emails *)
293
-
List.iter (fun email ->
294
-
let module Mail = Jmap_mail.Types in
295
-
296
-
(* Get sender *)
297
-
let sender = match email.Mail.from with
298
-
| None -> "<unknown>"
299
-
| Some addrs ->
300
-
match addrs with
301
-
| [] -> "<unknown>"
302
-
| addr :: _ ->
303
-
match addr.Mail.name with
304
-
| None -> addr.Mail.email
305
-
| Some name ->
306
-
Printf.sprintf "%s <%s>" name addr.Mail.email
307
-
in
308
-
309
-
(* Get subject *)
310
-
let subject = match email.Mail.subject with
311
-
| None -> "<no subject>"
312
-
| Some s -> s
313
-
in
314
-
315
-
(* Is unread? *)
316
-
let is_unread = List.exists (fun (kw, active) ->
317
-
match kw with
318
-
| Mail.Unread -> active
319
-
| Mail.Custom s when s = "$unread" -> active
320
-
| _ -> false
321
-
) email.Mail.keywords in
322
-
323
-
(* Print email info *)
324
-
Printf.printf "[%s] %s - %s\n"
325
-
(if is_unread then "UNREAD" else "READ")
326
-
sender
327
-
subject
328
-
) emails;
329
-
330
-
Lwt.return 0
331
-
332
-
(* Program entry point *)
333
-
let () =
334
-
let exit_code = Lwt_main.run (main ()) in
335
-
exit exit_code
336
-
]}
337
-
338
-
{1 API Reference}
339
-
340
-
{2 Core Modules}
341
-
342
-
- {!module:Jmap} - Core JMAP protocol
343
-
- {!module:Jmap.Types} - Core type definitions
344
-
- {!module:Jmap.Api} - HTTP client and session handling
345
-
- {!module:Jmap.ResultReference} - Request composition utilities
346
-
- {!module:Jmap.Capability} - JMAP capability handling
347
-
348
-
{2 Mail Extension Modules}
349
-
350
-
- {!module:Jmap_mail} - JMAP Mail extension
351
-
- {!module:Jmap_mail.Types} - Mail-specific types
352
-
- Jmap_mail.Capability - Mail capability handling
353
-
- Jmap_mail.Json - JSON serialization
354
-
- Specialized operations for emails, mailboxes, threads, and identities
355
-
356
-
{1 References}
357
-
358
-
- {{:https://datatracker.ietf.org/doc/html/rfc8620}} RFC8620: The JSON Meta Application Protocol (JMAP)
359
-
- {{:https://datatracker.ietf.org/doc/html/rfc8621}} RFC8621: The JSON Meta Application Protocol (JMAP) for Mail
360
-
- {{:https://datatracker.ietf.org/doc/html/draft-ietf-mailmaint-messageflag-mailboxattribute-02}} Message Flag and Mailbox Attribute Extension
+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
+38
-8
lib/dune
+38
-8
lib/dune
···
1
+
(include_subdirs unqualified)
2
+
1
3
(library
2
4
(name jmap)
3
5
(public_name jmap)
4
-
(modules jmap)
5
-
(libraries str ezjsonm ptime cohttp cohttp-lwt-unix uri lwt logs logs.fmt))
6
-
7
-
(library
8
-
(name jmap_mail)
9
-
(public_name jmap.mail)
10
-
(modules jmap_mail)
11
-
(libraries 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))
-804
lib/jmap.ml
-804
lib/jmap.ml
···
1
-
(**
2
-
* JMAP protocol implementation based on RFC8620
3
-
* https://datatracker.ietf.org/doc/html/rfc8620
4
-
*)
5
-
6
-
(** Whether to redact sensitive information *)
7
-
let should_redact_sensitive = ref true
8
-
9
-
(** Initialize and configure logging for JMAP *)
10
-
let init_logging ?(level=2) ?(enable_logs=true) ?(redact_sensitive=true) () =
11
-
if enable_logs then begin
12
-
Logs.set_reporter (Logs.format_reporter ());
13
-
match level with
14
-
| 0 -> Logs.set_level None
15
-
| 1 -> Logs.set_level (Some Logs.Error)
16
-
| 2 -> Logs.set_level (Some Logs.Info)
17
-
| 3 -> Logs.set_level (Some Logs.Debug)
18
-
| _ -> Logs.set_level (Some Logs.Debug)
19
-
end else
20
-
Logs.set_level None;
21
-
should_redact_sensitive := redact_sensitive
22
-
23
-
(** Redact sensitive data like tokens *)
24
-
let redact_token ?(redact=true) token =
25
-
if redact && !should_redact_sensitive && String.length token > 8 then
26
-
let prefix = String.sub token 0 4 in
27
-
let suffix = String.sub token (String.length token - 4) 4 in
28
-
prefix ^ "..." ^ suffix
29
-
else
30
-
token
31
-
32
-
(** Redact sensitive headers like Authorization *)
33
-
let redact_headers headers =
34
-
List.map (fun (k, v) ->
35
-
if String.lowercase_ascii k = "authorization" then
36
-
if !should_redact_sensitive then
37
-
let parts = String.split_on_char ' ' v in
38
-
match parts with
39
-
| scheme :: token :: _ -> (k, scheme ^ " " ^ redact_token token)
40
-
| _ -> (k, v)
41
-
else (k, v)
42
-
else (k, v)
43
-
) headers
44
-
45
-
(* Initialize logging with defaults *)
46
-
let () = init_logging ()
47
-
48
-
(** Module for managing JMAP capability URIs and other constants *)
49
-
module Capability = struct
50
-
(** JMAP capability URI as specified in RFC8620 *)
51
-
let core_uri = "urn:ietf:params:jmap:core"
52
-
53
-
(** All JMAP capability types *)
54
-
type t =
55
-
| Core (** Core JMAP capability *)
56
-
| Extension of string (** Extension capabilities *)
57
-
58
-
(** Convert capability to URI string *)
59
-
let to_string = function
60
-
| Core -> core_uri
61
-
| Extension s -> s
62
-
63
-
(** Parse a string to a capability, returns Extension for non-core capabilities *)
64
-
let of_string s =
65
-
if s = core_uri then Core
66
-
else Extension s
67
-
68
-
(** Check if a capability matches a core capability *)
69
-
let is_core = function
70
-
| Core -> true
71
-
| Extension _ -> false
72
-
73
-
(** Check if a capability string is a core capability *)
74
-
let is_core_string s = s = core_uri
75
-
76
-
(** Create a list of capability strings *)
77
-
let strings_of_capabilities capabilities =
78
-
List.map to_string capabilities
79
-
end
80
-
81
-
module Types = struct
82
-
(** Id string as per Section 1.2 *)
83
-
type id = string
84
-
85
-
(** Int bounded within the range -2^53+1 to 2^53-1 as per Section 1.3 *)
86
-
type int_t = int
87
-
88
-
(** UnsignedInt bounded within the range 0 to 2^53-1 as per Section 1.3 *)
89
-
type unsigned_int = int
90
-
91
-
(** Date string in RFC3339 format as per Section 1.4 *)
92
-
type date = string
93
-
94
-
(** UTCDate is a Date with 'Z' time zone as per Section 1.4 *)
95
-
type utc_date = string
96
-
97
-
(** Error object as per Section 3.6.2 *)
98
-
type error = {
99
-
type_: string;
100
-
description: string option;
101
-
}
102
-
103
-
(** Set error object as per Section 5.3 *)
104
-
type set_error = {
105
-
type_: string;
106
-
description: string option;
107
-
properties: string list option;
108
-
(* Additional properties for specific error types *)
109
-
existing_id: id option; (* For alreadyExists error *)
110
-
}
111
-
112
-
(** Invocation object as per Section 3.2 *)
113
-
type 'a invocation = {
114
-
name: string;
115
-
arguments: 'a;
116
-
method_call_id: string;
117
-
}
118
-
119
-
(** ResultReference object as per Section 3.7 *)
120
-
type result_reference = {
121
-
result_of: string;
122
-
name: string;
123
-
path: string;
124
-
}
125
-
126
-
(** FilterOperator, FilterCondition and Filter as per Section 5.5 *)
127
-
type filter_operator = {
128
-
operator: string; (* "AND", "OR", "NOT" *)
129
-
conditions: filter list;
130
-
}
131
-
and filter_condition = (string * Ezjsonm.value) list
132
-
and filter =
133
-
| Operator of filter_operator
134
-
| Condition of filter_condition
135
-
136
-
(** Comparator object for sorting as per Section 5.5 *)
137
-
type comparator = {
138
-
property: string;
139
-
is_ascending: bool option; (* Optional, defaults to true *)
140
-
collation: string option; (* Optional, server-dependent default *)
141
-
}
142
-
143
-
(** PatchObject as per Section 5.3 *)
144
-
type patch_object = (string * Ezjsonm.value) list
145
-
146
-
(** AddedItem structure as per Section 5.6 *)
147
-
type added_item = {
148
-
id: id;
149
-
index: unsigned_int;
150
-
}
151
-
152
-
(** Account object as per Section 1.6.2 *)
153
-
type account = {
154
-
name: string;
155
-
is_personal: bool;
156
-
is_read_only: bool;
157
-
account_capabilities: (string * Ezjsonm.value) list;
158
-
}
159
-
160
-
(** Core capability object as per Section 2 *)
161
-
type core_capability = {
162
-
max_size_upload: unsigned_int;
163
-
max_concurrent_upload: unsigned_int;
164
-
max_size_request: unsigned_int;
165
-
max_concurrent_requests: unsigned_int;
166
-
max_calls_in_request: unsigned_int;
167
-
max_objects_in_get: unsigned_int;
168
-
max_objects_in_set: unsigned_int;
169
-
collation_algorithms: string list;
170
-
}
171
-
172
-
(** PushSubscription keys object as per Section 7.2 *)
173
-
type push_keys = {
174
-
p256dh: string;
175
-
auth: string;
176
-
}
177
-
178
-
(** Session object as per Section 2 *)
179
-
type session = {
180
-
capabilities: (string * Ezjsonm.value) list;
181
-
accounts: (id * account) list;
182
-
primary_accounts: (string * id) list;
183
-
username: string;
184
-
api_url: string;
185
-
download_url: string;
186
-
upload_url: string;
187
-
event_source_url: string option;
188
-
state: string;
189
-
}
190
-
191
-
(** TypeState for state changes as per Section 7.1 *)
192
-
type type_state = (string * string) list
193
-
194
-
(** StateChange object as per Section 7.1 *)
195
-
type state_change = {
196
-
changed: (id * type_state) list;
197
-
}
198
-
199
-
(** PushVerification object as per Section 7.2.2 *)
200
-
type push_verification = {
201
-
push_subscription_id: id;
202
-
verification_code: string;
203
-
}
204
-
205
-
(** PushSubscription object as per Section 7.2 *)
206
-
type push_subscription = {
207
-
id: id;
208
-
device_client_id: string;
209
-
url: string;
210
-
keys: push_keys option;
211
-
verification_code: string option;
212
-
expires: utc_date option;
213
-
types: string list option;
214
-
}
215
-
216
-
(** Request object as per Section 3.3 *)
217
-
type request = {
218
-
using: string list;
219
-
method_calls: Ezjsonm.value invocation list;
220
-
created_ids: (id * id) list option;
221
-
}
222
-
223
-
(** Response object as per Section 3.4 *)
224
-
type response = {
225
-
method_responses: Ezjsonm.value invocation list;
226
-
created_ids: (id * id) list option;
227
-
session_state: string;
228
-
}
229
-
230
-
(** Standard method arguments and responses *)
231
-
232
-
(** Arguments for Foo/get method as per Section 5.1 *)
233
-
type 'a get_arguments = {
234
-
account_id: id;
235
-
ids: id list option;
236
-
properties: string list option;
237
-
}
238
-
239
-
(** Response for Foo/get method as per Section 5.1 *)
240
-
type 'a get_response = {
241
-
account_id: id;
242
-
state: string;
243
-
list: 'a list;
244
-
not_found: id list;
245
-
}
246
-
247
-
(** Arguments for Foo/changes method as per Section 5.2 *)
248
-
type changes_arguments = {
249
-
account_id: id;
250
-
since_state: string;
251
-
max_changes: unsigned_int option;
252
-
}
253
-
254
-
(** Response for Foo/changes method as per Section 5.2 *)
255
-
type changes_response = {
256
-
account_id: id;
257
-
old_state: string;
258
-
new_state: string;
259
-
has_more_changes: bool;
260
-
created: id list;
261
-
updated: id list;
262
-
destroyed: id list;
263
-
}
264
-
265
-
(** Arguments for Foo/set method as per Section 5.3 *)
266
-
type 'a set_arguments = {
267
-
account_id: id;
268
-
if_in_state: string option;
269
-
create: (id * 'a) list option;
270
-
update: (id * patch_object) list option;
271
-
destroy: id list option;
272
-
}
273
-
274
-
(** Response for Foo/set method as per Section 5.3 *)
275
-
type 'a set_response = {
276
-
account_id: id;
277
-
old_state: string option;
278
-
new_state: string;
279
-
created: (id * 'a) list option;
280
-
updated: (id * 'a option) list option;
281
-
destroyed: id list option;
282
-
not_created: (id * set_error) list option;
283
-
not_updated: (id * set_error) list option;
284
-
not_destroyed: (id * set_error) list option;
285
-
}
286
-
287
-
(** Arguments for Foo/copy method as per Section 5.4 *)
288
-
type 'a copy_arguments = {
289
-
from_account_id: id;
290
-
if_from_in_state: string option;
291
-
account_id: id;
292
-
if_in_state: string option;
293
-
create: (id * 'a) list;
294
-
on_success_destroy_original: bool option;
295
-
destroy_from_if_in_state: string option;
296
-
}
297
-
298
-
(** Response for Foo/copy method as per Section 5.4 *)
299
-
type 'a copy_response = {
300
-
from_account_id: id;
301
-
account_id: id;
302
-
old_state: string option;
303
-
new_state: string;
304
-
created: (id * 'a) list option;
305
-
not_created: (id * set_error) list option;
306
-
}
307
-
308
-
(** Arguments for Foo/query method as per Section 5.5 *)
309
-
type query_arguments = {
310
-
account_id: id;
311
-
filter: filter option;
312
-
sort: comparator list option;
313
-
position: int_t option;
314
-
anchor: id option;
315
-
anchor_offset: int_t option;
316
-
limit: unsigned_int option;
317
-
calculate_total: bool option;
318
-
}
319
-
320
-
(** Response for Foo/query method as per Section 5.5 *)
321
-
type query_response = {
322
-
account_id: id;
323
-
query_state: string;
324
-
can_calculate_changes: bool;
325
-
position: unsigned_int;
326
-
ids: id list;
327
-
total: unsigned_int option;
328
-
limit: unsigned_int option;
329
-
}
330
-
331
-
(** Arguments for Foo/queryChanges method as per Section 5.6 *)
332
-
type query_changes_arguments = {
333
-
account_id: id;
334
-
filter: filter option;
335
-
sort: comparator list option;
336
-
since_query_state: string;
337
-
max_changes: unsigned_int option;
338
-
up_to_id: id option;
339
-
calculate_total: bool option;
340
-
}
341
-
342
-
(** Response for Foo/queryChanges method as per Section 5.6 *)
343
-
type query_changes_response = {
344
-
account_id: id;
345
-
old_query_state: string;
346
-
new_query_state: string;
347
-
total: unsigned_int option;
348
-
removed: id list;
349
-
added: added_item list option;
350
-
}
351
-
352
-
(** Arguments for Blob/copy method as per Section 6.3 *)
353
-
type blob_copy_arguments = {
354
-
from_account_id: id;
355
-
account_id: id;
356
-
blob_ids: id list;
357
-
}
358
-
359
-
(** Response for Blob/copy method as per Section 6.3 *)
360
-
type blob_copy_response = {
361
-
from_account_id: id;
362
-
account_id: id;
363
-
copied: (id * id) list option;
364
-
not_copied: (id * set_error) list option;
365
-
}
366
-
367
-
(** Upload response as per Section 6.1 *)
368
-
type upload_response = {
369
-
account_id: id;
370
-
blob_id: id;
371
-
type_: string;
372
-
size: unsigned_int;
373
-
}
374
-
375
-
(** Problem details object as per RFC7807 and Section 3.6.1 *)
376
-
type problem_details = {
377
-
type_: string;
378
-
status: int option;
379
-
detail: string option;
380
-
limit: string option; (* For "limit" error *)
381
-
}
382
-
end
383
-
384
-
(** Module for working with ResultReferences as described in Section 3.7 of RFC8620 *)
385
-
module ResultReference = struct
386
-
open Types
387
-
388
-
(** Create a reference to a previous method result *)
389
-
let create ~result_of ~name ~path =
390
-
{ result_of; name; path }
391
-
392
-
(** Create a JSON pointer path to access a specific property *)
393
-
let property_path property =
394
-
"/" ^ property
395
-
396
-
(** Create a JSON pointer path to access all items in an array with a specific property *)
397
-
let array_items_path ?(property="") array_property =
398
-
let base = "/" ^ array_property ^ "/*" in
399
-
if property = "" then base
400
-
else base ^ "/" ^ property
401
-
402
-
(** Create argument with result reference.
403
-
Returns string key prefixed with # and ResultReference value. *)
404
-
let reference_arg arg_name ref_obj =
405
-
(* Prefix argument name with # *)
406
-
let prefixed_name = "#" ^ arg_name in
407
-
408
-
(* Convert reference object to JSON *)
409
-
let json_value = `O [
410
-
("resultOf", `String ref_obj.result_of);
411
-
("name", `String ref_obj.name);
412
-
("path", `String ref_obj.path)
413
-
] in
414
-
415
-
(prefixed_name, json_value)
416
-
417
-
(** Create a reference to all IDs returned by a query method *)
418
-
let query_ids ~result_of =
419
-
create
420
-
~result_of
421
-
~name:"Foo/query"
422
-
~path:"/ids"
423
-
424
-
(** Create a reference to properties of objects returned by a get method *)
425
-
let get_property ~result_of ~property =
426
-
create
427
-
~result_of
428
-
~name:"Foo/get"
429
-
~path:("/list/*/" ^ property)
430
-
end
431
-
432
-
module Api = struct
433
-
open Lwt.Syntax
434
-
open Types
435
-
436
-
(** Error that may occur during API requests *)
437
-
type error =
438
-
| Connection_error of string
439
-
| HTTP_error of int * string
440
-
| Parse_error of string
441
-
| Authentication_error
442
-
443
-
(** Result type for API operations *)
444
-
type 'a result = ('a, error) Stdlib.result
445
-
446
-
(** Convert an error to a human-readable string *)
447
-
let string_of_error = function
448
-
| Connection_error msg -> "Connection error: " ^ msg
449
-
| HTTP_error (code, body) -> Printf.sprintf "HTTP error %d: %s" code body
450
-
| Parse_error msg -> "Parse error: " ^ msg
451
-
| Authentication_error -> "Authentication error"
452
-
453
-
(** Pretty-print an error to a formatter *)
454
-
let pp_error ppf err =
455
-
Format.fprintf ppf "%s" (string_of_error err)
456
-
457
-
(** Configuration for a JMAP API client *)
458
-
type config = {
459
-
api_uri: Uri.t;
460
-
username: string;
461
-
authentication_token: string;
462
-
}
463
-
464
-
(** Convert Ezjsonm.value to string *)
465
-
let json_to_string json =
466
-
Ezjsonm.value_to_string ~minify:false json
467
-
468
-
(** Parse response string as JSON value *)
469
-
let parse_json_string str =
470
-
try Ok (Ezjsonm.from_string str)
471
-
with e -> Error (Parse_error (Printexc.to_string e))
472
-
473
-
(** Parse JSON response as a JMAP response object *)
474
-
let parse_response json =
475
-
try
476
-
let method_responses =
477
-
match Ezjsonm.find json ["methodResponses"] with
478
-
| `A items ->
479
-
List.map (fun json ->
480
-
match json with
481
-
| `A [`String name; args; `String method_call_id] ->
482
-
{ name; arguments = args; method_call_id }
483
-
| _ -> raise (Invalid_argument "Invalid invocation format in response")
484
-
) items
485
-
| _ -> raise (Invalid_argument "methodResponses is not an array")
486
-
in
487
-
let created_ids_opt =
488
-
try
489
-
let obj = Ezjsonm.find json ["createdIds"] in
490
-
match obj with
491
-
| `O items -> Some (List.map (fun (k, v) ->
492
-
match v with
493
-
| `String id -> (k, id)
494
-
| _ -> raise (Invalid_argument "createdIds value is not a string")
495
-
) items)
496
-
| _ -> None
497
-
with Not_found -> None
498
-
in
499
-
let session_state =
500
-
match Ezjsonm.find json ["sessionState"] with
501
-
| `String s -> s
502
-
| _ -> raise (Invalid_argument "sessionState is not a string")
503
-
in
504
-
Ok { method_responses; created_ids = created_ids_opt; session_state }
505
-
with
506
-
| Not_found -> Error (Parse_error "Required field not found in response")
507
-
| Invalid_argument msg -> Error (Parse_error msg)
508
-
| e -> Error (Parse_error (Printexc.to_string e))
509
-
510
-
(** Serialize a JMAP request object to JSON *)
511
-
let serialize_request req =
512
-
let method_calls_json =
513
-
`A (List.map (fun (inv : 'a invocation) ->
514
-
`A [`String inv.name; inv.arguments; `String inv.method_call_id]
515
-
) req.method_calls)
516
-
in
517
-
let using_json = `A (List.map (fun s -> `String s) req.using) in
518
-
let json = `O [
519
-
("using", using_json);
520
-
("methodCalls", method_calls_json)
521
-
] in
522
-
let json = match req.created_ids with
523
-
| Some ids ->
524
-
let created_ids_json = `O (List.map (fun (k, v) -> (k, `String v)) ids) in
525
-
Ezjsonm.update json ["createdIds"] (Some created_ids_json)
526
-
| None -> json
527
-
in
528
-
json_to_string json
529
-
530
-
(** Make a raw HTTP request *)
531
-
let make_http_request ~method_ ~headers ~body uri =
532
-
let open Cohttp in
533
-
let open Cohttp_lwt_unix in
534
-
let headers = Header.add_list (Header.init ()) headers in
535
-
536
-
(* Print detailed request information to stderr for debugging *)
537
-
let header_list = Cohttp.Header.to_list headers in
538
-
let redacted_headers = redact_headers header_list in
539
-
Logs.info (fun m ->
540
-
m "\n===== HTTP REQUEST =====\n\
541
-
URI: %s\n\
542
-
METHOD: %s\n\
543
-
HEADERS:\n%s\n\
544
-
BODY:\n%s\n\
545
-
======================\n"
546
-
(Uri.to_string uri)
547
-
method_
548
-
(String.concat "\n" (List.map (fun (k, v) -> Printf.sprintf " %s: %s" k v) redacted_headers))
549
-
body);
550
-
551
-
(* Force printing to stderr for immediate debugging *)
552
-
Printf.eprintf "[DEBUG-REQUEST] URI: %s\n" (Uri.to_string uri);
553
-
Printf.eprintf "[DEBUG-REQUEST] METHOD: %s\n" method_;
554
-
Printf.eprintf "[DEBUG-REQUEST] BODY: %s\n%!" body;
555
-
556
-
Lwt.catch
557
-
(fun () ->
558
-
let* resp, body =
559
-
match method_ with
560
-
| "GET" -> Client.get ~headers uri
561
-
| "POST" -> Client.post ~headers ~body:(Cohttp_lwt.Body.of_string body) uri
562
-
| _ -> failwith (Printf.sprintf "Unsupported HTTP method: %s" method_)
563
-
in
564
-
let* body_str = Cohttp_lwt.Body.to_string body in
565
-
let status = Response.status resp |> Code.code_of_status in
566
-
567
-
(* Print detailed response information to stderr for debugging *)
568
-
let header_list = Cohttp.Header.to_list (Response.headers resp) in
569
-
let redacted_headers = redact_headers header_list in
570
-
Logs.info (fun m ->
571
-
m "\n===== HTTP RESPONSE =====\n\
572
-
STATUS: %d\n\
573
-
HEADERS:\n%s\n\
574
-
BODY:\n%s\n\
575
-
======================\n"
576
-
status
577
-
(String.concat "\n" (List.map (fun (k, v) -> Printf.sprintf " %s: %s" k v) redacted_headers))
578
-
body_str);
579
-
580
-
(* Force printing to stderr for immediate debugging *)
581
-
Printf.eprintf "[DEBUG-RESPONSE] STATUS: %d\n" status;
582
-
Printf.eprintf "[DEBUG-RESPONSE] BODY: %s\n%!" body_str;
583
-
584
-
if status >= 200 && status < 300 then
585
-
Lwt.return (Ok body_str)
586
-
else
587
-
Lwt.return (Error (HTTP_error (status, body_str))))
588
-
(fun e ->
589
-
let error_msg = Printexc.to_string e in
590
-
Printf.eprintf "[DEBUG-ERROR] %s\n%!" error_msg;
591
-
Logs.err (fun m -> m "%s" error_msg);
592
-
Lwt.return (Error (Connection_error error_msg)))
593
-
594
-
(** Make a raw JMAP API request
595
-
596
-
TODO:claude *)
597
-
let make_request config req =
598
-
let body = serialize_request req in
599
-
(* Choose appropriate authorization header based on whether it's a bearer token or basic auth *)
600
-
let auth_header =
601
-
if String.length config.username > 0 then
602
-
(* Standard username/password authentication *)
603
-
"Basic " ^ Base64.encode_string (config.username ^ ":" ^ config.authentication_token)
604
-
else
605
-
(* API token (bearer authentication) *)
606
-
"Bearer " ^ config.authentication_token
607
-
in
608
-
609
-
(* Log auth header at debug level with redaction *)
610
-
let redacted_header =
611
-
if String.length config.username > 0 then
612
-
"Basic " ^ redact_token (Base64.encode_string (config.username ^ ":" ^ config.authentication_token))
613
-
else
614
-
"Bearer " ^ redact_token config.authentication_token
615
-
in
616
-
Logs.debug (fun m -> m "Using authorization header: %s" redacted_header);
617
-
618
-
let headers = [
619
-
("Content-Type", "application/json");
620
-
("Content-Length", string_of_int (String.length body));
621
-
("Authorization", auth_header)
622
-
] in
623
-
let* result = make_http_request ~method_:"POST" ~headers ~body config.api_uri in
624
-
match result with
625
-
| Ok response_body ->
626
-
(match parse_json_string response_body with
627
-
| Ok json ->
628
-
Logs.debug (fun m -> m "Successfully parsed JSON response");
629
-
Lwt.return (parse_response json)
630
-
| Error e ->
631
-
let msg = match e with Parse_error m -> m | _ -> "unknown error" in
632
-
Logs.err (fun m -> m "Failed to parse response: %s" msg);
633
-
Lwt.return (Error e))
634
-
| Error e ->
635
-
(match e with
636
-
| Connection_error msg -> Logs.err (fun m -> m "Connection error: %s" msg)
637
-
| HTTP_error (code, _) -> Logs.err (fun m -> m "HTTP error %d" code)
638
-
| Parse_error msg -> Logs.err (fun m -> m "Parse error: %s" msg)
639
-
| Authentication_error -> Logs.err (fun m -> m "Authentication error"));
640
-
Lwt.return (Error e)
641
-
642
-
(** Parse a JSON object as a Session object *)
643
-
let parse_session_object json =
644
-
try
645
-
let capabilities =
646
-
match Ezjsonm.find json ["capabilities"] with
647
-
| `O items -> items
648
-
| _ -> raise (Invalid_argument "capabilities is not an object")
649
-
in
650
-
651
-
let accounts =
652
-
match Ezjsonm.find json ["accounts"] with
653
-
| `O items -> List.map (fun (id, json) ->
654
-
match json with
655
-
| `O _ ->
656
-
let name = Ezjsonm.get_string (Ezjsonm.find json ["name"]) in
657
-
let is_personal = Ezjsonm.get_bool (Ezjsonm.find json ["isPersonal"]) in
658
-
let is_read_only = Ezjsonm.get_bool (Ezjsonm.find json ["isReadOnly"]) in
659
-
let account_capabilities =
660
-
match Ezjsonm.find json ["accountCapabilities"] with
661
-
| `O items -> items
662
-
| _ -> raise (Invalid_argument "accountCapabilities is not an object")
663
-
in
664
-
(id, { name; is_personal; is_read_only; account_capabilities })
665
-
| _ -> raise (Invalid_argument "account value is not an object")
666
-
) items
667
-
| _ -> raise (Invalid_argument "accounts is not an object")
668
-
in
669
-
670
-
let primary_accounts =
671
-
match Ezjsonm.find_opt json ["primaryAccounts"] with
672
-
| Some (`O items) -> List.map (fun (k, v) ->
673
-
match v with
674
-
| `String id -> (k, id)
675
-
| _ -> raise (Invalid_argument "primaryAccounts value is not a string")
676
-
) items
677
-
| Some _ -> raise (Invalid_argument "primaryAccounts is not an object")
678
-
| None -> []
679
-
in
680
-
681
-
let username = Ezjsonm.get_string (Ezjsonm.find json ["username"]) in
682
-
let api_url = Ezjsonm.get_string (Ezjsonm.find json ["apiUrl"]) in
683
-
let download_url = Ezjsonm.get_string (Ezjsonm.find json ["downloadUrl"]) in
684
-
let upload_url = Ezjsonm.get_string (Ezjsonm.find json ["uploadUrl"]) in
685
-
let event_source_url =
686
-
try Some (Ezjsonm.get_string (Ezjsonm.find json ["eventSourceUrl"]))
687
-
with Not_found -> None
688
-
in
689
-
let state = Ezjsonm.get_string (Ezjsonm.find json ["state"]) in
690
-
691
-
Ok { capabilities; accounts; primary_accounts; username;
692
-
api_url; download_url; upload_url; event_source_url; state }
693
-
with
694
-
| Not_found -> Error (Parse_error "Required field not found in session object")
695
-
| Invalid_argument msg -> Error (Parse_error msg)
696
-
| e -> Error (Parse_error (Printexc.to_string e))
697
-
698
-
(** Fetch a Session object from a JMAP server
699
-
700
-
TODO:claude *)
701
-
let get_session uri ?username ?authentication_token ?api_token () =
702
-
let headers =
703
-
match (username, authentication_token, api_token) with
704
-
| (Some u, Some t, _) ->
705
-
let auth = "Basic " ^ Base64.encode_string (u ^ ":" ^ t) in
706
-
let redacted_auth = "Basic " ^ redact_token (Base64.encode_string (u ^ ":" ^ t)) in
707
-
Logs.info (fun m -> m "Session using Basic auth: %s" redacted_auth);
708
-
[
709
-
("Content-Type", "application/json");
710
-
("Authorization", auth)
711
-
]
712
-
| (_, _, Some token) ->
713
-
let auth = "Bearer " ^ token in
714
-
let redacted_token = redact_token token in
715
-
Logs.info (fun m -> m "Session using Bearer auth: %s" ("Bearer " ^ redacted_token));
716
-
[
717
-
("Content-Type", "application/json");
718
-
("Authorization", auth)
719
-
]
720
-
| _ -> [("Content-Type", "application/json")]
721
-
in
722
-
723
-
let* result = make_http_request ~method_:"GET" ~headers ~body:"" uri in
724
-
match result with
725
-
| Ok response_body ->
726
-
(match parse_json_string response_body with
727
-
| Ok json ->
728
-
Logs.debug (fun m -> m "Successfully parsed session response");
729
-
Lwt.return (parse_session_object json)
730
-
| Error e ->
731
-
let msg = match e with Parse_error m -> m | _ -> "unknown error" in
732
-
Logs.err (fun m -> m "Failed to parse session response: %s" msg);
733
-
Lwt.return (Error e))
734
-
| Error e ->
735
-
let err_msg = match e with
736
-
| Connection_error msg -> "Connection error: " ^ msg
737
-
| HTTP_error (code, _) -> Printf.sprintf "HTTP error %d" code
738
-
| Parse_error msg -> "Parse error: " ^ msg
739
-
| Authentication_error -> "Authentication error"
740
-
in
741
-
Logs.err (fun m -> m "Failed to get session: %s" err_msg);
742
-
Lwt.return (Error e)
743
-
744
-
(** Upload a binary blob to the server
745
-
746
-
TODO:claude *)
747
-
let upload_blob config ~account_id ~content_type data =
748
-
let upload_url_template = config.api_uri |> Uri.to_string in
749
-
(* Replace {accountId} with the actual account ID *)
750
-
let upload_url = Str.global_replace (Str.regexp "{accountId}") account_id upload_url_template in
751
-
let upload_uri = Uri.of_string upload_url in
752
-
753
-
let headers = [
754
-
("Content-Type", content_type);
755
-
("Content-Length", string_of_int (String.length data));
756
-
("Authorization", "Basic " ^ Base64.encode_string (config.username ^ ":" ^ config.authentication_token))
757
-
] in
758
-
759
-
let* result = make_http_request ~method_:"POST" ~headers ~body:data upload_uri in
760
-
match result with
761
-
| Ok response_body ->
762
-
(match parse_json_string response_body with
763
-
| Ok json ->
764
-
(try
765
-
let account_id = Ezjsonm.get_string (Ezjsonm.find json ["accountId"]) in
766
-
let blob_id = Ezjsonm.get_string (Ezjsonm.find json ["blobId"]) in
767
-
let type_ = Ezjsonm.get_string (Ezjsonm.find json ["type"]) in
768
-
let size = Ezjsonm.get_int (Ezjsonm.find json ["size"]) in
769
-
Lwt.return (Ok { account_id; blob_id; type_; size })
770
-
with
771
-
| Not_found -> Lwt.return (Error (Parse_error "Required field not found in upload response"))
772
-
| e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
773
-
| Error e -> Lwt.return (Error e))
774
-
| Error e -> Lwt.return (Error e)
775
-
776
-
(** Download a binary blob from the server
777
-
778
-
TODO:claude *)
779
-
let download_blob config ~account_id ~blob_id ?type_ ?name () =
780
-
let download_url_template = config.api_uri |> Uri.to_string in
781
-
782
-
(* Replace template variables with actual values *)
783
-
let url = Str.global_replace (Str.regexp "{accountId}") account_id download_url_template in
784
-
let url = Str.global_replace (Str.regexp "{blobId}") blob_id url in
785
-
786
-
let url = match type_ with
787
-
| Some t -> Str.global_replace (Str.regexp "{type}") (Uri.pct_encode t) url
788
-
| None -> Str.global_replace (Str.regexp "{type}") "" url
789
-
in
790
-
791
-
let url = match name with
792
-
| Some n -> Str.global_replace (Str.regexp "{name}") (Uri.pct_encode n) url
793
-
| None -> Str.global_replace (Str.regexp "{name}") "file" url
794
-
in
795
-
796
-
let download_uri = Uri.of_string url in
797
-
798
-
let headers = [
799
-
("Authorization", "Basic " ^ Base64.encode_string (config.username ^ ":" ^ config.authentication_token))
800
-
] in
801
-
802
-
let* result = make_http_request ~method_:"GET" ~headers ~body:"" download_uri in
803
-
Lwt.return result
804
-
end
-663
lib/jmap.mli
-663
lib/jmap.mli
···
1
-
(**
2
-
* JMAP protocol implementation based on RFC8620
3
-
* https://datatracker.ietf.org/doc/html/rfc8620
4
-
*
5
-
* This module implements the core JMAP protocol as defined in RFC8620, providing
6
-
* types and functions for making JMAP API requests and handling responses.
7
-
*)
8
-
9
-
(** Initialize and configure logging for JMAP
10
-
@param level Optional logging level (higher means more verbose)
11
-
@param enable_logs Whether to enable logging at all (default true)
12
-
@param redact_sensitive Whether to redact sensitive information like tokens (default true)
13
-
*)
14
-
val init_logging : ?level:int -> ?enable_logs:bool -> ?redact_sensitive:bool -> unit -> unit
15
-
16
-
(** Redact sensitive data like authentication tokens from logs
17
-
@param redact Whether to perform redaction (default true)
18
-
@param token The token string to redact
19
-
@return A redacted version of the token (with characters replaced by '*')
20
-
*)
21
-
val redact_token : ?redact:bool -> string -> string
22
-
23
-
(** Module for managing JMAP capability URIs and other constants
24
-
as defined in RFC8620 Section 1.8
25
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-1.8> RFC8620 Section 1.8
26
-
*)
27
-
module Capability : sig
28
-
(** JMAP core capability URI as specified in RFC8620 Section 2
29
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-2> RFC8620 Section 2
30
-
*)
31
-
val core_uri : string
32
-
33
-
(** All JMAP capability types as described in RFC8620 Section 1.8
34
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-1.8> RFC8620 Section 1.8
35
-
*)
36
-
type t =
37
-
| Core (** Core JMAP capability *)
38
-
| Extension of string (** Extension capabilities with custom URIs *)
39
-
40
-
(** Convert capability to URI string
41
-
@param capability The capability to convert
42
-
@return The full URI string for the capability
43
-
*)
44
-
val to_string : t -> string
45
-
46
-
(** Parse a string to a capability, returns Extension for non-core capabilities
47
-
@param uri The capability URI string to parse
48
-
@return The parsed capability type
49
-
*)
50
-
val of_string : string -> t
51
-
52
-
(** Check if a capability matches the core capability
53
-
@param capability The capability to check
54
-
@return True if the capability is the core JMAP capability
55
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-2>
56
-
*)
57
-
val is_core : t -> bool
58
-
59
-
(** Check if a capability string is the core capability URI
60
-
@param uri The capability URI string to check
61
-
@return True if the string represents the core JMAP capability
62
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-2>
63
-
*)
64
-
val is_core_string : string -> bool
65
-
66
-
(** Create a list of capability URI strings
67
-
@param capabilities List of capability types
68
-
@return List of capability URI strings
69
-
*)
70
-
val strings_of_capabilities : t list -> string list
71
-
end
72
-
73
-
(** {1 Types}
74
-
Core types as defined in RFC8620
75
-
@see <https://datatracker.ietf.org/doc/html/rfc8620> RFC8620
76
-
*)
77
-
78
-
module Types : sig
79
-
(** Id string as defined in RFC8620 Section 1.2.
80
-
A string of at least 1 and maximum 255 octets, case-sensitive,
81
-
and does not begin with the '#' character.
82
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-1.2>
83
-
*)
84
-
type id = string
85
-
86
-
(** Int type bounded within the range -2^53+1 to 2^53-1 as defined in RFC8620 Section 1.3.
87
-
Represented as JSON number where the value MUST be an integer and in the range.
88
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-1.3>
89
-
*)
90
-
type int_t = int
91
-
92
-
(** UnsignedInt bounded within the range 0 to 2^53-1 as defined in RFC8620 Section 1.3.
93
-
Represented as JSON number where the value MUST be a non-negative integer and in the range.
94
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-1.3>
95
-
*)
96
-
type unsigned_int = int
97
-
98
-
(** Date string in RFC3339 format as defined in RFC8620 Section 1.4.
99
-
Includes date, time and time zone offset information or UTC.
100
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-1.4>
101
-
*)
102
-
type date = string
103
-
104
-
(** UTCDate is a Date with 'Z' time zone (UTC) as defined in RFC8620 Section 1.4.
105
-
Same format as Date type but always with UTC time zone (Z).
106
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-1.4>
107
-
*)
108
-
type utc_date = string
109
-
110
-
(** Error object as defined in RFC8620 Section 3.6.2.
111
-
Used to represent standard error conditions in method responses.
112
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-3.6.2>
113
-
*)
114
-
type error = {
115
-
type_: string; (** The type of error, e.g., "serverFail" *)
116
-
description: string option; (** Optional human-readable description of the error *)
117
-
}
118
-
119
-
(** Set error object as defined in RFC8620 Section 5.3.
120
-
Used for reporting errors in set operations.
121
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.3>
122
-
*)
123
-
type set_error = {
124
-
type_: string; (** The type of error, e.g., "notFound" *)
125
-
description: string option; (** Optional human-readable description of the error *)
126
-
properties: string list option; (** Properties causing the error, if applicable *)
127
-
existing_id: id option; (** For "alreadyExists" error, the ID of the existing object *)
128
-
}
129
-
130
-
(** Invocation object as defined in RFC8620 Section 3.2.
131
-
Represents a method call in the JMAP protocol.
132
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-3.2>
133
-
*)
134
-
type 'a invocation = {
135
-
name: string; (** The name of the method to call, e.g., "Mailbox/get" *)
136
-
arguments: 'a; (** The arguments for the method, type varies by method *)
137
-
method_call_id: string; (** Client-specified ID for referencing this call *)
138
-
}
139
-
140
-
(** ResultReference object as defined in RFC8620 Section 3.7.
141
-
Used to reference results from previous method calls.
142
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-3.7>
143
-
*)
144
-
type result_reference = {
145
-
result_of: string; (** The method_call_id of the method to reference *)
146
-
name: string; (** Name of the response in the referenced result *)
147
-
path: string; (** JSON pointer path to the value being referenced *)
148
-
}
149
-
150
-
(** FilterOperator, FilterCondition and Filter as defined in RFC8620 Section 5.5.
151
-
Used for complex filtering in query methods.
152
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.5>
153
-
*)
154
-
type filter_operator = {
155
-
operator: string; (** The operator: "AND", "OR", "NOT" *)
156
-
conditions: filter list; (** The conditions to apply the operator to *)
157
-
}
158
-
159
-
(** Property/value pairs for filtering *)
160
-
and filter_condition =
161
-
(string * Ezjsonm.value) list
162
-
163
-
and filter =
164
-
| Operator of filter_operator (** Logical operator combining conditions *)
165
-
| Condition of filter_condition (** Simple property-based condition *)
166
-
167
-
(** Comparator object for sorting as defined in RFC8620 Section 5.5.
168
-
Specifies how to sort query results.
169
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.5>
170
-
*)
171
-
type comparator = {
172
-
property: string; (** The property to sort by *)
173
-
is_ascending: bool option; (** Sort order (true for ascending, false for descending) *)
174
-
collation: string option; (** Collation algorithm for string comparison *)
175
-
}
176
-
177
-
(** PatchObject as defined in RFC8620 Section 5.3.
178
-
Used to represent a set of updates to apply to an object.
179
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.3>
180
-
*)
181
-
type patch_object = (string * Ezjsonm.value) list (** List of property/value pairs to update *)
182
-
183
-
(** AddedItem structure as defined in RFC8620 Section 5.6.
184
-
Represents an item added to a query result.
185
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.6>
186
-
*)
187
-
type added_item = {
188
-
id: id; (** The ID of the added item *)
189
-
index: unsigned_int; (** The index in the result list where the item appears *)
190
-
}
191
-
192
-
(** Account object as defined in RFC8620 Section 1.6.2.
193
-
Represents a user account in JMAP.
194
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-1.6.2>
195
-
*)
196
-
type account = {
197
-
name: string; (** User-friendly account name, e.g. "john@example.com" *)
198
-
is_personal: bool; (** Whether this account belongs to the authenticated user *)
199
-
is_read_only: bool; (** Whether this account can be modified *)
200
-
account_capabilities: (string * Ezjsonm.value) list; (** Capabilities available for this account *)
201
-
}
202
-
203
-
(** Core capability object as defined in RFC8620 Section 2.
204
-
Describes limits and features of the JMAP server.
205
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-2>
206
-
*)
207
-
type core_capability = {
208
-
max_size_upload: unsigned_int; (** Maximum file size in octets for uploads *)
209
-
max_concurrent_upload: unsigned_int; (** Maximum number of concurrent uploads *)
210
-
max_size_request: unsigned_int; (** Maximum size in octets for a request *)
211
-
max_concurrent_requests: unsigned_int; (** Maximum number of concurrent requests *)
212
-
max_calls_in_request: unsigned_int; (** Maximum number of method calls in a request *)
213
-
max_objects_in_get: unsigned_int; (** Maximum number of objects in a get request *)
214
-
max_objects_in_set: unsigned_int; (** Maximum number of objects in a set request *)
215
-
collation_algorithms: string list; (** Supported string collation algorithms *)
216
-
}
217
-
218
-
(** PushSubscription keys object as defined in RFC8620 Section 7.2.
219
-
Contains encryption keys for web push subscriptions.
220
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-7.2>
221
-
*)
222
-
type push_keys = {
223
-
p256dh: string; (** User agent public key (Base64url-encoded) *)
224
-
auth: string; (** Authentication secret (Base64url-encoded) *)
225
-
}
226
-
227
-
(** Session object as defined in RFC8620 Section 2.
228
-
Contains information about the server and user's accounts.
229
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-2>
230
-
*)
231
-
type session = {
232
-
capabilities: (string * Ezjsonm.value) list; (** Server capabilities with their properties *)
233
-
accounts: (id * account) list; (** Map of account IDs to account objects *)
234
-
primary_accounts: (string * id) list; (** Map of capability URIs to primary account IDs *)
235
-
username: string; (** Username associated with this session *)
236
-
api_url: string; (** URL to use for JMAP API requests *)
237
-
download_url: string; (** URL endpoint to download files *)
238
-
upload_url: string; (** URL endpoint to upload files *)
239
-
event_source_url: string option; (** URL for Server-Sent Events notifications *)
240
-
state: string; (** String representing the state on the server *)
241
-
}
242
-
243
-
(** TypeState for state changes as defined in RFC8620 Section 7.1.
244
-
Maps data type names to the state string for that type.
245
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-7.1>
246
-
*)
247
-
type type_state = (string * string) list (** (data type name, state string) pairs *)
248
-
249
-
(** StateChange object as defined in RFC8620 Section 7.1.
250
-
Represents changes to data types for different accounts.
251
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-7.1>
252
-
*)
253
-
type state_change = {
254
-
changed: (id * type_state) list; (** Map of account IDs to type state changes *)
255
-
}
256
-
257
-
(** PushVerification object as defined in RFC8620 Section 7.2.2.
258
-
Used for verifying push subscription ownership.
259
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-7.2.2>
260
-
*)
261
-
type push_verification = {
262
-
push_subscription_id: id; (** ID of the push subscription being verified *)
263
-
verification_code: string; (** Code the client must submit to verify ownership *)
264
-
}
265
-
266
-
(** PushSubscription object as defined in RFC8620 Section 7.2.
267
-
Represents a subscription for push notifications.
268
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-7.2>
269
-
*)
270
-
type push_subscription = {
271
-
id: id; (** Server-assigned ID for the subscription *)
272
-
device_client_id: string; (** ID representing the client/device *)
273
-
url: string; (** URL to which events are pushed *)
274
-
keys: push_keys option; (** Encryption keys for web push, if any *)
275
-
verification_code: string option; (** Verification code if not yet verified *)
276
-
expires: utc_date option; (** When the subscription expires, if applicable *)
277
-
types: string list option; (** Types of changes to push, null means all *)
278
-
}
279
-
280
-
(** Request object as defined in RFC8620 Section 3.3.
281
-
Represents a JMAP request from client to server.
282
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-3.3>
283
-
*)
284
-
type request = {
285
-
using: string list; (** Capabilities required for this request *)
286
-
method_calls: Ezjsonm.value invocation list; (** List of method calls to process *)
287
-
created_ids: (id * id) list option; (** Map of client-created IDs to server IDs *)
288
-
}
289
-
290
-
(** Response object as defined in RFC8620 Section 3.4.
291
-
Represents a JMAP response from server to client.
292
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-3.4>
293
-
*)
294
-
type response = {
295
-
method_responses: Ezjsonm.value invocation list; (** List of method responses *)
296
-
created_ids: (id * id) list option; (** Map of client-created IDs to server IDs *)
297
-
session_state: string; (** Current session state on the server *)
298
-
}
299
-
300
-
(** {2 Standard method arguments and responses}
301
-
Standard method patterns defined in RFC8620 Section 5
302
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5>
303
-
*)
304
-
305
-
(** Arguments for Foo/get method as defined in RFC8620 Section 5.1.
306
-
Generic template for retrieving objects by ID.
307
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.1>
308
-
*)
309
-
type 'a get_arguments = {
310
-
account_id: id; (** The account ID to operate on *)
311
-
ids: id list option; (** IDs to fetch, null means all *)
312
-
properties: string list option; (** Properties to return, null means all *)
313
-
}
314
-
315
-
(** Response for Foo/get method as defined in RFC8620 Section 5.1.
316
-
Generic template for returning requested objects.
317
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.1>
318
-
*)
319
-
type 'a get_response = {
320
-
account_id: id; (** The account ID that was operated on *)
321
-
state: string; (** Server state for the type at the time of processing *)
322
-
list: 'a list; (** The list of requested objects *)
323
-
not_found: id list; (** IDs that could not be found *)
324
-
}
325
-
326
-
(** Arguments for Foo/changes method as defined in RFC8620 Section 5.2.
327
-
Generic template for getting state changes.
328
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.2>
329
-
*)
330
-
type changes_arguments = {
331
-
account_id: id; (** The account ID to operate on *)
332
-
since_state: string; (** The last state seen by the client *)
333
-
max_changes: unsigned_int option; (** Maximum number of changes to return *)
334
-
}
335
-
336
-
(** Response for Foo/changes method as defined in RFC8620 Section 5.2.
337
-
Generic template for returning object changes.
338
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.2>
339
-
*)
340
-
type changes_response = {
341
-
account_id: id; (** The account ID that was operated on *)
342
-
old_state: string; (** The state provided in the request *)
343
-
new_state: string; (** The current server state *)
344
-
has_more_changes: bool; (** True if more changes are available *)
345
-
created: id list; (** IDs of objects created since old_state *)
346
-
updated: id list; (** IDs of objects updated since old_state *)
347
-
destroyed: id list; (** IDs of objects destroyed since old_state *)
348
-
}
349
-
350
-
(** Arguments for Foo/set method as defined in RFC8620 Section 5.3.
351
-
Generic template for creating, updating, and destroying objects.
352
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.3>
353
-
*)
354
-
type 'a set_arguments = {
355
-
account_id: id; (** The account ID to operate on *)
356
-
if_in_state: string option; (** Only apply changes if in this state *)
357
-
create: (id * 'a) list option; (** Map of creation IDs to objects to create *)
358
-
update: (id * patch_object) list option; (** Map of IDs to patches to apply *)
359
-
destroy: id list option; (** List of IDs to destroy *)
360
-
}
361
-
362
-
(** Response for Foo/set method as defined in RFC8620 Section 5.3.
363
-
Generic template for reporting create/update/destroy status.
364
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.3>
365
-
*)
366
-
type 'a set_response = {
367
-
account_id: id; (** The account ID that was operated on *)
368
-
old_state: string option; (** The state before processing, if changed *)
369
-
new_state: string; (** The current server state *)
370
-
created: (id * 'a) list option; (** Map of creation IDs to created objects *)
371
-
updated: (id * 'a option) list option; (** Map of IDs to updated objects *)
372
-
destroyed: id list option; (** List of IDs successfully destroyed *)
373
-
not_created: (id * set_error) list option; (** Map of IDs to errors for failed creates *)
374
-
not_updated: (id * set_error) list option; (** Map of IDs to errors for failed updates *)
375
-
not_destroyed: (id * set_error) list option; (** Map of IDs to errors for failed destroys *)
376
-
}
377
-
378
-
(** Arguments for Foo/copy method as defined in RFC8620 Section 5.4.
379
-
Generic template for copying objects between accounts.
380
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.4>
381
-
*)
382
-
type 'a copy_arguments = {
383
-
from_account_id: id; (** The account ID to copy from *)
384
-
if_from_in_state: string option; (** Only copy if source account in this state *)
385
-
account_id: id; (** The account ID to copy to *)
386
-
if_in_state: string option; (** Only copy if destination account in this state *)
387
-
create: (id * 'a) list; (** Map of creation IDs to objects to copy *)
388
-
on_success_destroy_original: bool option; (** Whether to destroy the original after copying *)
389
-
destroy_from_if_in_state: string option; (** Only destroy originals if in this state *)
390
-
}
391
-
392
-
(** Response for Foo/copy method as defined in RFC8620 Section 5.4.
393
-
Generic template for reporting copy operation status.
394
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.4>
395
-
*)
396
-
type 'a copy_response = {
397
-
from_account_id: id; (** The account ID that was copied from *)
398
-
account_id: id; (** The account ID that was copied to *)
399
-
old_state: string option; (** The state before processing, if changed *)
400
-
new_state: string; (** The current server state *)
401
-
created: (id * 'a) list option; (** Map of creation IDs to created objects *)
402
-
not_created: (id * set_error) list option; (** Map of IDs to errors for failed copies *)
403
-
}
404
-
405
-
(** Arguments for Foo/query method as defined in RFC8620 Section 5.5.
406
-
Generic template for querying objects.
407
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.5>
408
-
*)
409
-
type query_arguments = {
410
-
account_id: id; (** The account ID to operate on *)
411
-
filter: filter option; (** Filter to determine which objects are returned *)
412
-
sort: comparator list option; (** Sort order for returned objects *)
413
-
position: int_t option; (** Zero-based index of first result to return *)
414
-
anchor: id option; (** ID of object to use as reference point *)
415
-
anchor_offset: int_t option; (** Offset from anchor to start returning results *)
416
-
limit: unsigned_int option; (** Maximum number of results to return *)
417
-
calculate_total: bool option; (** Whether to calculate the total number of matching objects *)
418
-
}
419
-
420
-
(** Response for Foo/query method as defined in RFC8620 Section 5.5.
421
-
Generic template for returning query results.
422
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.5>
423
-
*)
424
-
type query_response = {
425
-
account_id: id; (** The account ID that was operated on *)
426
-
query_state: string; (** State string for the query results *)
427
-
can_calculate_changes: bool; (** Whether queryChanges can be used with these results *)
428
-
position: unsigned_int; (** Zero-based index of the first result *)
429
-
ids: id list; (** The list of IDs for objects matching the query *)
430
-
total: unsigned_int option; (** Total number of matching objects, if calculated *)
431
-
limit: unsigned_int option; (** Limit enforced on the results, if requested *)
432
-
}
433
-
434
-
(** Arguments for Foo/queryChanges method as defined in RFC8620 Section 5.6.
435
-
Generic template for getting query result changes.
436
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.6>
437
-
*)
438
-
type query_changes_arguments = {
439
-
account_id: id; (** The account ID to operate on *)
440
-
filter: filter option; (** Same filter as used in the original query *)
441
-
sort: comparator list option; (** Same sort as used in the original query *)
442
-
since_query_state: string; (** The query_state from previous results *)
443
-
max_changes: unsigned_int option; (** Maximum number of changes to return *)
444
-
up_to_id: id option; (** Only calculate changes until this ID is encountered *)
445
-
calculate_total: bool option; (** Whether to recalculate the total matches *)
446
-
}
447
-
448
-
(** Response for Foo/queryChanges method as defined in RFC8620 Section 5.6.
449
-
Generic template for returning query result changes.
450
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-5.6>
451
-
*)
452
-
type query_changes_response = {
453
-
account_id: id; (** The account ID that was operated on *)
454
-
old_query_state: string; (** The query_state from the request *)
455
-
new_query_state: string; (** The current query_state on the server *)
456
-
total: unsigned_int option; (** Updated total number of matches, if calculated *)
457
-
removed: id list; (** IDs that were in the old results but not in the new *)
458
-
added: added_item list option; (** IDs that are in the new results but not the old *)
459
-
}
460
-
461
-
(** Arguments for Blob/copy method as defined in RFC8620 Section 6.3.
462
-
Used for copying binary data between accounts.
463
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-6.3>
464
-
*)
465
-
type blob_copy_arguments = {
466
-
from_account_id: id; (** The account ID to copy blobs from *)
467
-
account_id: id; (** The account ID to copy blobs to *)
468
-
blob_ids: id list; (** IDs of blobs to copy *)
469
-
}
470
-
471
-
(** Response for Blob/copy method as defined in RFC8620 Section 6.3.
472
-
Reports the results of copying binary data.
473
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-6.3>
474
-
*)
475
-
type blob_copy_response = {
476
-
from_account_id: id; (** The account ID that was copied from *)
477
-
account_id: id; (** The account ID that was copied to *)
478
-
copied: (id * id) list option; (** Map of source IDs to destination IDs *)
479
-
not_copied: (id * set_error) list option; (** Map of IDs to errors for failed copies *)
480
-
}
481
-
482
-
(** Upload response as defined in RFC8620 Section 6.1.
483
-
Contains information about an uploaded binary blob.
484
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-6.1>
485
-
*)
486
-
type upload_response = {
487
-
account_id: id; (** The account ID the blob was uploaded to *)
488
-
blob_id: id; (** The ID for the uploaded blob *)
489
-
type_: string; (** Media type of the blob *)
490
-
size: unsigned_int; (** Size of the blob in octets *)
491
-
}
492
-
493
-
(** Problem details object as defined in RFC8620 Section 3.6.1 and RFC7807.
494
-
Used for HTTP error responses in the JMAP protocol.
495
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-3.6.1>
496
-
@see <https://datatracker.ietf.org/doc/html/rfc7807>
497
-
*)
498
-
type problem_details = {
499
-
type_: string; (** URI that identifies the problem type *)
500
-
status: int option; (** HTTP status code for this problem *)
501
-
detail: string option; (** Human-readable explanation of the problem *)
502
-
limit: string option; (** For "limit" errors, which limit was exceeded *)
503
-
}
504
-
end
505
-
506
-
(** {1 API Client}
507
-
Modules for interacting with JMAP servers
508
-
*)
509
-
510
-
(** Module for working with ResultReferences as described in Section 3.7 of RFC8620.
511
-
Provides utilities to create and compose results from previous methods.
512
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-3.7>
513
-
*)
514
-
module ResultReference : sig
515
-
(** Create a reference to a previous method result
516
-
@param result_of The methodCallId of the method call to reference
517
-
@param name The name in the response to reference (e.g., "list")
518
-
@param path JSON pointer path to the value being referenced
519
-
@return A result_reference object
520
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-3.7>
521
-
*)
522
-
val create :
523
-
result_of:string ->
524
-
name:string ->
525
-
path:string ->
526
-
Types.result_reference
527
-
528
-
(** Create a JSON pointer path to access a specific property
529
-
@param property The property name to access
530
-
@return A JSON pointer path string
531
-
*)
532
-
val property_path : string -> string
533
-
534
-
(** Create a JSON pointer path to access all items in an array with a specific property
535
-
@param property Optional property to access within each array item
536
-
@param array_name The name of the array to access
537
-
@return A JSON pointer path string that references all items in the array
538
-
*)
539
-
val array_items_path : ?property:string -> string -> string
540
-
541
-
(** Create argument with result reference.
542
-
@param arg_name The name of the argument
543
-
@param reference The result reference to use
544
-
@return A tuple of string key (with # prefix) and ResultReference JSON value
545
-
*)
546
-
val reference_arg : string -> Types.result_reference -> string * Ezjsonm.value
547
-
548
-
(** Create a reference to all IDs returned by a query method
549
-
@param result_of The methodCallId of the query method call
550
-
@return A result_reference to the IDs returned by the query
551
-
*)
552
-
val query_ids :
553
-
result_of:string ->
554
-
Types.result_reference
555
-
556
-
(** Create a reference to properties of objects returned by a get method
557
-
@param result_of The methodCallId of the get method call
558
-
@param property The property to reference in the returned objects
559
-
@return A result_reference to the specified property in the get results
560
-
*)
561
-
val get_property :
562
-
result_of:string ->
563
-
property:string ->
564
-
Types.result_reference
565
-
end
566
-
567
-
(** Module for making JMAP API requests over HTTP.
568
-
Provides functionality to interact with JMAP servers according to RFC8620.
569
-
@see <https://datatracker.ietf.org/doc/html/rfc8620>
570
-
*)
571
-
module Api : sig
572
-
(** Error that may occur during API requests *)
573
-
type error =
574
-
| Connection_error of string (** Network-related errors *)
575
-
| HTTP_error of int * string (** HTTP errors with status code and message *)
576
-
| Parse_error of string (** JSON parsing errors *)
577
-
| Authentication_error (** Authentication failures *)
578
-
579
-
(** Result type for API operations *)
580
-
type 'a result = ('a, error) Stdlib.result
581
-
582
-
(** Convert an error to a human-readable string
583
-
@param err The error to convert
584
-
@return A string representation of the error
585
-
*)
586
-
val string_of_error : error -> string
587
-
588
-
(** Pretty-print an error to a formatter
589
-
@param ppf The formatter to print to
590
-
@param err The error to print
591
-
*)
592
-
val pp_error : Format.formatter -> error -> unit
593
-
594
-
(** Configuration for a JMAP API client as defined in RFC8620 Section 3.1
595
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-3.1>
596
-
*)
597
-
type config = {
598
-
api_uri: Uri.t; (** The JMAP API endpoint URI *)
599
-
username: string; (** The username for authentication *)
600
-
authentication_token: string; (** The token for authentication *)
601
-
}
602
-
603
-
(** Make a raw JMAP API request as defined in RFC8620 Section 3.3
604
-
@param config The API client configuration
605
-
@param request The JMAP request to send
606
-
@return A result containing the JMAP response or an error
607
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-3.3>
608
-
*)
609
-
val make_request :
610
-
config ->
611
-
Types.request ->
612
-
Types.response result Lwt.t
613
-
614
-
(** Fetch a Session object from a JMAP server as defined in RFC8620 Section 2
615
-
Can authenticate with either username/password or API token.
616
-
@param uri The URI of the JMAP session resource
617
-
@param username Optional username for authentication
618
-
@param authentication_token Optional password or token for authentication
619
-
@param api_token Optional API token for Bearer authentication
620
-
@return A result containing the session object or an error
621
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-2>
622
-
*)
623
-
val get_session :
624
-
Uri.t ->
625
-
?username:string ->
626
-
?authentication_token:string ->
627
-
?api_token:string ->
628
-
unit ->
629
-
Types.session result Lwt.t
630
-
631
-
(** Upload a binary blob to the server as defined in RFC8620 Section 6.1
632
-
@param config The API client configuration
633
-
@param account_id The account ID to upload to
634
-
@param content_type The MIME type of the blob
635
-
@param data The blob data as a string
636
-
@return A result containing the upload response or an error
637
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-6.1>
638
-
*)
639
-
val upload_blob :
640
-
config ->
641
-
account_id:Types.id ->
642
-
content_type:string ->
643
-
string ->
644
-
Types.upload_response result Lwt.t
645
-
646
-
(** Download a binary blob from the server as defined in RFC8620 Section 6.2
647
-
@param config The API client configuration
648
-
@param account_id The account ID that contains the blob
649
-
@param blob_id The ID of the blob to download
650
-
@param type_ Optional MIME type to require for the blob
651
-
@param name Optional name for the downloaded blob
652
-
@return A result containing the blob data as a string or an error
653
-
@see <https://datatracker.ietf.org/doc/html/rfc8620#section-6.2>
654
-
*)
655
-
val download_blob :
656
-
config ->
657
-
account_id:Types.id ->
658
-
blob_id:Types.id ->
659
-
?type_:string ->
660
-
?name:string ->
661
-
unit ->
662
-
string result Lwt.t
663
-
end
-2828
lib/jmap_mail.ml
-2828
lib/jmap_mail.ml
···
1
-
(** Implementation of the JMAP Mail extension, as defined in RFC8621 *)
2
-
3
-
(** Module for managing JMAP Mail-specific capability URIs *)
4
-
module Capability = struct
5
-
(** Mail capability URI *)
6
-
let mail_uri = "urn:ietf:params:jmap:mail"
7
-
8
-
(** Submission capability URI *)
9
-
let submission_uri = "urn:ietf:params:jmap:submission"
10
-
11
-
(** Vacation response capability URI *)
12
-
let vacation_response_uri = "urn:ietf:params:jmap:vacationresponse"
13
-
14
-
(** All mail extension capability types *)
15
-
type t =
16
-
| Mail (** Mail capability *)
17
-
| Submission (** Submission capability *)
18
-
| VacationResponse (** Vacation response capability *)
19
-
| Extension of string (** Custom extension *)
20
-
21
-
(** Convert capability to URI string *)
22
-
let to_string = function
23
-
| Mail -> mail_uri
24
-
| Submission -> submission_uri
25
-
| VacationResponse -> vacation_response_uri
26
-
| Extension s -> s
27
-
28
-
(** Parse a string to a capability *)
29
-
let of_string s =
30
-
if s = mail_uri then Mail
31
-
else if s = submission_uri then Submission
32
-
else if s = vacation_response_uri then VacationResponse
33
-
else Extension s
34
-
35
-
(** Check if a capability is a standard mail capability *)
36
-
let is_standard = function
37
-
| Mail | Submission | VacationResponse -> true
38
-
| Extension _ -> false
39
-
40
-
(** Check if a capability string is a standard mail capability *)
41
-
let is_standard_string s =
42
-
s = mail_uri || s = submission_uri || s = vacation_response_uri
43
-
44
-
(** Create a list of capability strings *)
45
-
let strings_of_capabilities capabilities =
46
-
List.map to_string capabilities
47
-
end
48
-
49
-
module Types = struct
50
-
open Jmap.Types
51
-
52
-
(** {1 Mail capabilities} *)
53
-
54
-
(** Capability URI for JMAP Mail*)
55
-
let capability_mail = Capability.mail_uri
56
-
57
-
(** Capability URI for JMAP Submission *)
58
-
let capability_submission = Capability.submission_uri
59
-
60
-
(** Capability URI for JMAP Vacation Response *)
61
-
let capability_vacation_response = Capability.vacation_response_uri
62
-
63
-
(** {1:mailbox Mailbox objects} *)
64
-
65
-
(** A role for a mailbox. See RFC8621 Section 2. *)
66
-
type mailbox_role =
67
-
| All (** All mail *)
68
-
| Archive (** Archived mail *)
69
-
| Drafts (** Draft messages *)
70
-
| Flagged (** Starred/flagged mail *)
71
-
| Important (** Important mail *)
72
-
| Inbox (** Inbox *)
73
-
| Junk (** Spam/Junk mail *)
74
-
| Sent (** Sent mail *)
75
-
| Trash (** Deleted/Trash mail *)
76
-
| Unknown of string (** Server-specific roles *)
77
-
78
-
(** A mailbox (folder) in a mail account. See RFC8621 Section 2. *)
79
-
type mailbox = {
80
-
id : id;
81
-
name : string;
82
-
parent_id : id option;
83
-
role : mailbox_role option;
84
-
sort_order : unsigned_int;
85
-
total_emails : unsigned_int;
86
-
unread_emails : unsigned_int;
87
-
total_threads : unsigned_int;
88
-
unread_threads : unsigned_int;
89
-
is_subscribed : bool;
90
-
my_rights : mailbox_rights;
91
-
}
92
-
93
-
(** Rights for a mailbox. See RFC8621 Section 2. *)
94
-
and mailbox_rights = {
95
-
may_read_items : bool;
96
-
may_add_items : bool;
97
-
may_remove_items : bool;
98
-
may_set_seen : bool;
99
-
may_set_keywords : bool;
100
-
may_create_child : bool;
101
-
may_rename : bool;
102
-
may_delete : bool;
103
-
may_submit : bool;
104
-
}
105
-
106
-
(** Filter condition for mailbox queries. See RFC8621 Section 2.3. *)
107
-
type mailbox_filter_condition = {
108
-
parent_id : id option;
109
-
name : string option;
110
-
role : string option;
111
-
has_any_role : bool option;
112
-
is_subscribed : bool option;
113
-
}
114
-
115
-
type mailbox_query_filter = [
116
-
| `And of mailbox_query_filter list
117
-
| `Or of mailbox_query_filter list
118
-
| `Not of mailbox_query_filter
119
-
| `Condition of mailbox_filter_condition
120
-
]
121
-
122
-
(** Mailbox/get request arguments. See RFC8621 Section 2.1. *)
123
-
type mailbox_get_arguments = {
124
-
account_id : id;
125
-
ids : id list option;
126
-
properties : string list option;
127
-
}
128
-
129
-
(** Mailbox/get response. See RFC8621 Section 2.1. *)
130
-
type mailbox_get_response = {
131
-
account_id : id;
132
-
state : string;
133
-
list : mailbox list;
134
-
not_found : id list;
135
-
}
136
-
137
-
(** Mailbox/changes request arguments. See RFC8621 Section 2.2. *)
138
-
type mailbox_changes_arguments = {
139
-
account_id : id;
140
-
since_state : string;
141
-
max_changes : unsigned_int option;
142
-
}
143
-
144
-
(** Mailbox/changes response. See RFC8621 Section 2.2. *)
145
-
type mailbox_changes_response = {
146
-
account_id : id;
147
-
old_state : string;
148
-
new_state : string;
149
-
has_more_changes : bool;
150
-
created : id list;
151
-
updated : id list;
152
-
destroyed : id list;
153
-
}
154
-
155
-
(** Mailbox/query request arguments. See RFC8621 Section 2.3. *)
156
-
type mailbox_query_arguments = {
157
-
account_id : id;
158
-
filter : mailbox_query_filter option;
159
-
sort : [ `name | `role | `sort_order ] list option;
160
-
limit : unsigned_int option;
161
-
}
162
-
163
-
(** Mailbox/query response. See RFC8621 Section 2.3. *)
164
-
type mailbox_query_response = {
165
-
account_id : id;
166
-
query_state : string;
167
-
can_calculate_changes : bool;
168
-
position : unsigned_int;
169
-
ids : id list;
170
-
total : unsigned_int option;
171
-
}
172
-
173
-
(** Mailbox/queryChanges request arguments. See RFC8621 Section 2.4. *)
174
-
type mailbox_query_changes_arguments = {
175
-
account_id : id;
176
-
filter : mailbox_query_filter option;
177
-
sort : [ `name | `role | `sort_order ] list option;
178
-
since_query_state : string;
179
-
max_changes : unsigned_int option;
180
-
up_to_id : id option;
181
-
}
182
-
183
-
(** Mailbox/queryChanges response. See RFC8621 Section 2.4. *)
184
-
type mailbox_query_changes_response = {
185
-
account_id : id;
186
-
old_query_state : string;
187
-
new_query_state : string;
188
-
total : unsigned_int option;
189
-
removed : id list;
190
-
added : mailbox_query_changes_added list;
191
-
}
192
-
193
-
and mailbox_query_changes_added = {
194
-
id : id;
195
-
index : unsigned_int;
196
-
}
197
-
198
-
(** Mailbox/set request arguments. See RFC8621 Section 2.5. *)
199
-
type mailbox_set_arguments = {
200
-
account_id : id;
201
-
if_in_state : string option;
202
-
create : (id * mailbox_creation) list option;
203
-
update : (id * mailbox_update) list option;
204
-
destroy : id list option;
205
-
}
206
-
207
-
and mailbox_creation = {
208
-
name : string;
209
-
parent_id : id option;
210
-
role : string option;
211
-
sort_order : unsigned_int option;
212
-
is_subscribed : bool option;
213
-
}
214
-
215
-
and mailbox_update = {
216
-
name : string option;
217
-
parent_id : id option;
218
-
role : string option;
219
-
sort_order : unsigned_int option;
220
-
is_subscribed : bool option;
221
-
}
222
-
223
-
(** Mailbox/set response. See RFC8621 Section 2.5. *)
224
-
type mailbox_set_response = {
225
-
account_id : id;
226
-
old_state : string option;
227
-
new_state : string;
228
-
created : (id * mailbox) list option;
229
-
updated : id list option;
230
-
destroyed : id list option;
231
-
not_created : (id * set_error) list option;
232
-
not_updated : (id * set_error) list option;
233
-
not_destroyed : (id * set_error) list option;
234
-
}
235
-
236
-
(** {1:thread Thread objects} *)
237
-
238
-
(** A thread in a mail account. See RFC8621 Section 3. *)
239
-
type thread = {
240
-
id : id;
241
-
email_ids : id list;
242
-
}
243
-
244
-
(** Thread/get request arguments. See RFC8621 Section 3.1. *)
245
-
type thread_get_arguments = {
246
-
account_id : id;
247
-
ids : id list option;
248
-
properties : string list option;
249
-
}
250
-
251
-
(** Thread/get response. See RFC8621 Section 3.1. *)
252
-
type thread_get_response = {
253
-
account_id : id;
254
-
state : string;
255
-
list : thread list;
256
-
not_found : id list;
257
-
}
258
-
259
-
(** Thread/changes request arguments. See RFC8621 Section 3.2. *)
260
-
type thread_changes_arguments = {
261
-
account_id : id;
262
-
since_state : string;
263
-
max_changes : unsigned_int option;
264
-
}
265
-
266
-
(** Thread/changes response. See RFC8621 Section 3.2. *)
267
-
type thread_changes_response = {
268
-
account_id : id;
269
-
old_state : string;
270
-
new_state : string;
271
-
has_more_changes : bool;
272
-
created : id list;
273
-
updated : id list;
274
-
destroyed : id list;
275
-
}
276
-
277
-
(** {1:email Email objects} *)
278
-
279
-
(** Addressing (mailbox) information. See RFC8621 Section 4.1.1. *)
280
-
type email_address = {
281
-
name : string option;
282
-
email : string;
283
-
parameters : (string * string) list;
284
-
}
285
-
286
-
(** Message header field. See RFC8621 Section 4.1.2. *)
287
-
type header = {
288
-
name : string;
289
-
value : string;
290
-
}
291
-
292
-
(** Email keyword (flag). See RFC8621 Section 4.3. *)
293
-
type keyword =
294
-
| Flagged
295
-
| Answered
296
-
| Draft
297
-
| Forwarded
298
-
| Phishing
299
-
| Junk
300
-
| NotJunk
301
-
| Seen
302
-
| Unread
303
-
| Custom of string
304
-
305
-
(** Email message. See RFC8621 Section 4. *)
306
-
type email = {
307
-
id : id;
308
-
blob_id : id;
309
-
thread_id : id;
310
-
mailbox_ids : (id * bool) list;
311
-
keywords : (keyword * bool) list;
312
-
size : unsigned_int;
313
-
received_at : utc_date;
314
-
message_id : string list;
315
-
in_reply_to : string list option;
316
-
references : string list option;
317
-
sender : email_address list option;
318
-
from : email_address list option;
319
-
to_ : email_address list option;
320
-
cc : email_address list option;
321
-
bcc : email_address list option;
322
-
reply_to : email_address list option;
323
-
subject : string option;
324
-
sent_at : utc_date option;
325
-
has_attachment : bool option;
326
-
preview : string option;
327
-
body_values : (string * string) list option;
328
-
text_body : email_body_part list option;
329
-
html_body : email_body_part list option;
330
-
attachments : email_body_part list option;
331
-
headers : header list option;
332
-
}
333
-
334
-
(** Email body part. See RFC8621 Section 4.1.4. *)
335
-
and email_body_part = {
336
-
part_id : string option;
337
-
blob_id : id option;
338
-
size : unsigned_int option;
339
-
headers : header list option;
340
-
name : string option;
341
-
type_ : string option;
342
-
charset : string option;
343
-
disposition : string option;
344
-
cid : string option;
345
-
language : string list option;
346
-
location : string option;
347
-
sub_parts : email_body_part list option;
348
-
header_parameter_name : string option;
349
-
header_parameter_value : string option;
350
-
}
351
-
352
-
(** Email query filter condition. See RFC8621 Section 4.4. *)
353
-
type email_filter_condition = {
354
-
in_mailbox : id option;
355
-
in_mailbox_other_than : id list option;
356
-
min_size : unsigned_int option;
357
-
max_size : unsigned_int option;
358
-
before : utc_date option;
359
-
after : utc_date option;
360
-
header : (string * string) option;
361
-
from : string option;
362
-
to_ : string option;
363
-
cc : string option;
364
-
bcc : string option;
365
-
subject : string option;
366
-
body : string option;
367
-
has_keyword : string option;
368
-
not_keyword : string option;
369
-
has_attachment : bool option;
370
-
text : string option;
371
-
}
372
-
373
-
type email_query_filter = [
374
-
| `And of email_query_filter list
375
-
| `Or of email_query_filter list
376
-
| `Not of email_query_filter
377
-
| `Condition of email_filter_condition
378
-
]
379
-
380
-
(** Email/get request arguments. See RFC8621 Section 4.5. *)
381
-
type email_get_arguments = {
382
-
account_id : id;
383
-
ids : id list option;
384
-
properties : string list option;
385
-
body_properties : string list option;
386
-
fetch_text_body_values : bool option;
387
-
fetch_html_body_values : bool option;
388
-
fetch_all_body_values : bool option;
389
-
max_body_value_bytes : unsigned_int option;
390
-
}
391
-
392
-
(** Email/get response. See RFC8621 Section 4.5. *)
393
-
type email_get_response = {
394
-
account_id : id;
395
-
state : string;
396
-
list : email list;
397
-
not_found : id list;
398
-
}
399
-
400
-
(** Email/changes request arguments. See RFC8621 Section 4.6. *)
401
-
type email_changes_arguments = {
402
-
account_id : id;
403
-
since_state : string;
404
-
max_changes : unsigned_int option;
405
-
}
406
-
407
-
(** Email/changes response. See RFC8621 Section 4.6. *)
408
-
type email_changes_response = {
409
-
account_id : id;
410
-
old_state : string;
411
-
new_state : string;
412
-
has_more_changes : bool;
413
-
created : id list;
414
-
updated : id list;
415
-
destroyed : id list;
416
-
}
417
-
418
-
(** Email/query request arguments. See RFC8621 Section 4.4. *)
419
-
type email_query_arguments = {
420
-
account_id : id;
421
-
filter : email_query_filter option;
422
-
sort : comparator list option;
423
-
collapse_threads : bool option;
424
-
position : unsigned_int option;
425
-
anchor : id option;
426
-
anchor_offset : int_t option;
427
-
limit : unsigned_int option;
428
-
calculate_total : bool option;
429
-
}
430
-
431
-
(** Email/query response. See RFC8621 Section 4.4. *)
432
-
type email_query_response = {
433
-
account_id : id;
434
-
query_state : string;
435
-
can_calculate_changes : bool;
436
-
position : unsigned_int;
437
-
ids : id list;
438
-
total : unsigned_int option;
439
-
thread_ids : id list option;
440
-
}
441
-
442
-
(** Email/queryChanges request arguments. See RFC8621 Section 4.7. *)
443
-
type email_query_changes_arguments = {
444
-
account_id : id;
445
-
filter : email_query_filter option;
446
-
sort : comparator list option;
447
-
collapse_threads : bool option;
448
-
since_query_state : string;
449
-
max_changes : unsigned_int option;
450
-
up_to_id : id option;
451
-
}
452
-
453
-
(** Email/queryChanges response. See RFC8621 Section 4.7. *)
454
-
type email_query_changes_response = {
455
-
account_id : id;
456
-
old_query_state : string;
457
-
new_query_state : string;
458
-
total : unsigned_int option;
459
-
removed : id list;
460
-
added : email_query_changes_added list;
461
-
}
462
-
463
-
and email_query_changes_added = {
464
-
id : id;
465
-
index : unsigned_int;
466
-
}
467
-
468
-
(** Email/set request arguments. See RFC8621 Section 4.8. *)
469
-
type email_set_arguments = {
470
-
account_id : id;
471
-
if_in_state : string option;
472
-
create : (id * email_creation) list option;
473
-
update : (id * email_update) list option;
474
-
destroy : id list option;
475
-
}
476
-
477
-
and email_creation = {
478
-
mailbox_ids : (id * bool) list;
479
-
keywords : (keyword * bool) list option;
480
-
received_at : utc_date option;
481
-
message_id : string list option;
482
-
in_reply_to : string list option;
483
-
references : string list option;
484
-
sender : email_address list option;
485
-
from : email_address list option;
486
-
to_ : email_address list option;
487
-
cc : email_address list option;
488
-
bcc : email_address list option;
489
-
reply_to : email_address list option;
490
-
subject : string option;
491
-
body_values : (string * string) list option;
492
-
text_body : email_body_part list option;
493
-
html_body : email_body_part list option;
494
-
attachments : email_body_part list option;
495
-
headers : header list option;
496
-
}
497
-
498
-
and email_update = {
499
-
keywords : (keyword * bool) list option;
500
-
mailbox_ids : (id * bool) list option;
501
-
}
502
-
503
-
(** Email/set response. See RFC8621 Section 4.8. *)
504
-
type email_set_response = {
505
-
account_id : id;
506
-
old_state : string option;
507
-
new_state : string;
508
-
created : (id * email) list option;
509
-
updated : id list option;
510
-
destroyed : id list option;
511
-
not_created : (id * set_error) list option;
512
-
not_updated : (id * set_error) list option;
513
-
not_destroyed : (id * set_error) list option;
514
-
}
515
-
516
-
(** Email/copy request arguments. See RFC8621 Section 4.9. *)
517
-
type email_copy_arguments = {
518
-
from_account_id : id;
519
-
account_id : id;
520
-
create : (id * email_creation) list;
521
-
on_success_destroy_original : bool option;
522
-
}
523
-
524
-
(** Email/copy response. See RFC8621 Section 4.9. *)
525
-
type email_copy_response = {
526
-
from_account_id : id;
527
-
account_id : id;
528
-
created : (id * email) list option;
529
-
not_created : (id * set_error) list option;
530
-
}
531
-
532
-
(** Email/import request arguments. See RFC8621 Section 4.10. *)
533
-
type email_import_arguments = {
534
-
account_id : id;
535
-
emails : (id * email_import) list;
536
-
}
537
-
538
-
and email_import = {
539
-
blob_id : id;
540
-
mailbox_ids : (id * bool) list;
541
-
keywords : (keyword * bool) list option;
542
-
received_at : utc_date option;
543
-
}
544
-
545
-
(** Email/import response. See RFC8621 Section 4.10. *)
546
-
type email_import_response = {
547
-
account_id : id;
548
-
created : (id * email) list option;
549
-
not_created : (id * set_error) list option;
550
-
}
551
-
552
-
(** {1:search_snippet Search snippets} *)
553
-
554
-
(** SearchSnippet/get request arguments. See RFC8621 Section 4.11. *)
555
-
type search_snippet_get_arguments = {
556
-
account_id : id;
557
-
email_ids : id list;
558
-
filter : email_filter_condition;
559
-
}
560
-
561
-
(** SearchSnippet/get response. See RFC8621 Section 4.11. *)
562
-
type search_snippet_get_response = {
563
-
account_id : id;
564
-
list : (id * search_snippet) list;
565
-
not_found : id list;
566
-
}
567
-
568
-
and search_snippet = {
569
-
subject : string option;
570
-
preview : string option;
571
-
}
572
-
573
-
(** {1:submission EmailSubmission objects} *)
574
-
575
-
(** EmailSubmission address. See RFC8621 Section 5.1. *)
576
-
type submission_address = {
577
-
email : string;
578
-
parameters : (string * string) list option;
579
-
}
580
-
581
-
(** Email submission object. See RFC8621 Section 5.1. *)
582
-
type email_submission = {
583
-
id : id;
584
-
identity_id : id;
585
-
email_id : id;
586
-
thread_id : id;
587
-
envelope : envelope option;
588
-
send_at : utc_date option;
589
-
undo_status : [
590
-
| `pending
591
-
| `final
592
-
| `canceled
593
-
] option;
594
-
delivery_status : (string * submission_status) list option;
595
-
dsn_blob_ids : (string * id) list option;
596
-
mdn_blob_ids : (string * id) list option;
597
-
}
598
-
599
-
(** Envelope for mail submission. See RFC8621 Section 5.1. *)
600
-
and envelope = {
601
-
mail_from : submission_address;
602
-
rcpt_to : submission_address list;
603
-
}
604
-
605
-
(** Delivery status for submitted email. See RFC8621 Section 5.1. *)
606
-
and submission_status = {
607
-
smtp_reply : string;
608
-
delivered : string option;
609
-
}
610
-
611
-
(** EmailSubmission/get request arguments. See RFC8621 Section 5.3. *)
612
-
type email_submission_get_arguments = {
613
-
account_id : id;
614
-
ids : id list option;
615
-
properties : string list option;
616
-
}
617
-
618
-
(** EmailSubmission/get response. See RFC8621 Section 5.3. *)
619
-
type email_submission_get_response = {
620
-
account_id : id;
621
-
state : string;
622
-
list : email_submission list;
623
-
not_found : id list;
624
-
}
625
-
626
-
(** EmailSubmission/changes request arguments. See RFC8621 Section 5.4. *)
627
-
type email_submission_changes_arguments = {
628
-
account_id : id;
629
-
since_state : string;
630
-
max_changes : unsigned_int option;
631
-
}
632
-
633
-
(** EmailSubmission/changes response. See RFC8621 Section 5.4. *)
634
-
type email_submission_changes_response = {
635
-
account_id : id;
636
-
old_state : string;
637
-
new_state : string;
638
-
has_more_changes : bool;
639
-
created : id list;
640
-
updated : id list;
641
-
destroyed : id list;
642
-
}
643
-
644
-
(** EmailSubmission/query filter condition. See RFC8621 Section 5.5. *)
645
-
type email_submission_filter_condition = {
646
-
identity_id : id option;
647
-
email_id : id option;
648
-
thread_id : id option;
649
-
before : utc_date option;
650
-
after : utc_date option;
651
-
subject : string option;
652
-
}
653
-
654
-
type email_submission_query_filter = [
655
-
| `And of email_submission_query_filter list
656
-
| `Or of email_submission_query_filter list
657
-
| `Not of email_submission_query_filter
658
-
| `Condition of email_submission_filter_condition
659
-
]
660
-
661
-
(** EmailSubmission/query request arguments. See RFC8621 Section 5.5. *)
662
-
type email_submission_query_arguments = {
663
-
account_id : id;
664
-
filter : email_submission_query_filter option;
665
-
sort : comparator list option;
666
-
position : unsigned_int option;
667
-
anchor : id option;
668
-
anchor_offset : int_t option;
669
-
limit : unsigned_int option;
670
-
calculate_total : bool option;
671
-
}
672
-
673
-
(** EmailSubmission/query response. See RFC8621 Section 5.5. *)
674
-
type email_submission_query_response = {
675
-
account_id : id;
676
-
query_state : string;
677
-
can_calculate_changes : bool;
678
-
position : unsigned_int;
679
-
ids : id list;
680
-
total : unsigned_int option;
681
-
}
682
-
683
-
(** EmailSubmission/set request arguments. See RFC8621 Section 5.6. *)
684
-
type email_submission_set_arguments = {
685
-
account_id : id;
686
-
if_in_state : string option;
687
-
create : (id * email_submission_creation) list option;
688
-
update : (id * email_submission_update) list option;
689
-
destroy : id list option;
690
-
on_success_update_email : (id * email_update) list option;
691
-
}
692
-
693
-
and email_submission_creation = {
694
-
email_id : id;
695
-
identity_id : id;
696
-
envelope : envelope option;
697
-
send_at : utc_date option;
698
-
}
699
-
700
-
and email_submission_update = {
701
-
email_id : id option;
702
-
identity_id : id option;
703
-
envelope : envelope option;
704
-
undo_status : [`canceled] option;
705
-
}
706
-
707
-
(** EmailSubmission/set response. See RFC8621 Section 5.6. *)
708
-
type email_submission_set_response = {
709
-
account_id : id;
710
-
old_state : string option;
711
-
new_state : string;
712
-
created : (id * email_submission) list option;
713
-
updated : id list option;
714
-
destroyed : id list option;
715
-
not_created : (id * set_error) list option;
716
-
not_updated : (id * set_error) list option;
717
-
not_destroyed : (id * set_error) list option;
718
-
}
719
-
720
-
(** {1:identity Identity objects} *)
721
-
722
-
(** Identity for sending mail. See RFC8621 Section 6. *)
723
-
type identity = {
724
-
id : id;
725
-
name : string;
726
-
email : string;
727
-
reply_to : email_address list option;
728
-
bcc : email_address list option;
729
-
text_signature : string option;
730
-
html_signature : string option;
731
-
may_delete : bool;
732
-
}
733
-
734
-
(** Identity/get request arguments. See RFC8621 Section 6.1. *)
735
-
type identity_get_arguments = {
736
-
account_id : id;
737
-
ids : id list option;
738
-
properties : string list option;
739
-
}
740
-
741
-
(** Identity/get response. See RFC8621 Section 6.1. *)
742
-
type identity_get_response = {
743
-
account_id : id;
744
-
state : string;
745
-
list : identity list;
746
-
not_found : id list;
747
-
}
748
-
749
-
(** Identity/changes request arguments. See RFC8621 Section 6.2. *)
750
-
type identity_changes_arguments = {
751
-
account_id : id;
752
-
since_state : string;
753
-
max_changes : unsigned_int option;
754
-
}
755
-
756
-
(** Identity/changes response. See RFC8621 Section 6.2. *)
757
-
type identity_changes_response = {
758
-
account_id : id;
759
-
old_state : string;
760
-
new_state : string;
761
-
has_more_changes : bool;
762
-
created : id list;
763
-
updated : id list;
764
-
destroyed : id list;
765
-
}
766
-
767
-
(** Identity/set request arguments. See RFC8621 Section 6.3. *)
768
-
type identity_set_arguments = {
769
-
account_id : id;
770
-
if_in_state : string option;
771
-
create : (id * identity_creation) list option;
772
-
update : (id * identity_update) list option;
773
-
destroy : id list option;
774
-
}
775
-
776
-
and identity_creation = {
777
-
name : string;
778
-
email : string;
779
-
reply_to : email_address list option;
780
-
bcc : email_address list option;
781
-
text_signature : string option;
782
-
html_signature : string option;
783
-
}
784
-
785
-
and identity_update = {
786
-
name : string option;
787
-
email : string option;
788
-
reply_to : email_address list option;
789
-
bcc : email_address list option;
790
-
text_signature : string option;
791
-
html_signature : string option;
792
-
}
793
-
794
-
(** Identity/set response. See RFC8621 Section 6.3. *)
795
-
type identity_set_response = {
796
-
account_id : id;
797
-
old_state : string option;
798
-
new_state : string;
799
-
created : (id * identity) list option;
800
-
updated : id list option;
801
-
destroyed : id list option;
802
-
not_created : (id * set_error) list option;
803
-
not_updated : (id * set_error) list option;
804
-
not_destroyed : (id * set_error) list option;
805
-
}
806
-
807
-
(** {1:vacation_response VacationResponse objects} *)
808
-
809
-
(** Vacation auto-reply setting. See RFC8621 Section 7. *)
810
-
type vacation_response = {
811
-
id : id;
812
-
is_enabled : bool;
813
-
from_date : utc_date option;
814
-
to_date : utc_date option;
815
-
subject : string option;
816
-
text_body : string option;
817
-
html_body : string option;
818
-
}
819
-
820
-
(** VacationResponse/get request arguments. See RFC8621 Section 7.2. *)
821
-
type vacation_response_get_arguments = {
822
-
account_id : id;
823
-
ids : id list option;
824
-
properties : string list option;
825
-
}
826
-
827
-
(** VacationResponse/get response. See RFC8621 Section 7.2. *)
828
-
type vacation_response_get_response = {
829
-
account_id : id;
830
-
state : string;
831
-
list : vacation_response list;
832
-
not_found : id list;
833
-
}
834
-
835
-
(** VacationResponse/set request arguments. See RFC8621 Section 7.3. *)
836
-
type vacation_response_set_arguments = {
837
-
account_id : id;
838
-
if_in_state : string option;
839
-
update : (id * vacation_response_update) list;
840
-
}
841
-
842
-
and vacation_response_update = {
843
-
is_enabled : bool option;
844
-
from_date : utc_date option;
845
-
to_date : utc_date option;
846
-
subject : string option;
847
-
text_body : string option;
848
-
html_body : string option;
849
-
}
850
-
851
-
(** VacationResponse/set response. See RFC8621 Section 7.3. *)
852
-
type vacation_response_set_response = {
853
-
account_id : id;
854
-
old_state : string option;
855
-
new_state : string;
856
-
updated : id list option;
857
-
not_updated : (id * set_error) list option;
858
-
}
859
-
860
-
(** {1:message_flags Message Flags and Mailbox Attributes} *)
861
-
862
-
(** Flag color defined by the combination of MailFlagBit0, MailFlagBit1, and MailFlagBit2 keywords *)
863
-
type flag_color =
864
-
| Red (** Bit pattern 000 *)
865
-
| Orange (** Bit pattern 100 *)
866
-
| Yellow (** Bit pattern 010 *)
867
-
| Green (** Bit pattern 111 *)
868
-
| Blue (** Bit pattern 001 *)
869
-
| Purple (** Bit pattern 101 *)
870
-
| Gray (** Bit pattern 011 *)
871
-
872
-
(** Standard message keywords as defined in draft-ietf-mailmaint-messageflag-mailboxattribute-02 *)
873
-
type message_keyword =
874
-
| Notify (** Indicate a notification should be shown for this message *)
875
-
| Muted (** User is not interested in future replies to this thread *)
876
-
| Followed (** User is particularly interested in future replies to this thread *)
877
-
| Memo (** Message is a note-to-self about another message in the same thread *)
878
-
| HasMemo (** Message has an associated memo with the $memo keyword *)
879
-
| HasAttachment (** Message has an attachment *)
880
-
| HasNoAttachment (** Message does not have an attachment *)
881
-
| AutoSent (** Message was sent automatically as a response due to a user rule *)
882
-
| Unsubscribed (** User has unsubscribed from the thread this message is in *)
883
-
| CanUnsubscribe (** Message has an RFC8058-compliant List-Unsubscribe header *)
884
-
| Imported (** Message was imported from another mailbox *)
885
-
| IsTrusted (** Server has verified authenticity of the from name and email *)
886
-
| MaskedEmail (** Message was received via an alias created for an individual sender *)
887
-
| New (** Message should be made more prominent due to a recent action *)
888
-
| MailFlagBit0 (** Bit 0 of the 3-bit flag color pattern *)
889
-
| MailFlagBit1 (** Bit 1 of the 3-bit flag color pattern *)
890
-
| MailFlagBit2 (** Bit 2 of the 3-bit flag color pattern *)
891
-
| OtherKeyword of string (** Other non-standard keywords *)
892
-
893
-
(** Special mailbox attribute names as defined in draft-ietf-mailmaint-messageflag-mailboxattribute-02 *)
894
-
type mailbox_attribute =
895
-
| Snoozed (** Mailbox containing messages that have been snoozed *)
896
-
| Scheduled (** Mailbox containing messages scheduled to be sent later *)
897
-
| Memos (** Mailbox containing messages with the $memo keyword *)
898
-
| OtherAttribute of string (** Other non-standard mailbox attributes *)
899
-
900
-
(** Functions for working with flag colors based on the specification in
901
-
draft-ietf-mailmaint-messageflag-mailboxattribute-02, section 3.1. *)
902
-
903
-
(** Convert bit pattern to flag color *)
904
-
let flag_color_of_bits bit0 bit1 bit2 =
905
-
match (bit0, bit1, bit2) with
906
-
| (false, false, false) -> Red (* 000 *)
907
-
| (true, false, false) -> Orange (* 100 *)
908
-
| (false, true, false) -> Yellow (* 010 *)
909
-
| (true, true, true) -> Green (* 111 *)
910
-
| (false, false, true) -> Blue (* 001 *)
911
-
| (true, false, true) -> Purple (* 101 *)
912
-
| (false, true, true) -> Gray (* 011 *)
913
-
| (true, true, false) -> Green (* 110 - not in spec, defaulting to green *)
914
-
915
-
(** Get bits for a flag color *)
916
-
let bits_of_flag_color = function
917
-
| Red -> (false, false, false)
918
-
| Orange -> (true, false, false)
919
-
| Yellow -> (false, true, false)
920
-
| Green -> (true, true, true)
921
-
| Blue -> (false, false, true)
922
-
| Purple -> (true, false, true)
923
-
| Gray -> (false, true, true)
924
-
925
-
(** Check if a keyword list contains a flag color *)
926
-
let has_flag_color keywords =
927
-
let has_bit0 = List.exists (function
928
-
| (Custom s, true) when s = "$MailFlagBit0" -> true
929
-
| _ -> false
930
-
) keywords in
931
-
932
-
let has_bit1 = List.exists (function
933
-
| (Custom s, true) when s = "$MailFlagBit1" -> true
934
-
| _ -> false
935
-
) keywords in
936
-
937
-
let has_bit2 = List.exists (function
938
-
| (Custom s, true) when s = "$MailFlagBit2" -> true
939
-
| _ -> false
940
-
) keywords in
941
-
942
-
has_bit0 || has_bit1 || has_bit2
943
-
944
-
(** Extract flag color from keywords if present *)
945
-
let get_flag_color keywords =
946
-
(* First check if the message has the \Flagged system flag *)
947
-
let is_flagged = List.exists (function
948
-
| (Flagged, true) -> true
949
-
| _ -> false
950
-
) keywords in
951
-
952
-
if not is_flagged then
953
-
None
954
-
else
955
-
(* Get values of each bit flag *)
956
-
let bit0 = List.exists (function
957
-
| (Custom s, true) when s = "$MailFlagBit0" -> true
958
-
| _ -> false
959
-
) keywords in
960
-
961
-
let bit1 = List.exists (function
962
-
| (Custom s, true) when s = "$MailFlagBit1" -> true
963
-
| _ -> false
964
-
) keywords in
965
-
966
-
let bit2 = List.exists (function
967
-
| (Custom s, true) when s = "$MailFlagBit2" -> true
968
-
| _ -> false
969
-
) keywords in
970
-
971
-
Some (flag_color_of_bits bit0 bit1 bit2)
972
-
973
-
(** Convert a message keyword to its string representation *)
974
-
let string_of_message_keyword = function
975
-
| Notify -> "$notify"
976
-
| Muted -> "$muted"
977
-
| Followed -> "$followed"
978
-
| Memo -> "$memo"
979
-
| HasMemo -> "$hasmemo"
980
-
| HasAttachment -> "$hasattachment"
981
-
| HasNoAttachment -> "$hasnoattachment"
982
-
| AutoSent -> "$autosent"
983
-
| Unsubscribed -> "$unsubscribed"
984
-
| CanUnsubscribe -> "$canunsubscribe"
985
-
| Imported -> "$imported"
986
-
| IsTrusted -> "$istrusted"
987
-
| MaskedEmail -> "$maskedemail"
988
-
| New -> "$new"
989
-
| MailFlagBit0 -> "$MailFlagBit0"
990
-
| MailFlagBit1 -> "$MailFlagBit1"
991
-
| MailFlagBit2 -> "$MailFlagBit2"
992
-
| OtherKeyword s -> s
993
-
994
-
(** Parse a string into a message keyword *)
995
-
let message_keyword_of_string = function
996
-
| "$notify" -> Notify
997
-
| "$muted" -> Muted
998
-
| "$followed" -> Followed
999
-
| "$memo" -> Memo
1000
-
| "$hasmemo" -> HasMemo
1001
-
| "$hasattachment" -> HasAttachment
1002
-
| "$hasnoattachment" -> HasNoAttachment
1003
-
| "$autosent" -> AutoSent
1004
-
| "$unsubscribed" -> Unsubscribed
1005
-
| "$canunsubscribe" -> CanUnsubscribe
1006
-
| "$imported" -> Imported
1007
-
| "$istrusted" -> IsTrusted
1008
-
| "$maskedemail" -> MaskedEmail
1009
-
| "$new" -> New
1010
-
| "$MailFlagBit0" -> MailFlagBit0
1011
-
| "$MailFlagBit1" -> MailFlagBit1
1012
-
| "$MailFlagBit2" -> MailFlagBit2
1013
-
| s -> OtherKeyword s
1014
-
1015
-
(** Convert a mailbox attribute to its string representation *)
1016
-
let string_of_mailbox_attribute = function
1017
-
| Snoozed -> "Snoozed"
1018
-
| Scheduled -> "Scheduled"
1019
-
| Memos -> "Memos"
1020
-
| OtherAttribute s -> s
1021
-
1022
-
(** Parse a string into a mailbox attribute *)
1023
-
let mailbox_attribute_of_string = function
1024
-
| "Snoozed" -> Snoozed
1025
-
| "Scheduled" -> Scheduled
1026
-
| "Memos" -> Memos
1027
-
| s -> OtherAttribute s
1028
-
1029
-
(** Get a human-readable representation of a flag color *)
1030
-
let human_readable_flag_color = function
1031
-
| Red -> "Red"
1032
-
| Orange -> "Orange"
1033
-
| Yellow -> "Yellow"
1034
-
| Green -> "Green"
1035
-
| Blue -> "Blue"
1036
-
| Purple -> "Purple"
1037
-
| Gray -> "Gray"
1038
-
1039
-
(** Get a human-readable representation of a message keyword *)
1040
-
let human_readable_message_keyword = function
1041
-
| Notify -> "Notify"
1042
-
| Muted -> "Muted"
1043
-
| Followed -> "Followed"
1044
-
| Memo -> "Memo"
1045
-
| HasMemo -> "Has Memo"
1046
-
| HasAttachment -> "Has Attachment"
1047
-
| HasNoAttachment -> "No Attachment"
1048
-
| AutoSent -> "Auto Sent"
1049
-
| Unsubscribed -> "Unsubscribed"
1050
-
| CanUnsubscribe -> "Can Unsubscribe"
1051
-
| Imported -> "Imported"
1052
-
| IsTrusted -> "Trusted"
1053
-
| MaskedEmail -> "Masked Email"
1054
-
| New -> "New"
1055
-
| MailFlagBit0 | MailFlagBit1 | MailFlagBit2 -> "Flag Bit"
1056
-
| OtherKeyword s -> s
1057
-
1058
-
(** Format email keywords into a human-readable string representation *)
1059
-
let format_email_keywords keywords =
1060
-
(* Get flag color if present *)
1061
-
let color_str =
1062
-
match get_flag_color keywords with
1063
-
| Some color -> human_readable_flag_color color
1064
-
| None -> ""
1065
-
in
1066
-
1067
-
(* Get standard JMAP keywords *)
1068
-
let standard_keywords = List.filter_map (fun (kw, active) ->
1069
-
if not active then None
1070
-
else match kw with
1071
-
| Flagged -> Some "Flagged"
1072
-
| Answered -> Some "Answered"
1073
-
| Draft -> Some "Draft"
1074
-
| Forwarded -> Some "Forwarded"
1075
-
| Phishing -> Some "Phishing"
1076
-
| Junk -> Some "Junk"
1077
-
| NotJunk -> Some "Not Junk"
1078
-
| Seen -> Some "Seen"
1079
-
| Unread -> Some "Unread"
1080
-
| _ -> None
1081
-
) keywords in
1082
-
1083
-
(* Get message keywords *)
1084
-
let message_keywords = List.filter_map (fun (kw, active) ->
1085
-
if not active then None
1086
-
else match kw with
1087
-
| Custom s ->
1088
-
(* Try to parse as message keyword *)
1089
-
let message_kw = message_keyword_of_string s in
1090
-
(match message_kw with
1091
-
| OtherKeyword _ -> None
1092
-
| MailFlagBit0 | MailFlagBit1 | MailFlagBit2 -> None
1093
-
| kw -> Some (human_readable_message_keyword kw))
1094
-
| _ -> None
1095
-
) keywords in
1096
-
1097
-
(* Combine all human-readable labels *)
1098
-
let all_parts =
1099
-
(if color_str <> "" then [color_str] else []) @
1100
-
standard_keywords @
1101
-
message_keywords
1102
-
in
1103
-
1104
-
String.concat ", " all_parts
1105
-
end
1106
-
1107
-
(** {1 JSON serialization} *)
1108
-
1109
-
module Json = struct
1110
-
open Types
1111
-
1112
-
(** {2 Helper functions for serialization} *)
1113
-
1114
-
let string_of_mailbox_role = function
1115
-
| All -> "all"
1116
-
| Archive -> "archive"
1117
-
| Drafts -> "drafts"
1118
-
| Flagged -> "flagged"
1119
-
| Important -> "important"
1120
-
| Inbox -> "inbox"
1121
-
| Junk -> "junk"
1122
-
| Sent -> "sent"
1123
-
| Trash -> "trash"
1124
-
| Unknown s -> s
1125
-
1126
-
let mailbox_role_of_string = function
1127
-
| "all" -> All
1128
-
| "archive" -> Archive
1129
-
| "drafts" -> Drafts
1130
-
| "flagged" -> Flagged
1131
-
| "important" -> Important
1132
-
| "inbox" -> Inbox
1133
-
| "junk" -> Junk
1134
-
| "sent" -> Sent
1135
-
| "trash" -> Trash
1136
-
| s -> Unknown s
1137
-
1138
-
let string_of_keyword = function
1139
-
| Flagged -> "$flagged"
1140
-
| Answered -> "$answered"
1141
-
| Draft -> "$draft"
1142
-
| Forwarded -> "$forwarded"
1143
-
| Phishing -> "$phishing"
1144
-
| Junk -> "$junk"
1145
-
| NotJunk -> "$notjunk"
1146
-
| Seen -> "$seen"
1147
-
| Unread -> "$unread"
1148
-
| Custom s -> s
1149
-
1150
-
let keyword_of_string = function
1151
-
| "$flagged" -> Flagged
1152
-
| "$answered" -> Answered
1153
-
| "$draft" -> Draft
1154
-
| "$forwarded" -> Forwarded
1155
-
| "$phishing" -> Phishing
1156
-
| "$junk" -> Junk
1157
-
| "$notjunk" -> NotJunk
1158
-
| "$seen" -> Seen
1159
-
| "$unread" -> Unread
1160
-
| s -> Custom s
1161
-
1162
-
(** {2 Mailbox serialization} *)
1163
-
1164
-
(** TODO:claude - Need to implement all JSON serialization functions
1165
-
for each type we've defined. This would be a substantial amount of
1166
-
code and likely require additional understanding of the ezjsonm API.
1167
-
1168
-
For a full implementation, we would need functions to convert between
1169
-
OCaml types and JSON for each of:
1170
-
- mailbox, mailbox_rights, mailbox query/update operations
1171
-
- thread operations
1172
-
- email, email_address, header, email_body_part
1173
-
- email query/update operations
1174
-
- submission operations
1175
-
- identity operations
1176
-
- vacation response operations
1177
-
*)
1178
-
end
1179
-
1180
-
(** {1 API functions} *)
1181
-
1182
-
open Lwt.Syntax
1183
-
open Jmap.Api
1184
-
open Jmap.Types
1185
-
1186
-
(** Authentication credentials for a JMAP server *)
1187
-
type credentials = {
1188
-
username: string;
1189
-
password: string;
1190
-
}
1191
-
1192
-
(** Connection to a JMAP mail server *)
1193
-
type connection = {
1194
-
session: Jmap.Types.session;
1195
-
config: Jmap.Api.config;
1196
-
}
1197
-
1198
-
(** Convert JSON mail object to OCaml type *)
1199
-
let mailbox_of_json json =
1200
-
try
1201
-
let open Ezjsonm in
1202
-
let id = get_string (find json ["id"]) in
1203
-
let name = get_string (find json ["name"]) in
1204
-
(* Handle parentId which can be null *)
1205
-
let parent_id =
1206
-
match find_opt json ["parentId"] with
1207
-
| Some (`Null) -> None
1208
-
| Some (`String s) -> Some s
1209
-
| None -> None
1210
-
| _ -> None
1211
-
in
1212
-
(* Handle role which might be null *)
1213
-
let role =
1214
-
match find_opt json ["role"] with
1215
-
| Some (`Null) -> None
1216
-
| Some (`String s) -> Some (Json.mailbox_role_of_string s)
1217
-
| None -> None
1218
-
| _ -> None
1219
-
in
1220
-
let sort_order = get_int (find json ["sortOrder"]) in
1221
-
let total_emails = get_int (find json ["totalEmails"]) in
1222
-
let unread_emails = get_int (find json ["unreadEmails"]) in
1223
-
let total_threads = get_int (find json ["totalThreads"]) in
1224
-
let unread_threads = get_int (find json ["unreadThreads"]) in
1225
-
let is_subscribed = get_bool (find json ["isSubscribed"]) in
1226
-
let rights_json = find json ["myRights"] in
1227
-
let my_rights = {
1228
-
Types.may_read_items = get_bool (find rights_json ["mayReadItems"]);
1229
-
may_add_items = get_bool (find rights_json ["mayAddItems"]);
1230
-
may_remove_items = get_bool (find rights_json ["mayRemoveItems"]);
1231
-
may_set_seen = get_bool (find rights_json ["maySetSeen"]);
1232
-
may_set_keywords = get_bool (find rights_json ["maySetKeywords"]);
1233
-
may_create_child = get_bool (find rights_json ["mayCreateChild"]);
1234
-
may_rename = get_bool (find rights_json ["mayRename"]);
1235
-
may_delete = get_bool (find rights_json ["mayDelete"]);
1236
-
may_submit = get_bool (find rights_json ["maySubmit"]);
1237
-
} in
1238
-
let result = {
1239
-
Types.id;
1240
-
name;
1241
-
parent_id;
1242
-
role;
1243
-
sort_order;
1244
-
total_emails;
1245
-
unread_emails;
1246
-
total_threads;
1247
-
unread_threads;
1248
-
is_subscribed;
1249
-
my_rights;
1250
-
} in
1251
-
Ok (result)
1252
-
with
1253
-
| Not_found ->
1254
-
Error (Parse_error "Required field not found in mailbox object")
1255
-
| Invalid_argument msg ->
1256
-
Error (Parse_error msg)
1257
-
| e ->
1258
-
Error (Parse_error (Printexc.to_string e))
1259
-
1260
-
(** Convert JSON email object to OCaml type *)
1261
-
let email_of_json json =
1262
-
try
1263
-
let open Ezjsonm in
1264
-
1265
-
let id = get_string (find json ["id"]) in
1266
-
let blob_id = get_string (find json ["blobId"]) in
1267
-
let thread_id = get_string (find json ["threadId"]) in
1268
-
1269
-
(* Process mailboxIds map *)
1270
-
let mailbox_ids_json = find json ["mailboxIds"] in
1271
-
let mailbox_ids = match mailbox_ids_json with
1272
-
| `O items -> List.map (fun (id, v) -> (id, get_bool v)) items
1273
-
| _ -> raise (Invalid_argument "mailboxIds is not an object")
1274
-
in
1275
-
1276
-
(* Process keywords map *)
1277
-
let keywords_json = find json ["keywords"] in
1278
-
let keywords = match keywords_json with
1279
-
| `O items -> List.map (fun (k, v) ->
1280
-
(Json.keyword_of_string k, get_bool v)) items
1281
-
| _ -> raise (Invalid_argument "keywords is not an object")
1282
-
in
1283
-
1284
-
let size = get_int (find json ["size"]) in
1285
-
let received_at = get_string (find json ["receivedAt"]) in
1286
-
1287
-
(* Handle messageId which might be an array or missing *)
1288
-
let message_id =
1289
-
match find_opt json ["messageId"] with
1290
-
| Some (`A ids) -> List.map (fun id ->
1291
-
match id with
1292
-
| `String s -> s
1293
-
| _ -> raise (Invalid_argument "messageId item is not a string")
1294
-
) ids
1295
-
| Some (`String s) -> [s] (* Handle single string case *)
1296
-
| None -> [] (* Handle missing case *)
1297
-
| _ -> raise (Invalid_argument "messageId has unexpected type")
1298
-
in
1299
-
1300
-
(* Parse optional fields *)
1301
-
let parse_email_addresses opt_json =
1302
-
match opt_json with
1303
-
| Some (`A items) ->
1304
-
Some (List.map (fun addr_json ->
1305
-
let name =
1306
-
match find_opt addr_json ["name"] with
1307
-
| Some (`String s) -> Some s
1308
-
| Some (`Null) -> None
1309
-
| None -> None
1310
-
| _ -> None
1311
-
in
1312
-
let email = get_string (find addr_json ["email"]) in
1313
-
let parameters =
1314
-
match find_opt addr_json ["parameters"] with
1315
-
| Some (`O items) -> List.map (fun (k, v) ->
1316
-
match v with
1317
-
| `String s -> (k, s)
1318
-
| _ -> (k, "")
1319
-
) items
1320
-
| _ -> []
1321
-
in
1322
-
{ Types.name; email; parameters }
1323
-
) items)
1324
-
| _ -> None
1325
-
in
1326
-
1327
-
(* Handle optional string arrays with null handling *)
1328
-
let parse_string_array_opt field_name =
1329
-
match find_opt json [field_name] with
1330
-
| Some (`A ids) ->
1331
-
Some (List.filter_map (function
1332
-
| `String s -> Some s
1333
-
| _ -> None
1334
-
) ids)
1335
-
| Some (`Null) -> None
1336
-
| None -> None
1337
-
| _ -> None
1338
-
in
1339
-
1340
-
let in_reply_to = parse_string_array_opt "inReplyTo" in
1341
-
let references = parse_string_array_opt "references" in
1342
-
1343
-
let sender = parse_email_addresses (find_opt json ["sender"]) in
1344
-
let from = parse_email_addresses (find_opt json ["from"]) in
1345
-
let to_ = parse_email_addresses (find_opt json ["to"]) in
1346
-
let cc = parse_email_addresses (find_opt json ["cc"]) in
1347
-
let bcc = parse_email_addresses (find_opt json ["bcc"]) in
1348
-
let reply_to = parse_email_addresses (find_opt json ["replyTo"]) in
1349
-
1350
-
(* Handle optional string fields with null handling *)
1351
-
let parse_string_opt field_name =
1352
-
match find_opt json [field_name] with
1353
-
| Some (`String s) -> Some s
1354
-
| Some (`Null) -> None
1355
-
| None -> None
1356
-
| _ -> None
1357
-
in
1358
-
1359
-
let subject = parse_string_opt "subject" in
1360
-
let sent_at = parse_string_opt "sentAt" in
1361
-
1362
-
(* Handle optional boolean fields with null handling *)
1363
-
let parse_bool_opt field_name =
1364
-
match find_opt json [field_name] with
1365
-
| Some (`Bool b) -> Some b
1366
-
| Some (`Null) -> None
1367
-
| None -> None
1368
-
| _ -> None
1369
-
in
1370
-
1371
-
let has_attachment = parse_bool_opt "hasAttachment" in
1372
-
let preview = parse_string_opt "preview" in
1373
-
1374
-
(* TODO Body parts parsing would go here - omitting for brevity *)
1375
-
Ok ({
1376
-
Types.id;
1377
-
blob_id;
1378
-
thread_id;
1379
-
mailbox_ids;
1380
-
keywords;
1381
-
size;
1382
-
received_at;
1383
-
message_id;
1384
-
in_reply_to;
1385
-
references;
1386
-
sender;
1387
-
from;
1388
-
to_;
1389
-
cc;
1390
-
bcc;
1391
-
reply_to;
1392
-
subject;
1393
-
sent_at;
1394
-
has_attachment;
1395
-
preview;
1396
-
body_values = None;
1397
-
text_body = None;
1398
-
html_body = None;
1399
-
attachments = None;
1400
-
headers = None;
1401
-
})
1402
-
with
1403
-
| Not_found ->
1404
-
Error (Parse_error "Required field not found in email object")
1405
-
| Invalid_argument msg ->
1406
-
Error (Parse_error msg)
1407
-
| e ->
1408
-
Error (Parse_error (Printexc.to_string e))
1409
-
1410
-
(** Login to a JMAP server and establish a connection
1411
-
@param uri The URI of the JMAP server
1412
-
@param credentials Authentication credentials
1413
-
@return A connection object if successful
1414
-
1415
-
TODO:claude *)
1416
-
let login ~uri ~credentials =
1417
-
let* session_result = get_session (Uri.of_string uri)
1418
-
~username:credentials.username
1419
-
~authentication_token:credentials.password
1420
-
() in
1421
-
match session_result with
1422
-
| Ok session ->
1423
-
let api_uri = Uri.of_string session.api_url in
1424
-
let config = {
1425
-
api_uri;
1426
-
username = credentials.username;
1427
-
authentication_token = credentials.password;
1428
-
} in
1429
-
Lwt.return (Ok { session; config })
1430
-
| Error e -> Lwt.return (Error e)
1431
-
1432
-
(** Login to a JMAP server using an API token
1433
-
@param uri The URI of the JMAP server
1434
-
@param api_token The API token for authentication
1435
-
@return A connection object if successful
1436
-
1437
-
TODO:claude *)
1438
-
let login_with_token ~uri ~api_token =
1439
-
let* session_result = get_session (Uri.of_string uri)
1440
-
~api_token
1441
-
() in
1442
-
match session_result with
1443
-
| Ok session ->
1444
-
let api_uri = Uri.of_string session.api_url in
1445
-
let config = {
1446
-
api_uri;
1447
-
username = ""; (* Empty username indicates we're using token auth *)
1448
-
authentication_token = api_token;
1449
-
} in
1450
-
Lwt.return (Ok { session; config })
1451
-
| Error e -> Lwt.return (Error e)
1452
-
1453
-
(** Get all mailboxes for an account
1454
-
@param conn The JMAP connection
1455
-
@param account_id The account ID to get mailboxes for
1456
-
@return A list of mailboxes if successful
1457
-
1458
-
TODO:claude *)
1459
-
let get_mailboxes conn ~account_id =
1460
-
let request = {
1461
-
using = [
1462
-
Jmap.Capability.to_string Jmap.Capability.Core;
1463
-
Capability.to_string Capability.Mail
1464
-
];
1465
-
method_calls = [
1466
-
{
1467
-
name = "Mailbox/get";
1468
-
arguments = `O [
1469
-
("accountId", `String account_id);
1470
-
];
1471
-
method_call_id = "m1";
1472
-
}
1473
-
];
1474
-
created_ids = None;
1475
-
} in
1476
-
1477
-
let* response_result = make_request conn.config request in
1478
-
match response_result with
1479
-
| Ok response ->
1480
-
let result =
1481
-
try
1482
-
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1483
-
inv.name = "Mailbox/get") response.method_responses in
1484
-
let args = method_response.arguments in
1485
-
match Ezjsonm.find_opt args ["list"] with
1486
-
| Some (`A mailbox_list) ->
1487
-
let parse_results = List.map mailbox_of_json mailbox_list in
1488
-
let (successes, failures) = List.partition Result.is_ok parse_results in
1489
-
if List.length failures > 0 then
1490
-
Error (Parse_error "Failed to parse some mailboxes")
1491
-
else
1492
-
Ok (List.map Result.get_ok successes)
1493
-
| _ -> Error (Parse_error "Mailbox list not found in response")
1494
-
with
1495
-
| Not_found -> Error (Parse_error "Mailbox/get method response not found")
1496
-
| e -> Error (Parse_error (Printexc.to_string e))
1497
-
in
1498
-
Lwt.return result
1499
-
| Error e -> Lwt.return (Error e)
1500
-
1501
-
(** Get a specific mailbox by ID
1502
-
@param conn The JMAP connection
1503
-
@param account_id The account ID
1504
-
@param mailbox_id The mailbox ID to retrieve
1505
-
@return The mailbox if found
1506
-
1507
-
TODO:claude *)
1508
-
let get_mailbox conn ~account_id ~mailbox_id =
1509
-
let request = {
1510
-
using = [
1511
-
Jmap.Capability.to_string Jmap.Capability.Core;
1512
-
Capability.to_string Capability.Mail
1513
-
];
1514
-
method_calls = [
1515
-
{
1516
-
name = "Mailbox/get";
1517
-
arguments = `O [
1518
-
("accountId", `String account_id);
1519
-
("ids", `A [`String mailbox_id]);
1520
-
];
1521
-
method_call_id = "m1";
1522
-
}
1523
-
];
1524
-
created_ids = None;
1525
-
} in
1526
-
1527
-
let* response_result = make_request conn.config request in
1528
-
match response_result with
1529
-
| Ok response ->
1530
-
let result =
1531
-
try
1532
-
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1533
-
inv.name = "Mailbox/get") response.method_responses in
1534
-
let args = method_response.arguments in
1535
-
match Ezjsonm.find_opt args ["list"] with
1536
-
| Some (`A [mailbox]) -> mailbox_of_json mailbox
1537
-
| Some (`A []) -> Error (Parse_error ("Mailbox not found: " ^ mailbox_id))
1538
-
| _ -> Error (Parse_error "Expected single mailbox in response")
1539
-
with
1540
-
| Not_found -> Error (Parse_error "Mailbox/get method response not found")
1541
-
| e -> Error (Parse_error (Printexc.to_string e))
1542
-
in
1543
-
Lwt.return result
1544
-
| Error e -> Lwt.return (Error e)
1545
-
1546
-
(** Get messages in a mailbox
1547
-
@param conn The JMAP connection
1548
-
@param account_id The account ID
1549
-
@param mailbox_id The mailbox ID to get messages from
1550
-
@param limit Optional limit on number of messages to return
1551
-
@return The list of email messages if successful
1552
-
1553
-
TODO:claude *)
1554
-
let get_messages_in_mailbox conn ~account_id ~mailbox_id ?limit () =
1555
-
(* First query the emails in the mailbox *)
1556
-
let query_request = {
1557
-
using = [
1558
-
Jmap.Capability.to_string Jmap.Capability.Core;
1559
-
Capability.to_string Capability.Mail
1560
-
];
1561
-
method_calls = [
1562
-
{
1563
-
name = "Email/query";
1564
-
arguments = `O ([
1565
-
("accountId", `String account_id);
1566
-
("filter", `O [("inMailbox", `String mailbox_id)]);
1567
-
("sort", `A [`O [("property", `String "receivedAt"); ("isAscending", `Bool false)]]);
1568
-
] @ (match limit with
1569
-
| Some l -> [("limit", `Float (float_of_int l))]
1570
-
| None -> []
1571
-
));
1572
-
method_call_id = "q1";
1573
-
}
1574
-
];
1575
-
created_ids = None;
1576
-
} in
1577
-
1578
-
let* query_result = make_request conn.config query_request in
1579
-
match query_result with
1580
-
| Ok query_response ->
1581
-
(try
1582
-
let query_method = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1583
-
inv.name = "Email/query") query_response.method_responses in
1584
-
let args = query_method.arguments in
1585
-
match Ezjsonm.find_opt args ["ids"] with
1586
-
| Some (`A ids) ->
1587
-
let email_ids = List.map (function
1588
-
| `String id -> id
1589
-
| _ -> raise (Invalid_argument "Email ID is not a string")
1590
-
) ids in
1591
-
1592
-
(* If we have IDs, fetch the actual email objects *)
1593
-
if List.length email_ids > 0 then
1594
-
let get_request = {
1595
-
using = [
1596
-
Jmap.Capability.to_string Jmap.Capability.Core;
1597
-
Capability.to_string Capability.Mail
1598
-
];
1599
-
method_calls = [
1600
-
{
1601
-
name = "Email/get";
1602
-
arguments = `O [
1603
-
("accountId", `String account_id);
1604
-
("ids", `A (List.map (fun id -> `String id) email_ids));
1605
-
];
1606
-
method_call_id = "g1";
1607
-
}
1608
-
];
1609
-
created_ids = None;
1610
-
} in
1611
-
1612
-
let* get_result = make_request conn.config get_request in
1613
-
match get_result with
1614
-
| Ok get_response ->
1615
-
(try
1616
-
let get_method = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1617
-
inv.name = "Email/get") get_response.method_responses in
1618
-
let args = get_method.arguments in
1619
-
match Ezjsonm.find_opt args ["list"] with
1620
-
| Some (`A email_list) ->
1621
-
let parse_results = List.map email_of_json email_list in
1622
-
let (successes, failures) = List.partition Result.is_ok parse_results in
1623
-
if List.length failures > 0 then
1624
-
Lwt.return (Error (Parse_error "Failed to parse some emails"))
1625
-
else
1626
-
Lwt.return (Ok (List.map Result.get_ok successes))
1627
-
| _ -> Lwt.return (Error (Parse_error "Email list not found in response"))
1628
-
with
1629
-
| Not_found -> Lwt.return (Error (Parse_error "Email/get method response not found"))
1630
-
| e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
1631
-
| Error e -> Lwt.return (Error e)
1632
-
else
1633
-
(* No emails in mailbox *)
1634
-
Lwt.return (Ok [])
1635
-
1636
-
| _ -> Lwt.return (Error (Parse_error "Email IDs not found in query response"))
1637
-
with
1638
-
| Not_found -> Lwt.return (Error (Parse_error "Email/query method response not found"))
1639
-
| Invalid_argument msg -> Lwt.return (Error (Parse_error msg))
1640
-
| e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
1641
-
| Error e -> Lwt.return (Error e)
1642
-
1643
-
(** Get a single email message by ID
1644
-
@param conn The JMAP connection
1645
-
@param account_id The account ID
1646
-
@param email_id The email ID to retrieve
1647
-
@return The email message if found
1648
-
1649
-
TODO:claude *)
1650
-
let get_email conn ~account_id ~email_id =
1651
-
let request = {
1652
-
using = [
1653
-
Jmap.Capability.to_string Jmap.Capability.Core;
1654
-
Capability.to_string Capability.Mail
1655
-
];
1656
-
method_calls = [
1657
-
{
1658
-
name = "Email/get";
1659
-
arguments = `O [
1660
-
("accountId", `String account_id);
1661
-
("ids", `A [`String email_id]);
1662
-
];
1663
-
method_call_id = "m1";
1664
-
}
1665
-
];
1666
-
created_ids = None;
1667
-
} in
1668
-
1669
-
let* response_result = make_request conn.config request in
1670
-
match response_result with
1671
-
| Ok response ->
1672
-
let result =
1673
-
try
1674
-
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1675
-
inv.name = "Email/get") response.method_responses in
1676
-
let args = method_response.arguments in
1677
-
match Ezjsonm.find_opt args ["list"] with
1678
-
| Some (`A [email]) -> email_of_json email
1679
-
| Some (`A []) -> Error (Parse_error ("Email not found: " ^ email_id))
1680
-
| _ -> Error (Parse_error "Expected single email in response")
1681
-
with
1682
-
| Not_found -> Error (Parse_error "Email/get method response not found")
1683
-
| e -> Error (Parse_error (Printexc.to_string e))
1684
-
in
1685
-
Lwt.return result
1686
-
| Error e -> Lwt.return (Error e)
1687
-
1688
-
(** Helper functions for working with message flags and mailbox attributes *)
1689
-
1690
-
(** Check if an email has a specific message keyword
1691
-
@param email The email to check
1692
-
@param keyword The message keyword to look for
1693
-
@return true if the email has the keyword, false otherwise
1694
-
1695
-
TODO:claude *)
1696
-
let has_message_keyword (email:Types.email) keyword =
1697
-
let open Types in
1698
-
let keyword_string = string_of_message_keyword keyword in
1699
-
List.exists (function
1700
-
| (Custom s, true) when s = keyword_string -> true
1701
-
| _ -> false
1702
-
) email.keywords
1703
-
1704
-
(** Add a message keyword to an email
1705
-
@param conn The JMAP connection
1706
-
@param account_id The account ID
1707
-
@param email_id The email ID
1708
-
@param keyword The message keyword to add
1709
-
@return Success or error
1710
-
1711
-
TODO:claude *)
1712
-
let add_message_keyword conn ~account_id ~email_id ~keyword =
1713
-
let keyword_string = Types.string_of_message_keyword keyword in
1714
-
1715
-
let request = {
1716
-
using = [
1717
-
Jmap.Capability.to_string Jmap.Capability.Core;
1718
-
Capability.to_string Capability.Mail
1719
-
];
1720
-
method_calls = [
1721
-
{
1722
-
name = "Email/set";
1723
-
arguments = `O [
1724
-
("accountId", `String account_id);
1725
-
("update", `O [
1726
-
(email_id, `O [
1727
-
("keywords", `O [
1728
-
(keyword_string, `Bool true)
1729
-
])
1730
-
])
1731
-
]);
1732
-
];
1733
-
method_call_id = "m1";
1734
-
}
1735
-
];
1736
-
created_ids = None;
1737
-
} in
1738
-
1739
-
let* response_result = make_request conn.config request in
1740
-
match response_result with
1741
-
| Ok response ->
1742
-
let result =
1743
-
try
1744
-
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1745
-
inv.name = "Email/set") response.method_responses in
1746
-
let args = method_response.arguments in
1747
-
match Ezjsonm.find_opt args ["updated"] with
1748
-
| Some (`A _ids) -> Ok ()
1749
-
| _ ->
1750
-
match Ezjsonm.find_opt args ["notUpdated"] with
1751
-
| Some (`O _errors) ->
1752
-
Error (Parse_error ("Failed to update email: " ^ email_id))
1753
-
| _ -> Error (Parse_error "Unexpected response format")
1754
-
with
1755
-
| Not_found -> Error (Parse_error "Email/set method response not found")
1756
-
| e -> Error (Parse_error (Printexc.to_string e))
1757
-
in
1758
-
Lwt.return result
1759
-
| Error e -> Lwt.return (Error e)
1760
-
1761
-
(** Set a flag color for an email
1762
-
@param conn The JMAP connection
1763
-
@param account_id The account ID
1764
-
@param email_id The email ID
1765
-
@param color The flag color to set
1766
-
@return Success or error
1767
-
1768
-
TODO:claude *)
1769
-
let set_flag_color conn ~account_id ~email_id ~color =
1770
-
(* Get the bit pattern for the color *)
1771
-
let (bit0, bit1, bit2) = Types.bits_of_flag_color color in
1772
-
1773
-
(* Build the keywords update object *)
1774
-
let keywords = [
1775
-
("$flagged", `Bool true);
1776
-
("$MailFlagBit0", `Bool bit0);
1777
-
("$MailFlagBit1", `Bool bit1);
1778
-
("$MailFlagBit2", `Bool bit2);
1779
-
] in
1780
-
1781
-
let request = {
1782
-
using = [
1783
-
Jmap.Capability.to_string Jmap.Capability.Core;
1784
-
Capability.to_string Capability.Mail
1785
-
];
1786
-
method_calls = [
1787
-
{
1788
-
name = "Email/set";
1789
-
arguments = `O [
1790
-
("accountId", `String account_id);
1791
-
("update", `O [
1792
-
(email_id, `O [
1793
-
("keywords", `O keywords)
1794
-
])
1795
-
]);
1796
-
];
1797
-
method_call_id = "m1";
1798
-
}
1799
-
];
1800
-
created_ids = None;
1801
-
} in
1802
-
1803
-
let* response_result = make_request conn.config request in
1804
-
match response_result with
1805
-
| Ok response ->
1806
-
let result =
1807
-
try
1808
-
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1809
-
inv.name = "Email/set") response.method_responses in
1810
-
let args = method_response.arguments in
1811
-
match Ezjsonm.find_opt args ["updated"] with
1812
-
| Some (`A _ids) -> Ok ()
1813
-
| _ ->
1814
-
match Ezjsonm.find_opt args ["notUpdated"] with
1815
-
| Some (`O _errors) ->
1816
-
Error (Parse_error ("Failed to update email: " ^ email_id))
1817
-
| _ -> Error (Parse_error "Unexpected response format")
1818
-
with
1819
-
| Not_found -> Error (Parse_error "Email/set method response not found")
1820
-
| e -> Error (Parse_error (Printexc.to_string e))
1821
-
in
1822
-
Lwt.return result
1823
-
| Error e -> Lwt.return (Error e)
1824
-
1825
-
(** Convert an email's keywords to typed message_keyword list
1826
-
@param email The email to analyze
1827
-
@return List of message keywords
1828
-
1829
-
TODO:claude *)
1830
-
let get_message_keywords (email:Types.email) =
1831
-
let open Types in
1832
-
List.filter_map (function
1833
-
| (Custom s, true) -> Some (message_keyword_of_string s)
1834
-
| _ -> None
1835
-
) email.keywords
1836
-
1837
-
(** Get emails with a specific message keyword
1838
-
@param conn The JMAP connection
1839
-
@param account_id The account ID
1840
-
@param keyword The message keyword to search for
1841
-
@param limit Optional limit on number of emails to return
1842
-
@return List of emails with the keyword if successful
1843
-
1844
-
TODO:claude *)
1845
-
let get_emails_with_keyword conn ~account_id ~keyword ?limit () =
1846
-
let keyword_string = Types.string_of_message_keyword keyword in
1847
-
1848
-
(* Query for emails with the specified keyword *)
1849
-
let query_request = {
1850
-
using = [
1851
-
Jmap.Capability.to_string Jmap.Capability.Core;
1852
-
Capability.to_string Capability.Mail
1853
-
];
1854
-
method_calls = [
1855
-
{
1856
-
name = "Email/query";
1857
-
arguments = `O ([
1858
-
("accountId", `String account_id);
1859
-
("filter", `O [("hasKeyword", `String keyword_string)]);
1860
-
("sort", `A [`O [("property", `String "receivedAt"); ("isAscending", `Bool false)]]);
1861
-
] @ (match limit with
1862
-
| Some l -> [("limit", `Float (float_of_int l))]
1863
-
| None -> []
1864
-
));
1865
-
method_call_id = "q1";
1866
-
}
1867
-
];
1868
-
created_ids = None;
1869
-
} in
1870
-
1871
-
let* query_result = make_request conn.config query_request in
1872
-
match query_result with
1873
-
| Ok query_response ->
1874
-
(try
1875
-
let query_method = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1876
-
inv.name = "Email/query") query_response.method_responses in
1877
-
let args = query_method.arguments in
1878
-
match Ezjsonm.find_opt args ["ids"] with
1879
-
| Some (`A ids) ->
1880
-
let email_ids = List.map (function
1881
-
| `String id -> id
1882
-
| _ -> raise (Invalid_argument "Email ID is not a string")
1883
-
) ids in
1884
-
1885
-
(* If we have IDs, fetch the actual email objects *)
1886
-
if List.length email_ids > 0 then
1887
-
let get_request = {
1888
-
using = [
1889
-
Jmap.Capability.to_string Jmap.Capability.Core;
1890
-
Capability.to_string Capability.Mail
1891
-
];
1892
-
method_calls = [
1893
-
{
1894
-
name = "Email/get";
1895
-
arguments = `O [
1896
-
("accountId", `String account_id);
1897
-
("ids", `A (List.map (fun id -> `String id) email_ids));
1898
-
];
1899
-
method_call_id = "g1";
1900
-
}
1901
-
];
1902
-
created_ids = None;
1903
-
} in
1904
-
1905
-
let* get_result = make_request conn.config get_request in
1906
-
match get_result with
1907
-
| Ok get_response ->
1908
-
(try
1909
-
let get_method = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
1910
-
inv.name = "Email/get") get_response.method_responses in
1911
-
let args = get_method.arguments in
1912
-
match Ezjsonm.find_opt args ["list"] with
1913
-
| Some (`A email_list) ->
1914
-
let parse_results = List.map email_of_json email_list in
1915
-
let (successes, failures) = List.partition Result.is_ok parse_results in
1916
-
if List.length failures > 0 then
1917
-
Lwt.return (Error (Parse_error "Failed to parse some emails"))
1918
-
else
1919
-
Lwt.return (Ok (List.map Result.get_ok successes))
1920
-
| _ -> Lwt.return (Error (Parse_error "Email list not found in response"))
1921
-
with
1922
-
| Not_found -> Lwt.return (Error (Parse_error "Email/get method response not found"))
1923
-
| e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
1924
-
| Error e -> Lwt.return (Error e)
1925
-
else
1926
-
(* No emails with the keyword *)
1927
-
Lwt.return (Ok [])
1928
-
1929
-
| _ -> Lwt.return (Error (Parse_error "Email IDs not found in query response"))
1930
-
with
1931
-
| Not_found -> Lwt.return (Error (Parse_error "Email/query method response not found"))
1932
-
| Invalid_argument msg -> Lwt.return (Error (Parse_error msg))
1933
-
| e -> Lwt.return (Error (Parse_error (Printexc.to_string e))))
1934
-
| Error e -> Lwt.return (Error e)
1935
-
1936
-
(** {1 Email Submission} *)
1937
-
1938
-
(** Create a new email draft
1939
-
@param conn The JMAP connection
1940
-
@param account_id The account ID
1941
-
@param mailbox_id The mailbox ID to store the draft in (usually "drafts")
1942
-
@param from The sender's email address
1943
-
@param to_addresses List of recipient email addresses
1944
-
@param subject The email subject line
1945
-
@param text_body Plain text message body
1946
-
@param html_body Optional HTML message body
1947
-
@return The created email ID if successful
1948
-
1949
-
TODO:claude
1950
-
*)
1951
-
let create_email_draft conn ~account_id ~mailbox_id ~from ~to_addresses ~subject ~text_body ?html_body () =
1952
-
(* Create email addresses *)
1953
-
let from_addr = {
1954
-
Types.name = None;
1955
-
email = from;
1956
-
parameters = [];
1957
-
} in
1958
-
1959
-
let to_addrs = List.map (fun addr -> {
1960
-
Types.name = None;
1961
-
email = addr;
1962
-
parameters = [];
1963
-
}) to_addresses in
1964
-
1965
-
(* Create text body part *)
1966
-
let text_part = {
1967
-
Types.part_id = Some "part1";
1968
-
blob_id = None;
1969
-
size = None;
1970
-
headers = None;
1971
-
name = None;
1972
-
type_ = Some "text/plain";
1973
-
charset = Some "utf-8";
1974
-
disposition = None;
1975
-
cid = None;
1976
-
language = None;
1977
-
location = None;
1978
-
sub_parts = None;
1979
-
header_parameter_name = None;
1980
-
header_parameter_value = None;
1981
-
} in
1982
-
1983
-
(* Create HTML body part if provided *)
1984
-
let html_part_opt = match html_body with
1985
-
| Some _html -> Some {
1986
-
Types.part_id = Some "part2";
1987
-
blob_id = None;
1988
-
size = None;
1989
-
headers = None;
1990
-
name = None;
1991
-
type_ = Some "text/html";
1992
-
charset = Some "utf-8";
1993
-
disposition = None;
1994
-
cid = None;
1995
-
language = None;
1996
-
location = None;
1997
-
sub_parts = None;
1998
-
header_parameter_name = None;
1999
-
header_parameter_value = None;
2000
-
}
2001
-
| None -> None
2002
-
in
2003
-
2004
-
(* Create body values *)
2005
-
let body_values = [
2006
-
("part1", text_body)
2007
-
] @ (match html_body with
2008
-
| Some html -> [("part2", html)]
2009
-
| None -> []
2010
-
) in
2011
-
2012
-
(* Create email *)
2013
-
let html_body_list = match html_part_opt with
2014
-
| Some part -> Some [part]
2015
-
| None -> None
2016
-
in
2017
-
2018
-
let _email_creation = {
2019
-
Types.mailbox_ids = [(mailbox_id, true)];
2020
-
keywords = Some [(Draft, true)];
2021
-
received_at = None; (* Server will set this *)
2022
-
message_id = None; (* Server will generate this *)
2023
-
in_reply_to = None;
2024
-
references = None;
2025
-
sender = None;
2026
-
from = Some [from_addr];
2027
-
to_ = Some to_addrs;
2028
-
cc = None;
2029
-
bcc = None;
2030
-
reply_to = None;
2031
-
subject = Some subject;
2032
-
body_values = Some body_values;
2033
-
text_body = Some [text_part];
2034
-
html_body = html_body_list;
2035
-
attachments = None;
2036
-
headers = None;
2037
-
} in
2038
-
2039
-
let request = {
2040
-
using = [
2041
-
Jmap.Capability.to_string Jmap.Capability.Core;
2042
-
Capability.to_string Capability.Mail
2043
-
];
2044
-
method_calls = [
2045
-
{
2046
-
name = "Email/set";
2047
-
arguments = `O [
2048
-
("accountId", `String account_id);
2049
-
("create", `O [
2050
-
("draft1", `O (
2051
-
[
2052
-
("mailboxIds", `O [(mailbox_id, `Bool true)]);
2053
-
("keywords", `O [("$draft", `Bool true)]);
2054
-
("from", `A [`O [("name", `Null); ("email", `String from)]]);
2055
-
("to", `A (List.map (fun addr ->
2056
-
`O [("name", `Null); ("email", `String addr)]
2057
-
) to_addresses));
2058
-
("subject", `String subject);
2059
-
("bodyStructure", `O [
2060
-
("type", `String "multipart/alternative");
2061
-
("subParts", `A [
2062
-
`O [
2063
-
("partId", `String "part1");
2064
-
("type", `String "text/plain")
2065
-
];
2066
-
`O [
2067
-
("partId", `String "part2");
2068
-
("type", `String "text/html")
2069
-
]
2070
-
])
2071
-
]);
2072
-
("bodyValues", `O ([
2073
-
("part1", `O [("value", `String text_body)])
2074
-
] @ (match html_body with
2075
-
| Some html -> [("part2", `O [("value", `String html)])]
2076
-
| None -> [("part2", `O [("value", `String ("<html><body>" ^ text_body ^ "</body></html>"))])]
2077
-
)))
2078
-
]
2079
-
))
2080
-
])
2081
-
];
2082
-
method_call_id = "m1";
2083
-
}
2084
-
];
2085
-
created_ids = None;
2086
-
} in
2087
-
2088
-
let* response_result = make_request conn.config request in
2089
-
match response_result with
2090
-
| Ok response ->
2091
-
let result =
2092
-
try
2093
-
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
2094
-
inv.name = "Email/set") response.method_responses in
2095
-
let args = method_response.arguments in
2096
-
match Ezjsonm.find_opt args ["created"] with
2097
-
| Some (`O created) ->
2098
-
let draft_created = List.find_opt (fun (id, _) -> id = "draft1") created in
2099
-
(match draft_created with
2100
-
| Some (_, json) ->
2101
-
let id = Ezjsonm.get_string (Ezjsonm.find json ["id"]) in
2102
-
Ok id
2103
-
| None -> Error (Parse_error "Created email not found in response"))
2104
-
| _ ->
2105
-
match Ezjsonm.find_opt args ["notCreated"] with
2106
-
| Some (`O errors) ->
2107
-
let error_msg = match List.find_opt (fun (id, _) -> id = "draft1") errors with
2108
-
| Some (_, err) ->
2109
-
let type_ = Ezjsonm.get_string (Ezjsonm.find err ["type"]) in
2110
-
let description =
2111
-
match Ezjsonm.find_opt err ["description"] with
2112
-
| Some (`String desc) -> desc
2113
-
| _ -> "Unknown error"
2114
-
in
2115
-
"Error type: " ^ type_ ^ ", Description: " ^ description
2116
-
| None -> "Unknown error"
2117
-
in
2118
-
Error (Parse_error ("Failed to create email: " ^ error_msg))
2119
-
| _ -> Error (Parse_error "Unexpected response format")
2120
-
with
2121
-
| Not_found -> Error (Parse_error "Email/set method response not found")
2122
-
| e -> Error (Parse_error (Printexc.to_string e))
2123
-
in
2124
-
Lwt.return result
2125
-
| Error e -> Lwt.return (Error e)
2126
-
2127
-
(** Get all identities for an account
2128
-
@param conn The JMAP connection
2129
-
@param account_id The account ID
2130
-
@return A list of identities if successful
2131
-
2132
-
TODO:claude
2133
-
*)
2134
-
let get_identities conn ~account_id =
2135
-
let request = {
2136
-
using = [
2137
-
Jmap.Capability.to_string Jmap.Capability.Core;
2138
-
Capability.to_string Capability.Submission
2139
-
];
2140
-
method_calls = [
2141
-
{
2142
-
name = "Identity/get";
2143
-
arguments = `O [
2144
-
("accountId", `String account_id);
2145
-
];
2146
-
method_call_id = "m1";
2147
-
}
2148
-
];
2149
-
created_ids = None;
2150
-
} in
2151
-
2152
-
let* response_result = make_request conn.config request in
2153
-
match response_result with
2154
-
| Ok response ->
2155
-
let result =
2156
-
try
2157
-
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
2158
-
inv.name = "Identity/get") response.method_responses in
2159
-
let args = method_response.arguments in
2160
-
match Ezjsonm.find_opt args ["list"] with
2161
-
| Some (`A identities) ->
2162
-
let parse_identity json =
2163
-
try
2164
-
let open Ezjsonm in
2165
-
let id = get_string (find json ["id"]) in
2166
-
let name = get_string (find json ["name"]) in
2167
-
let email = get_string (find json ["email"]) in
2168
-
2169
-
let parse_email_addresses field =
2170
-
match find_opt json [field] with
2171
-
| Some (`A items) ->
2172
-
Some (List.map (fun addr_json ->
2173
-
let name =
2174
-
match find_opt addr_json ["name"] with
2175
-
| Some (`String s) -> Some s
2176
-
| Some (`Null) -> None
2177
-
| None -> None
2178
-
| _ -> None
2179
-
in
2180
-
let email = get_string (find addr_json ["email"]) in
2181
-
let parameters =
2182
-
match find_opt addr_json ["parameters"] with
2183
-
| Some (`O items) -> List.map (fun (k, v) ->
2184
-
match v with
2185
-
| `String s -> (k, s)
2186
-
| _ -> (k, "")
2187
-
) items
2188
-
| _ -> []
2189
-
in
2190
-
{ Types.name; email; parameters }
2191
-
) items)
2192
-
| _ -> None
2193
-
in
2194
-
2195
-
let reply_to = parse_email_addresses "replyTo" in
2196
-
let bcc = parse_email_addresses "bcc" in
2197
-
2198
-
let text_signature =
2199
-
match find_opt json ["textSignature"] with
2200
-
| Some (`String s) -> Some s
2201
-
| _ -> None
2202
-
in
2203
-
2204
-
let html_signature =
2205
-
match find_opt json ["htmlSignature"] with
2206
-
| Some (`String s) -> Some s
2207
-
| _ -> None
2208
-
in
2209
-
2210
-
let may_delete =
2211
-
match find_opt json ["mayDelete"] with
2212
-
| Some (`Bool b) -> b
2213
-
| _ -> false
2214
-
in
2215
-
2216
-
(* Create our own identity record for simplicity *)
2217
-
let r : Types.identity = {
2218
-
id = id;
2219
-
name = name;
2220
-
email = email;
2221
-
reply_to = reply_to;
2222
-
bcc = bcc;
2223
-
text_signature = text_signature;
2224
-
html_signature = html_signature;
2225
-
may_delete = may_delete
2226
-
} in Ok r
2227
-
with
2228
-
| Not_found -> Error (Parse_error "Required field not found in identity object")
2229
-
| Invalid_argument msg -> Error (Parse_error msg)
2230
-
| e -> Error (Parse_error (Printexc.to_string e))
2231
-
in
2232
-
2233
-
let results = List.map parse_identity identities in
2234
-
let (successes, failures) = List.partition Result.is_ok results in
2235
-
if List.length failures > 0 then
2236
-
Error (Parse_error "Failed to parse some identity objects")
2237
-
else
2238
-
Ok (List.map Result.get_ok successes)
2239
-
| _ -> Error (Parse_error "Identity list not found in response")
2240
-
with
2241
-
| Not_found -> Error (Parse_error "Identity/get method response not found")
2242
-
| e -> Error (Parse_error (Printexc.to_string e))
2243
-
in
2244
-
Lwt.return result
2245
-
| Error e -> Lwt.return (Error e)
2246
-
2247
-
(** Find a suitable identity by email address
2248
-
@param conn The JMAP connection
2249
-
@param account_id The account ID
2250
-
@param email The email address to match
2251
-
@return The identity if found, otherwise Error
2252
-
2253
-
TODO:claude
2254
-
*)
2255
-
let find_identity_by_email conn ~account_id ~email =
2256
-
let* identities_result = get_identities conn ~account_id in
2257
-
match identities_result with
2258
-
| Ok identities -> begin
2259
-
let matching_identity = List.find_opt (fun (identity:Types.identity) ->
2260
-
(* Exact match *)
2261
-
if String.lowercase_ascii identity.email = String.lowercase_ascii email then
2262
-
true
2263
-
else
2264
-
(* Wildcard match (e.g., *@example.com) *)
2265
-
let parts = String.split_on_char '@' identity.email in
2266
-
if List.length parts = 2 && List.hd parts = "*" then
2267
-
let domain = List.nth parts 1 in
2268
-
let email_parts = String.split_on_char '@' email in
2269
-
if List.length email_parts = 2 then
2270
-
List.nth email_parts 1 = domain
2271
-
else
2272
-
false
2273
-
else
2274
-
false
2275
-
) identities in
2276
-
2277
-
match matching_identity with
2278
-
| Some identity -> Lwt.return (Ok identity)
2279
-
| None -> Lwt.return (Error (Parse_error "No matching identity found"))
2280
-
end
2281
-
| Error e -> Lwt.return (Error e)
2282
-
2283
-
(** Submit an email for delivery
2284
-
@param conn The JMAP connection
2285
-
@param account_id The account ID
2286
-
@param identity_id The identity ID to send from
2287
-
@param email_id The email ID to submit
2288
-
@param envelope Optional custom envelope
2289
-
@return The submission ID if successful
2290
-
2291
-
TODO:claude
2292
-
*)
2293
-
let submit_email conn ~account_id ~identity_id ~email_id ?envelope () =
2294
-
let request = {
2295
-
using = [
2296
-
Jmap.Capability.to_string Jmap.Capability.Core;
2297
-
Capability.to_string Capability.Mail;
2298
-
Capability.to_string Capability.Submission
2299
-
];
2300
-
method_calls = [
2301
-
{
2302
-
name = "EmailSubmission/set";
2303
-
arguments = `O [
2304
-
("accountId", `String account_id);
2305
-
("create", `O [
2306
-
("submission1", `O (
2307
-
[
2308
-
("emailId", `String email_id);
2309
-
("identityId", `String identity_id);
2310
-
] @ (match envelope with
2311
-
| Some env -> [
2312
-
("envelope", `O [
2313
-
("mailFrom", `O [
2314
-
("email", `String env.Types.mail_from.email);
2315
-
("parameters", match env.Types.mail_from.parameters with
2316
-
| Some params -> `O (List.map (fun (k, v) -> (k, `String v)) params)
2317
-
| None -> `O []
2318
-
)
2319
-
]);
2320
-
("rcptTo", `A (List.map (fun (rcpt:Types.submission_address) ->
2321
-
`O [
2322
-
("email", `String rcpt.Types.email);
2323
-
("parameters", match rcpt.Types.parameters with
2324
-
| Some params -> `O (List.map (fun (k, v) -> (k, `String v)) params)
2325
-
| None -> `O []
2326
-
)
2327
-
]
2328
-
) env.Types.rcpt_to))
2329
-
])
2330
-
]
2331
-
| None -> []
2332
-
)
2333
-
))
2334
-
]);
2335
-
("onSuccessUpdateEmail", `O [
2336
-
(email_id, `O [
2337
-
("keywords", `O [
2338
-
("$draft", `Bool false);
2339
-
("$sent", `Bool true);
2340
-
])
2341
-
])
2342
-
]);
2343
-
];
2344
-
method_call_id = "m1";
2345
-
}
2346
-
];
2347
-
created_ids = None;
2348
-
} in
2349
-
2350
-
let* response_result = make_request conn.config request in
2351
-
match response_result with
2352
-
| Ok response ->
2353
-
let result =
2354
-
try
2355
-
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
2356
-
inv.name = "EmailSubmission/set") response.method_responses in
2357
-
let args = method_response.arguments in
2358
-
match Ezjsonm.find_opt args ["created"] with
2359
-
| Some (`O created) ->
2360
-
let submission_created = List.find_opt (fun (id, _) -> id = "submission1") created in
2361
-
(match submission_created with
2362
-
| Some (_, json) ->
2363
-
let id = Ezjsonm.get_string (Ezjsonm.find json ["id"]) in
2364
-
Ok id
2365
-
| None -> Error (Parse_error "Created submission not found in response"))
2366
-
| _ ->
2367
-
match Ezjsonm.find_opt args ["notCreated"] with
2368
-
| Some (`O errors) ->
2369
-
let error_msg = match List.find_opt (fun (id, _) -> id = "submission1") errors with
2370
-
| Some (_, err) ->
2371
-
let type_ = Ezjsonm.get_string (Ezjsonm.find err ["type"]) in
2372
-
let description =
2373
-
match Ezjsonm.find_opt err ["description"] with
2374
-
| Some (`String desc) -> desc
2375
-
| _ -> "Unknown error"
2376
-
in
2377
-
"Error type: " ^ type_ ^ ", Description: " ^ description
2378
-
| None -> "Unknown error"
2379
-
in
2380
-
Error (Parse_error ("Failed to submit email: " ^ error_msg))
2381
-
| _ -> Error (Parse_error "Unexpected response format")
2382
-
with
2383
-
| Not_found -> Error (Parse_error "EmailSubmission/set method response not found")
2384
-
| e -> Error (Parse_error (Printexc.to_string e))
2385
-
in
2386
-
Lwt.return result
2387
-
| Error e -> Lwt.return (Error e)
2388
-
2389
-
(** Create and submit an email in one operation
2390
-
@param conn The JMAP connection
2391
-
@param account_id The account ID
2392
-
@param from The sender's email address
2393
-
@param to_addresses List of recipient email addresses
2394
-
@param subject The email subject line
2395
-
@param text_body Plain text message body
2396
-
@param html_body Optional HTML message body
2397
-
@return The submission ID if successful
2398
-
2399
-
TODO:claude
2400
-
*)
2401
-
let create_and_submit_email conn ~account_id ~from ~to_addresses ~subject ~text_body ?html_body:_ () =
2402
-
(* First get accounts to find the draft mailbox and identity in a single request *)
2403
-
let* initial_result =
2404
-
let request = {
2405
-
using = [
2406
-
Jmap.Capability.to_string Jmap.Capability.Core;
2407
-
Capability.to_string Capability.Mail;
2408
-
Capability.to_string Capability.Submission
2409
-
];
2410
-
method_calls = [
2411
-
{
2412
-
name = "Mailbox/get";
2413
-
arguments = `O [
2414
-
("accountId", `String account_id);
2415
-
];
2416
-
method_call_id = "m1";
2417
-
};
2418
-
{
2419
-
name = "Identity/get";
2420
-
arguments = `O [
2421
-
("accountId", `String account_id)
2422
-
];
2423
-
method_call_id = "m2";
2424
-
}
2425
-
];
2426
-
created_ids = None;
2427
-
} in
2428
-
make_request conn.config request
2429
-
in
2430
-
2431
-
match initial_result with
2432
-
| Ok initial_response -> begin
2433
-
(* Find drafts mailbox ID *)
2434
-
let find_drafts_result =
2435
-
try
2436
-
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
2437
-
inv.name = "Mailbox/get") initial_response.method_responses in
2438
-
let args = method_response.arguments in
2439
-
match Ezjsonm.find_opt args ["list"] with
2440
-
| Some (`A mailboxes) -> begin
2441
-
let draft_mailbox = List.find_opt (fun mailbox ->
2442
-
match Ezjsonm.find_opt mailbox ["role"] with
2443
-
| Some (`String role) -> role = "drafts"
2444
-
| _ -> false
2445
-
) mailboxes in
2446
-
2447
-
match draft_mailbox with
2448
-
| Some mb -> Ok (Ezjsonm.get_string (Ezjsonm.find mb ["id"]))
2449
-
| None -> Error (Parse_error "No drafts mailbox found")
2450
-
end
2451
-
| _ -> Error (Parse_error "Mailbox list not found in response")
2452
-
with
2453
-
| Not_found -> Error (Parse_error "Mailbox/get method response not found")
2454
-
| e -> Error (Parse_error (Printexc.to_string e))
2455
-
in
2456
-
2457
-
(* Find matching identity for from address *)
2458
-
let find_identity_result =
2459
-
try
2460
-
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
2461
-
inv.name = "Identity/get") initial_response.method_responses in
2462
-
let args = method_response.arguments in
2463
-
match Ezjsonm.find_opt args ["list"] with
2464
-
| Some (`A identities) -> begin
2465
-
let matching_identity = List.find_opt (fun identity ->
2466
-
match Ezjsonm.find_opt identity ["email"] with
2467
-
| Some (`String email) ->
2468
-
let email_lc = String.lowercase_ascii email in
2469
-
let from_lc = String.lowercase_ascii from in
2470
-
email_lc = from_lc || (* Exact match *)
2471
-
(* Wildcard domain match *)
2472
-
(let parts = String.split_on_char '@' email_lc in
2473
-
if List.length parts = 2 && List.hd parts = "*" then
2474
-
let domain = List.nth parts 1 in
2475
-
let from_parts = String.split_on_char '@' from_lc in
2476
-
if List.length from_parts = 2 then
2477
-
List.nth from_parts 1 = domain
2478
-
else false
2479
-
else false)
2480
-
| _ -> false
2481
-
) identities in
2482
-
2483
-
match matching_identity with
2484
-
| Some id ->
2485
-
let identity_id = Ezjsonm.get_string (Ezjsonm.find id ["id"]) in
2486
-
Ok identity_id
2487
-
| None -> Error (Parse_error ("No matching identity found for " ^ from))
2488
-
end
2489
-
| _ -> Error (Parse_error "Identity list not found in response")
2490
-
with
2491
-
| Not_found -> Error (Parse_error "Identity/get method response not found")
2492
-
| e -> Error (Parse_error (Printexc.to_string e))
2493
-
in
2494
-
2495
-
(* If we have both required IDs, create and submit the email in one request *)
2496
-
match (find_drafts_result, find_identity_result) with
2497
-
| (Ok drafts_id, Ok identity_id) -> begin
2498
-
(* Now create and submit the email in a single request *)
2499
-
let request = {
2500
-
using = [
2501
-
Jmap.Capability.to_string Jmap.Capability.Core;
2502
-
Capability.to_string Capability.Mail;
2503
-
Capability.to_string Capability.Submission
2504
-
];
2505
-
method_calls = [
2506
-
{
2507
-
name = "Email/set";
2508
-
arguments = `O [
2509
-
("accountId", `String account_id);
2510
-
("create", `O [
2511
-
("draft", `O (
2512
-
[
2513
-
("mailboxIds", `O [(drafts_id, `Bool true)]);
2514
-
("keywords", `O [("$draft", `Bool true)]);
2515
-
("from", `A [`O [("email", `String from)]]);
2516
-
("to", `A (List.map (fun addr ->
2517
-
`O [("email", `String addr)]
2518
-
) to_addresses));
2519
-
("subject", `String subject);
2520
-
("textBody", `A [`O [
2521
-
("partId", `String "body");
2522
-
("type", `String "text/plain")
2523
-
]]);
2524
-
("bodyValues", `O [
2525
-
("body", `O [
2526
-
("charset", `String "utf-8");
2527
-
("value", `String text_body)
2528
-
])
2529
-
])
2530
-
]
2531
-
))
2532
-
]);
2533
-
];
2534
-
method_call_id = "0";
2535
-
};
2536
-
{
2537
-
name = "EmailSubmission/set";
2538
-
arguments = `O [
2539
-
("accountId", `String account_id);
2540
-
("create", `O [
2541
-
("sendIt", `O [
2542
-
("emailId", `String "#draft");
2543
-
("identityId", `String identity_id)
2544
-
])
2545
-
])
2546
-
];
2547
-
method_call_id = "1";
2548
-
}
2549
-
];
2550
-
created_ids = None;
2551
-
} in
2552
-
2553
-
let* submit_result = make_request conn.config request in
2554
-
match submit_result with
2555
-
| Ok submit_response -> begin
2556
-
try
2557
-
let submission_method = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
2558
-
inv.name = "EmailSubmission/set") submit_response.method_responses in
2559
-
let args = submission_method.arguments in
2560
-
2561
-
(* Check if email was created and submission was created *)
2562
-
match Ezjsonm.find_opt args ["created"] with
2563
-
| Some (`O created) -> begin
2564
-
(* Extract the submission ID *)
2565
-
let submission_created = List.find_opt (fun (id, _) -> id = "sendIt") created in
2566
-
match submission_created with
2567
-
| Some (_, json) ->
2568
-
let id = Ezjsonm.get_string (Ezjsonm.find json ["id"]) in
2569
-
Lwt.return (Ok id)
2570
-
| None -> begin
2571
-
(* Check if there was an error in creation *)
2572
-
match Ezjsonm.find_opt args ["notCreated"] with
2573
-
| Some (`O errors) ->
2574
-
let error_msg = match List.find_opt (fun (id, _) -> id = "sendIt") errors with
2575
-
| Some (_, err) ->
2576
-
let type_ = Ezjsonm.get_string (Ezjsonm.find err ["type"]) in
2577
-
let description =
2578
-
match Ezjsonm.find_opt err ["description"] with
2579
-
| Some (`String desc) -> desc
2580
-
| _ -> "Unknown error"
2581
-
in
2582
-
"Error type: " ^ type_ ^ ", Description: " ^ description
2583
-
| None -> "Unknown error"
2584
-
in
2585
-
Lwt.return (Error (Parse_error ("Failed to submit email: " ^ error_msg)))
2586
-
| Some _ -> Lwt.return (Error (Parse_error "Email submission not found in response"))
2587
-
| None -> Lwt.return (Error (Parse_error "Email submission not found in response"))
2588
-
end
2589
-
end
2590
-
| Some (`Null) -> Lwt.return (Error (Parse_error "No created submissions in response"))
2591
-
| Some _ -> Lwt.return (Error (Parse_error "Invalid response format for created submissions"))
2592
-
| None -> Lwt.return (Error (Parse_error "No created submissions in response"))
2593
-
with
2594
-
| Not_found -> Lwt.return (Error (Parse_error "EmailSubmission/set method response not found"))
2595
-
| e -> Lwt.return (Error (Parse_error (Printexc.to_string e)))
2596
-
end
2597
-
| Error e -> Lwt.return (Error e)
2598
-
end
2599
-
| (Error e, _) -> Lwt.return (Error e)
2600
-
| (_, Error e) -> Lwt.return (Error e)
2601
-
end
2602
-
| Error e -> Lwt.return (Error e)
2603
-
2604
-
(** Get status of an email submission
2605
-
@param conn The JMAP connection
2606
-
@param account_id The account ID
2607
-
@param submission_id The email submission ID
2608
-
@return The submission status if successful
2609
-
2610
-
TODO:claude
2611
-
*)
2612
-
let get_submission_status conn ~account_id ~submission_id =
2613
-
let request = {
2614
-
using = [
2615
-
Jmap.Capability.to_string Jmap.Capability.Core;
2616
-
Capability.to_string Capability.Submission
2617
-
];
2618
-
method_calls = [
2619
-
{
2620
-
name = "EmailSubmission/get";
2621
-
arguments = `O [
2622
-
("accountId", `String account_id);
2623
-
("ids", `A [`String submission_id]);
2624
-
];
2625
-
method_call_id = "m1";
2626
-
}
2627
-
];
2628
-
created_ids = None;
2629
-
} in
2630
-
2631
-
let* response_result = make_request conn.config request in
2632
-
match response_result with
2633
-
| Ok response ->
2634
-
let result =
2635
-
try
2636
-
let method_response = List.find (fun (inv : Ezjsonm.value Jmap.Types.invocation) ->
2637
-
inv.name = "EmailSubmission/get") response.method_responses in
2638
-
let args = method_response.arguments in
2639
-
match Ezjsonm.find_opt args ["list"] with
2640
-
| Some (`A [submission]) ->
2641
-
let parse_submission json =
2642
-
try
2643
-
let open Ezjsonm in
2644
-
let id = get_string (find json ["id"]) in
2645
-
let identity_id = get_string (find json ["identityId"]) in
2646
-
let email_id = get_string (find json ["emailId"]) in
2647
-
let thread_id = get_string (find json ["threadId"]) in
2648
-
2649
-
let envelope =
2650
-
match find_opt json ["envelope"] with
2651
-
| Some (`O env) -> begin
2652
-
let parse_address addr_json =
2653
-
let email = get_string (find addr_json ["email"]) in
2654
-
let parameters =
2655
-
match find_opt addr_json ["parameters"] with
2656
-
| Some (`O params) ->
2657
-
Some (List.map (fun (k, v) -> (k, get_string v)) params)
2658
-
| _ -> None
2659
-
in
2660
-
{ Types.email; parameters }
2661
-
in
2662
-
2663
-
let mail_from = parse_address (find (`O env) ["mailFrom"]) in
2664
-
let rcpt_to =
2665
-
match find (`O env) ["rcptTo"] with
2666
-
| `A rcpts -> List.map parse_address rcpts
2667
-
| _ -> []
2668
-
in
2669
-
2670
-
Some { Types.mail_from; rcpt_to }
2671
-
end
2672
-
| _ -> None
2673
-
in
2674
-
2675
-
let send_at =
2676
-
match find_opt json ["sendAt"] with
2677
-
| Some (`String date) -> Some date
2678
-
| _ -> None
2679
-
in
2680
-
2681
-
let undo_status =
2682
-
match find_opt json ["undoStatus"] with
2683
-
| Some (`String "pending") -> Some `pending
2684
-
| Some (`String "final") -> Some `final
2685
-
| Some (`String "canceled") -> Some `canceled
2686
-
| _ -> None
2687
-
in
2688
-
2689
-
let parse_delivery_status deliveries =
2690
-
match deliveries with
2691
-
| `O statuses ->
2692
-
Some (List.map (fun (email, status_json) ->
2693
-
let smtp_reply = get_string (find status_json ["smtpReply"]) in
2694
-
let delivered =
2695
-
match find_opt status_json ["delivered"] with
2696
-
| Some (`String d) -> Some d
2697
-
| _ -> None
2698
-
in
2699
-
(email, { Types.smtp_reply; delivered })
2700
-
) statuses)
2701
-
| _ -> None
2702
-
in
2703
-
2704
-
let delivery_status =
2705
-
match find_opt json ["deliveryStatus"] with
2706
-
| Some status -> parse_delivery_status status
2707
-
| _ -> None
2708
-
in
2709
-
2710
-
let dsn_blob_ids =
2711
-
match find_opt json ["dsnBlobIds"] with
2712
-
| Some (`O ids) -> Some (List.map (fun (email, id) -> (email, get_string id)) ids)
2713
-
| _ -> None
2714
-
in
2715
-
2716
-
let mdn_blob_ids =
2717
-
match find_opt json ["mdnBlobIds"] with
2718
-
| Some (`O ids) -> Some (List.map (fun (email, id) -> (email, get_string id)) ids)
2719
-
| _ -> None
2720
-
in
2721
-
2722
-
Ok {
2723
-
Types.id;
2724
-
identity_id;
2725
-
email_id;
2726
-
thread_id;
2727
-
envelope;
2728
-
send_at;
2729
-
undo_status;
2730
-
delivery_status;
2731
-
dsn_blob_ids;
2732
-
mdn_blob_ids;
2733
-
}
2734
-
with
2735
-
| Not_found -> Error (Parse_error "Required field not found in submission object")
2736
-
| Invalid_argument msg -> Error (Parse_error msg)
2737
-
| e -> Error (Parse_error (Printexc.to_string e))
2738
-
in
2739
-
2740
-
parse_submission submission
2741
-
| Some (`A []) -> Error (Parse_error ("Submission not found: " ^ submission_id))
2742
-
| _ -> Error (Parse_error "Expected single submission in response")
2743
-
with
2744
-
| Not_found -> Error (Parse_error "EmailSubmission/get method response not found")
2745
-
| e -> Error (Parse_error (Printexc.to_string e))
2746
-
in
2747
-
Lwt.return result
2748
-
| Error e -> Lwt.return (Error e)
2749
-
2750
-
(** {1 Email Address Utilities} *)
2751
-
2752
-
(** Custom implementation of substring matching *)
2753
-
let contains_substring str sub =
2754
-
try
2755
-
let _ = Str.search_forward (Str.regexp_string sub) str 0 in
2756
-
true
2757
-
with Not_found -> false
2758
-
2759
-
(** Checks if a pattern with wildcards matches a string
2760
-
@param pattern Pattern string with * and ? wildcards
2761
-
@param str String to match against
2762
-
Based on simple recursive wildcard matching algorithm
2763
-
*)
2764
-
let matches_wildcard pattern str =
2765
-
let pattern_len = String.length pattern in
2766
-
let str_len = String.length str in
2767
-
2768
-
(* Convert both to lowercase for case-insensitive matching *)
2769
-
let pattern = String.lowercase_ascii pattern in
2770
-
let str = String.lowercase_ascii str in
2771
-
2772
-
(* If there are no wildcards, do a simple substring check *)
2773
-
if not (String.contains pattern '*' || String.contains pattern '?') then
2774
-
contains_substring str pattern
2775
-
else
2776
-
(* Classic recursive matching algorithm *)
2777
-
let rec match_from p_pos s_pos =
2778
-
(* Pattern matched to the end *)
2779
-
if p_pos = pattern_len then
2780
-
s_pos = str_len
2781
-
(* Star matches zero or more chars *)
2782
-
else if pattern.[p_pos] = '*' then
2783
-
match_from (p_pos + 1) s_pos || (* Match empty string *)
2784
-
(s_pos < str_len && match_from p_pos (s_pos + 1)) (* Match one more char *)
2785
-
(* If both have more chars and they match or ? wildcard *)
2786
-
else if s_pos < str_len &&
2787
-
(pattern.[p_pos] = '?' || pattern.[p_pos] = str.[s_pos]) then
2788
-
match_from (p_pos + 1) (s_pos + 1)
2789
-
else
2790
-
false
2791
-
in
2792
-
2793
-
match_from 0 0
2794
-
2795
-
(** Check if an email address matches a filter string
2796
-
@param email The email address to check
2797
-
@param pattern The filter pattern to match against
2798
-
@return True if the email address matches the filter
2799
-
*)
2800
-
let email_address_matches email pattern =
2801
-
matches_wildcard pattern email
2802
-
2803
-
(** Check if an email matches a sender filter
2804
-
@param email The email object to check
2805
-
@param pattern The sender filter pattern
2806
-
@return True if any sender address matches the filter
2807
-
*)
2808
-
let email_matches_sender (email : Types.email) pattern =
2809
-
(* Helper to extract emails from address list *)
2810
-
let addresses_match addrs =
2811
-
List.exists (fun (addr : Types.email_address) ->
2812
-
email_address_matches addr.email pattern
2813
-
) addrs
2814
-
in
2815
-
2816
-
(* Check From addresses first *)
2817
-
let from_match =
2818
-
match email.Types.from with
2819
-
| Some addrs -> addresses_match addrs
2820
-
| None -> false
2821
-
in
2822
-
2823
-
(* If no match in From, check Sender field *)
2824
-
if from_match then true
2825
-
else
2826
-
match email.Types.sender with
2827
-
| Some addrs -> addresses_match addrs
2828
-
| None -> false
-1655
lib/jmap_mail.mli
-1655
lib/jmap_mail.mli
···
1
-
(** Implementation of the JMAP Mail extension, as defined in RFC8621
2
-
@see <https://datatracker.ietf.org/doc/html/rfc8621> RFC8621
3
-
4
-
This module implements the JMAP Mail specification, providing types and
5
-
functions for working with emails, mailboxes, threads, and other mail-related
6
-
objects in the JMAP protocol.
7
-
*)
8
-
9
-
(** Module for managing JMAP Mail-specific capability URIs as defined in RFC8621 Section 1.3
10
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-1.3> RFC8621 Section 1.3
11
-
*)
12
-
module Capability : sig
13
-
(** Mail capability URI as defined in RFC8621 Section 1.3
14
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-1.3>
15
-
*)
16
-
val mail_uri : string
17
-
18
-
(** Submission capability URI as defined in RFC8621 Section 1.3
19
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-1.3>
20
-
*)
21
-
val submission_uri : string
22
-
23
-
(** Vacation response capability URI as defined in RFC8621 Section 1.3
24
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-1.3>
25
-
*)
26
-
val vacation_response_uri : string
27
-
28
-
(** All mail extension capability types as defined in RFC8621 Section 1.3
29
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-1.3>
30
-
*)
31
-
type t =
32
-
| Mail (** Mail capability for emails and mailboxes *)
33
-
| Submission (** Submission capability for sending emails *)
34
-
| VacationResponse (** Vacation response capability for auto-replies *)
35
-
| Extension of string (** Custom extension capabilities *)
36
-
37
-
(** Convert capability to URI string
38
-
@param capability The capability to convert
39
-
@return The full URI string for the capability
40
-
*)
41
-
val to_string : t -> string
42
-
43
-
(** Parse a string to a capability
44
-
@param uri The capability URI string to parse
45
-
@return The parsed capability type
46
-
*)
47
-
val of_string : string -> t
48
-
49
-
(** Check if a capability is a standard mail capability
50
-
@param capability The capability to check
51
-
@return True if the capability is a standard JMAP Mail capability
52
-
*)
53
-
val is_standard : t -> bool
54
-
55
-
(** Check if a capability string is a standard mail capability
56
-
@param uri The capability URI string to check
57
-
@return True if the string represents a standard JMAP Mail capability
58
-
*)
59
-
val is_standard_string : string -> bool
60
-
61
-
(** Create a list of capability strings
62
-
@param capabilities List of capability types
63
-
@return List of capability URI strings
64
-
*)
65
-
val strings_of_capabilities : t list -> string list
66
-
end
67
-
68
-
(** Types for the JMAP Mail extension as defined in RFC8621
69
-
@see <https://datatracker.ietf.org/doc/html/rfc8621>
70
-
*)
71
-
module Types : sig
72
-
open Jmap.Types
73
-
74
-
(** {1 Mail capabilities}
75
-
Capability URIs for JMAP Mail extension as defined in RFC8621 Section 1.3
76
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-1.3>
77
-
*)
78
-
79
-
(** Capability URI for JMAP Mail as defined in RFC8621 Section 1.3
80
-
Identifies support for the Mail data model
81
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-1.3>
82
-
*)
83
-
val capability_mail : string
84
-
85
-
(** Capability URI for JMAP Submission as defined in RFC8621 Section 1.3
86
-
Identifies support for email submission
87
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-1.3>
88
-
*)
89
-
val capability_submission : string
90
-
91
-
(** Capability URI for JMAP Vacation Response as defined in RFC8621 Section 1.3
92
-
Identifies support for vacation auto-reply functionality
93
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-1.3>
94
-
*)
95
-
val capability_vacation_response : string
96
-
97
-
(** {1:mailbox Mailbox objects}
98
-
Mailbox types as defined in RFC8621 Section 2
99
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2>
100
-
*)
101
-
102
-
(** A role for a mailbox as defined in RFC8621 Section 2.
103
-
Standardized roles for special mailboxes like Inbox, Sent, etc.
104
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2>
105
-
*)
106
-
type mailbox_role =
107
-
| All (** All mail mailbox *)
108
-
| Archive (** Archived mail mailbox *)
109
-
| Drafts (** Draft messages mailbox *)
110
-
| Flagged (** Starred/flagged mail mailbox *)
111
-
| Important (** Important mail mailbox *)
112
-
| Inbox (** Primary inbox mailbox *)
113
-
| Junk (** Spam/Junk mail mailbox *)
114
-
| Sent (** Sent mail mailbox *)
115
-
| Trash (** Deleted/Trash mail mailbox *)
116
-
| Unknown of string (** Server-specific custom roles *)
117
-
118
-
(** A mailbox (folder) in a mail account as defined in RFC8621 Section 2.
119
-
Represents an email folder or label in the account.
120
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2>
121
-
*)
122
-
type mailbox = {
123
-
id : id; (** Server-assigned ID for the mailbox *)
124
-
name : string; (** User-visible name for the mailbox *)
125
-
parent_id : id option; (** ID of the parent mailbox, if any *)
126
-
role : mailbox_role option; (** The role of this mailbox, if it's a special mailbox *)
127
-
sort_order : unsigned_int; (** Position for mailbox in the UI *)
128
-
total_emails : unsigned_int; (** Total number of emails in the mailbox *)
129
-
unread_emails : unsigned_int; (** Number of unread emails in the mailbox *)
130
-
total_threads : unsigned_int; (** Total number of threads in the mailbox *)
131
-
unread_threads : unsigned_int; (** Number of threads with unread emails *)
132
-
is_subscribed : bool; (** Has the user subscribed to this mailbox *)
133
-
my_rights : mailbox_rights; (** Access rights for the user on this mailbox *)
134
-
}
135
-
136
-
(** Rights for a mailbox as defined in RFC8621 Section 2.
137
-
Determines the operations a user can perform on a mailbox.
138
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2>
139
-
*)
140
-
and mailbox_rights = {
141
-
may_read_items : bool; (** Can the user read messages in this mailbox *)
142
-
may_add_items : bool; (** Can the user add messages to this mailbox *)
143
-
may_remove_items : bool; (** Can the user remove messages from this mailbox *)
144
-
may_set_seen : bool; (** Can the user mark messages as read/unread *)
145
-
may_set_keywords : bool; (** Can the user set keywords/flags on messages *)
146
-
may_create_child : bool; (** Can the user create child mailboxes *)
147
-
may_rename : bool; (** Can the user rename this mailbox *)
148
-
may_delete : bool; (** Can the user delete this mailbox *)
149
-
may_submit : bool; (** Can the user submit messages in this mailbox for delivery *)
150
-
}
151
-
152
-
(** Filter condition for mailbox queries as defined in RFC8621 Section 2.3.
153
-
Used to filter mailboxes in queries.
154
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.3>
155
-
*)
156
-
type mailbox_filter_condition = {
157
-
parent_id : id option; (** Only include mailboxes with this parent *)
158
-
name : string option; (** Only include mailboxes with this name (case-insensitive substring match) *)
159
-
role : string option; (** Only include mailboxes with this role *)
160
-
has_any_role : bool option; (** If true, only include mailboxes with a role, if false those without *)
161
-
is_subscribed : bool option; (** If true, only include subscribed mailboxes, if false unsubscribed *)
162
-
}
163
-
164
-
(** Filter for mailbox queries as defined in RFC8621 Section 2.3.
165
-
Complex filter for Mailbox/query method.
166
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.3>
167
-
*)
168
-
type mailbox_query_filter = [
169
-
| `And of mailbox_query_filter list (** Logical AND of filters *)
170
-
| `Or of mailbox_query_filter list (** Logical OR of filters *)
171
-
| `Not of mailbox_query_filter (** Logical NOT of a filter *)
172
-
| `Condition of mailbox_filter_condition (** Simple condition filter *)
173
-
]
174
-
175
-
(** Mailbox/get request arguments as defined in RFC8621 Section 2.1.
176
-
Used to fetch mailboxes by ID.
177
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.1>
178
-
*)
179
-
type mailbox_get_arguments = {
180
-
account_id : id; (** The account to fetch mailboxes from *)
181
-
ids : id list option; (** The IDs of mailboxes to fetch, null means all *)
182
-
properties : string list option; (** Properties to return, null means all *)
183
-
}
184
-
185
-
(** Mailbox/get response as defined in RFC8621 Section 2.1.
186
-
Contains requested mailboxes.
187
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.1>
188
-
*)
189
-
type mailbox_get_response = {
190
-
account_id : id; (** The account from which mailboxes were fetched *)
191
-
state : string; (** A string representing the state on the server *)
192
-
list : mailbox list; (** The list of mailboxes requested *)
193
-
not_found : id list; (** IDs requested that could not be found *)
194
-
}
195
-
196
-
(** Mailbox/changes request arguments as defined in RFC8621 Section 2.2.
197
-
Used to get mailbox changes since a previous state.
198
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.2>
199
-
*)
200
-
type mailbox_changes_arguments = {
201
-
account_id : id; (** The account to get changes for *)
202
-
since_state : string; (** The previous state to compare to *)
203
-
max_changes : unsigned_int option; (** Maximum number of changes to return *)
204
-
}
205
-
206
-
(** Mailbox/changes response as defined in RFC8621 Section 2.2.
207
-
Reports mailboxes that have changed since a previous state.
208
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.2>
209
-
*)
210
-
type mailbox_changes_response = {
211
-
account_id : id; (** The account changes are for *)
212
-
old_state : string; (** The state provided in the request *)
213
-
new_state : string; (** The current state on the server *)
214
-
has_more_changes : bool; (** If true, more changes are available *)
215
-
created : id list; (** IDs of mailboxes created since old_state *)
216
-
updated : id list; (** IDs of mailboxes updated since old_state *)
217
-
destroyed : id list; (** IDs of mailboxes destroyed since old_state *)
218
-
}
219
-
220
-
(** Mailbox/query request arguments as defined in RFC8621 Section 2.3.
221
-
Used to query mailboxes based on filter criteria.
222
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.3>
223
-
*)
224
-
type mailbox_query_arguments = {
225
-
account_id : id; (** The account to query *)
226
-
filter : mailbox_query_filter option; (** Filter to match mailboxes against *)
227
-
sort : [ `name | `role | `sort_order ] list option; (** Sort criteria *)
228
-
limit : unsigned_int option; (** Maximum number of results to return *)
229
-
}
230
-
231
-
(** Mailbox/query response as defined in RFC8621 Section 2.3.
232
-
Contains IDs of mailboxes matching the query.
233
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.3>
234
-
*)
235
-
type mailbox_query_response = {
236
-
account_id : id; (** The account that was queried *)
237
-
query_state : string; (** State string for the query results *)
238
-
can_calculate_changes : bool; (** Whether queryChanges can be used with these results *)
239
-
position : unsigned_int; (** Zero-based index of the first result *)
240
-
ids : id list; (** IDs of mailboxes matching the query *)
241
-
total : unsigned_int option; (** Total number of matches if requested *)
242
-
}
243
-
244
-
(** Mailbox/queryChanges request arguments as defined in RFC8621 Section 2.4.
245
-
Used to get changes to mailbox query results.
246
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.4>
247
-
*)
248
-
type mailbox_query_changes_arguments = {
249
-
account_id : id; (** The account to query *)
250
-
filter : mailbox_query_filter option; (** Same filter as the original query *)
251
-
sort : [ `name | `role | `sort_order ] list option; (** Same sort as the original query *)
252
-
since_query_state : string; (** The query_state from the previous result *)
253
-
max_changes : unsigned_int option; (** Maximum number of changes to return *)
254
-
up_to_id : id option; (** ID of the last mailbox to check for changes *)
255
-
}
256
-
257
-
(** Mailbox/queryChanges response as defined in RFC8621 Section 2.4.
258
-
Reports changes to a mailbox query since the previous state.
259
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.4>
260
-
*)
261
-
type mailbox_query_changes_response = {
262
-
account_id : id; (** The account that was queried *)
263
-
old_query_state : string; (** The query_state from the request *)
264
-
new_query_state : string; (** The current query_state on the server *)
265
-
total : unsigned_int option; (** Updated total number of matches, if requested *)
266
-
removed : id list; (** IDs that were in the old results but not the new *)
267
-
added : mailbox_query_changes_added list; (** IDs that are in the new results but not the old *)
268
-
}
269
-
270
-
(** Added item in mailbox query changes as defined in RFC8621 Section 2.4.
271
-
Represents a mailbox added to query results.
272
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.4>
273
-
*)
274
-
and mailbox_query_changes_added = {
275
-
id : id; (** ID of the added mailbox *)
276
-
index : unsigned_int; (** Zero-based index of the added mailbox in the results *)
277
-
}
278
-
279
-
(** Mailbox/set request arguments as defined in RFC8621 Section 2.5.
280
-
Used to create, update, and destroy mailboxes.
281
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.5>
282
-
*)
283
-
type mailbox_set_arguments = {
284
-
account_id : id; (** The account to make changes in *)
285
-
if_in_state : string option; (** Only apply changes if in this state *)
286
-
create : (id * mailbox_creation) list option; (** Map of creation IDs to mailboxes to create *)
287
-
update : (id * mailbox_update) list option; (** Map of IDs to update properties *)
288
-
destroy : id list option; (** List of IDs to destroy *)
289
-
}
290
-
291
-
(** Properties for mailbox creation as defined in RFC8621 Section 2.5.
292
-
Used to create new mailboxes.
293
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.5>
294
-
*)
295
-
and mailbox_creation = {
296
-
name : string; (** Name for the new mailbox *)
297
-
parent_id : id option; (** ID of the parent mailbox, if any *)
298
-
role : string option; (** Role for the mailbox, if it's a special-purpose mailbox *)
299
-
sort_order : unsigned_int option; (** Sort order, defaults to 0 *)
300
-
is_subscribed : bool option; (** Whether the mailbox is subscribed, defaults to true *)
301
-
}
302
-
303
-
(** Properties for mailbox update as defined in RFC8621 Section 2.5.
304
-
Used to update existing mailboxes.
305
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.5>
306
-
*)
307
-
and mailbox_update = {
308
-
name : string option; (** New name for the mailbox *)
309
-
parent_id : id option; (** New parent ID for the mailbox *)
310
-
role : string option; (** New role for the mailbox *)
311
-
sort_order : unsigned_int option; (** New sort order for the mailbox *)
312
-
is_subscribed : bool option; (** New subscription status for the mailbox *)
313
-
}
314
-
315
-
(** Mailbox/set response as defined in RFC8621 Section 2.5.
316
-
Reports the results of mailbox changes.
317
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-2.5>
318
-
*)
319
-
type mailbox_set_response = {
320
-
account_id : id; (** The account that was modified *)
321
-
old_state : string option; (** The state before processing, if changed *)
322
-
new_state : string; (** The current state on the server *)
323
-
created : (id * mailbox) list option; (** Map of creation IDs to created mailboxes *)
324
-
updated : id list option; (** List of IDs that were successfully updated *)
325
-
destroyed : id list option; (** List of IDs that were successfully destroyed *)
326
-
not_created : (id * set_error) list option; (** Map of IDs to errors for failed creates *)
327
-
not_updated : (id * set_error) list option; (** Map of IDs to errors for failed updates *)
328
-
not_destroyed : (id * set_error) list option; (** Map of IDs to errors for failed destroys *)
329
-
}
330
-
331
-
(** {1:thread Thread objects}
332
-
Thread types as defined in RFC8621 Section 3
333
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-3>
334
-
*)
335
-
336
-
(** A thread in a mail account as defined in RFC8621 Section 3.
337
-
Represents a group of related email messages.
338
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-3>
339
-
*)
340
-
type thread = {
341
-
id : id; (** Server-assigned ID for the thread *)
342
-
email_ids : id list; (** IDs of emails in the thread *)
343
-
}
344
-
345
-
(** Thread/get request arguments as defined in RFC8621 Section 3.1.
346
-
Used to fetch threads by ID.
347
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-3.1>
348
-
*)
349
-
type thread_get_arguments = {
350
-
account_id : id; (** The account to fetch threads from *)
351
-
ids : id list option; (** The IDs of threads to fetch, null means all *)
352
-
properties : string list option; (** Properties to return, null means all *)
353
-
}
354
-
355
-
(** Thread/get response as defined in RFC8621 Section 3.1.
356
-
Contains requested threads.
357
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-3.1>
358
-
*)
359
-
type thread_get_response = {
360
-
account_id : id; (** The account from which threads were fetched *)
361
-
state : string; (** A string representing the state on the server *)
362
-
list : thread list; (** The list of threads requested *)
363
-
not_found : id list; (** IDs requested that could not be found *)
364
-
}
365
-
366
-
(** Thread/changes request arguments as defined in RFC8621 Section 3.2.
367
-
Used to get thread changes since a previous state.
368
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-3.2>
369
-
*)
370
-
type thread_changes_arguments = {
371
-
account_id : id; (** The account to get changes for *)
372
-
since_state : string; (** The previous state to compare to *)
373
-
max_changes : unsigned_int option; (** Maximum number of changes to return *)
374
-
}
375
-
376
-
(** Thread/changes response as defined in RFC8621 Section 3.2.
377
-
Reports threads that have changed since a previous state.
378
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-3.2>
379
-
*)
380
-
type thread_changes_response = {
381
-
account_id : id; (** The account changes are for *)
382
-
old_state : string; (** The state provided in the request *)
383
-
new_state : string; (** The current state on the server *)
384
-
has_more_changes : bool; (** If true, more changes are available *)
385
-
created : id list; (** IDs of threads created since old_state *)
386
-
updated : id list; (** IDs of threads updated since old_state *)
387
-
destroyed : id list; (** IDs of threads destroyed since old_state *)
388
-
}
389
-
390
-
(** {1:email Email objects}
391
-
Email types as defined in RFC8621 Section 4
392
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4>
393
-
*)
394
-
395
-
(** Addressing (mailbox) information as defined in RFC8621 Section 4.1.1.
396
-
Represents an email address with optional display name.
397
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.1.1>
398
-
*)
399
-
type email_address = {
400
-
name : string option; (** Display name of the mailbox (e.g., "John Doe") *)
401
-
email : string; (** The email address (e.g., "john@example.com") *)
402
-
parameters : (string * string) list; (** Additional parameters for the address *)
403
-
}
404
-
405
-
(** Message header field as defined in RFC8621 Section 4.1.2.
406
-
Represents an email header.
407
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.1.2>
408
-
*)
409
-
type header = {
410
-
name : string; (** Name of the header field (e.g., "Subject") *)
411
-
value : string; (** Value of the header field *)
412
-
}
413
-
414
-
(** Email keyword (flag) as defined in RFC8621 Section 4.3.
415
-
Represents a flag or tag on an email message.
416
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.3>
417
-
*)
418
-
type keyword =
419
-
| Flagged (** Message is flagged/starred *)
420
-
| Answered (** Message has been replied to *)
421
-
| Draft (** Message is a draft *)
422
-
| Forwarded (** Message has been forwarded *)
423
-
| Phishing (** Message has been reported as phishing *)
424
-
| Junk (** Message is spam/junk *)
425
-
| NotJunk (** Message is explicitly not spam *)
426
-
| Seen (** Message has been read *)
427
-
| Unread (** Message is unread (inverse of $seen) *)
428
-
| Custom of string (** Custom/non-standard keywords *)
429
-
430
-
(** Email message as defined in RFC8621 Section 4.
431
-
Represents an email message in a mail account.
432
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4>
433
-
*)
434
-
type email = {
435
-
id : id; (** Server-assigned ID for the message *)
436
-
blob_id : id; (** ID of the raw message content blob *)
437
-
thread_id : id; (** ID of the thread this message belongs to *)
438
-
mailbox_ids : (id * bool) list; (** Map of mailbox IDs to boolean (whether message belongs to mailbox) *)
439
-
keywords : (keyword * bool) list; (** Map of keywords to boolean (whether message has keyword) *)
440
-
size : unsigned_int; (** Size of the message in octets *)
441
-
received_at : utc_date; (** When the message was received by the server *)
442
-
message_id : string list; (** Message-ID header values *)
443
-
in_reply_to : string list option; (** In-Reply-To header values *)
444
-
references : string list option; (** References header values *)
445
-
sender : email_address list option; (** Sender header addresses *)
446
-
from : email_address list option; (** From header addresses *)
447
-
to_ : email_address list option; (** To header addresses *)
448
-
cc : email_address list option; (** Cc header addresses *)
449
-
bcc : email_address list option; (** Bcc header addresses *)
450
-
reply_to : email_address list option; (** Reply-To header addresses *)
451
-
subject : string option; (** Subject header value *)
452
-
sent_at : utc_date option; (** Date header value as a date-time *)
453
-
has_attachment : bool option; (** Does the message have any attachments *)
454
-
preview : string option; (** Preview of the message (first bit of text) *)
455
-
body_values : (string * string) list option; (** Map of part IDs to text content *)
456
-
text_body : email_body_part list option; (** Plain text message body parts *)
457
-
html_body : email_body_part list option; (** HTML message body parts *)
458
-
attachments : email_body_part list option; (** Attachment parts in the message *)
459
-
headers : header list option; (** All headers in the message *)
460
-
}
461
-
462
-
(** Email body part as defined in RFC8621 Section 4.1.4.
463
-
Represents a MIME part in an email message.
464
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.1.4>
465
-
*)
466
-
and email_body_part = {
467
-
part_id : string option; (** Server-assigned ID for the MIME part *)
468
-
blob_id : id option; (** ID of the raw content for this part *)
469
-
size : unsigned_int option; (** Size of the part in octets *)
470
-
headers : header list option; (** Headers for this MIME part *)
471
-
name : string option; (** Filename of this part, if any *)
472
-
type_ : string option; (** MIME type of the part *)
473
-
charset : string option; (** Character set of the part, if applicable *)
474
-
disposition : string option; (** Content-Disposition value *)
475
-
cid : string option; (** Content-ID value *)
476
-
language : string list option; (** Content-Language values *)
477
-
location : string option; (** Content-Location value *)
478
-
sub_parts : email_body_part list option; (** Child MIME parts for multipart types *)
479
-
header_parameter_name : string option; (** Header parameter name (for headers with parameters) *)
480
-
header_parameter_value : string option; (** Header parameter value (for headers with parameters) *)
481
-
}
482
-
483
-
(** Email query filter condition as defined in RFC8621 Section 4.4.
484
-
Specifies conditions for filtering emails in queries.
485
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.4>
486
-
*)
487
-
type email_filter_condition = {
488
-
in_mailbox : id option; (** Only include emails in this mailbox *)
489
-
in_mailbox_other_than : id list option; (** Only include emails not in these mailboxes *)
490
-
min_size : unsigned_int option; (** Only include emails of at least this size in octets *)
491
-
max_size : unsigned_int option; (** Only include emails of at most this size in octets *)
492
-
before : utc_date option; (** Only include emails received before this date-time *)
493
-
after : utc_date option; (** Only include emails received after this date-time *)
494
-
header : (string * string) option; (** Only include emails with header matching value (name, value) *)
495
-
from : string option; (** Only include emails with From containing this text *)
496
-
to_ : string option; (** Only include emails with To containing this text *)
497
-
cc : string option; (** Only include emails with CC containing this text *)
498
-
bcc : string option; (** Only include emails with BCC containing this text *)
499
-
subject : string option; (** Only include emails with Subject containing this text *)
500
-
body : string option; (** Only include emails with body containing this text *)
501
-
has_keyword : string option; (** Only include emails with this keyword *)
502
-
not_keyword : string option; (** Only include emails without this keyword *)
503
-
has_attachment : bool option; (** If true, only include emails with attachments *)
504
-
text : string option; (** Only include emails with this text in headers or body *)
505
-
}
506
-
507
-
(** Filter for email queries as defined in RFC8621 Section 4.4.
508
-
Complex filter for Email/query method.
509
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.4>
510
-
*)
511
-
type email_query_filter = [
512
-
| `And of email_query_filter list (** Logical AND of filters *)
513
-
| `Or of email_query_filter list (** Logical OR of filters *)
514
-
| `Not of email_query_filter (** Logical NOT of a filter *)
515
-
| `Condition of email_filter_condition (** Simple condition filter *)
516
-
]
517
-
518
-
(** Email/get request arguments as defined in RFC8621 Section 4.5.
519
-
Used to fetch emails by ID.
520
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.5>
521
-
*)
522
-
type email_get_arguments = {
523
-
account_id : id; (** The account to fetch emails from *)
524
-
ids : id list option; (** The IDs of emails to fetch, null means all *)
525
-
properties : string list option; (** Properties to return, null means all *)
526
-
body_properties : string list option; (** Properties to return on body parts *)
527
-
fetch_text_body_values : bool option; (** Whether to fetch text body content *)
528
-
fetch_html_body_values : bool option; (** Whether to fetch HTML body content *)
529
-
fetch_all_body_values : bool option; (** Whether to fetch all body content *)
530
-
max_body_value_bytes : unsigned_int option; (** Maximum size of body values to return *)
531
-
}
532
-
533
-
(** Email/get response as defined in RFC8621 Section 4.5.
534
-
Contains requested emails.
535
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.5>
536
-
*)
537
-
type email_get_response = {
538
-
account_id : id; (** The account from which emails were fetched *)
539
-
state : string; (** A string representing the state on the server *)
540
-
list : email list; (** The list of emails requested *)
541
-
not_found : id list; (** IDs requested that could not be found *)
542
-
}
543
-
544
-
(** Email/changes request arguments as defined in RFC8621 Section 4.6.
545
-
Used to get email changes since a previous state.
546
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.6>
547
-
*)
548
-
type email_changes_arguments = {
549
-
account_id : id; (** The account to get changes for *)
550
-
since_state : string; (** The previous state to compare to *)
551
-
max_changes : unsigned_int option; (** Maximum number of changes to return *)
552
-
}
553
-
554
-
(** Email/changes response as defined in RFC8621 Section 4.6.
555
-
Reports emails that have changed since a previous state.
556
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.6>
557
-
*)
558
-
type email_changes_response = {
559
-
account_id : id; (** The account changes are for *)
560
-
old_state : string; (** The state provided in the request *)
561
-
new_state : string; (** The current state on the server *)
562
-
has_more_changes : bool; (** If true, more changes are available *)
563
-
created : id list; (** IDs of emails created since old_state *)
564
-
updated : id list; (** IDs of emails updated since old_state *)
565
-
destroyed : id list; (** IDs of emails destroyed since old_state *)
566
-
}
567
-
568
-
(** Email/query request arguments as defined in RFC8621 Section 4.4.
569
-
Used to query emails based on filter criteria.
570
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.4>
571
-
*)
572
-
type email_query_arguments = {
573
-
account_id : id; (** The account to query *)
574
-
filter : email_query_filter option; (** Filter to match emails against *)
575
-
sort : comparator list option; (** Sort criteria *)
576
-
collapse_threads : bool option; (** Whether to collapse threads in the results *)
577
-
position : unsigned_int option; (** Zero-based index of first result to return *)
578
-
anchor : id option; (** ID of email to use as reference point *)
579
-
anchor_offset : int_t option; (** Offset from anchor to start returning results *)
580
-
limit : unsigned_int option; (** Maximum number of results to return *)
581
-
calculate_total : bool option; (** Whether to calculate the total number of matching emails *)
582
-
}
583
-
584
-
(** Email/query response as defined in RFC8621 Section 4.4.
585
-
Contains IDs of emails matching the query.
586
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.4>
587
-
*)
588
-
type email_query_response = {
589
-
account_id : id; (** The account that was queried *)
590
-
query_state : string; (** State string for the query results *)
591
-
can_calculate_changes : bool; (** Whether queryChanges can be used with these results *)
592
-
position : unsigned_int; (** Zero-based index of the first result *)
593
-
ids : id list; (** IDs of emails matching the query *)
594
-
total : unsigned_int option; (** Total number of matches if requested *)
595
-
thread_ids : id list option; (** IDs of threads if collapse_threads was true *)
596
-
}
597
-
598
-
(** Email/queryChanges request arguments as defined in RFC8621 Section 4.7.
599
-
Used to get changes to email query results.
600
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.7>
601
-
*)
602
-
type email_query_changes_arguments = {
603
-
account_id : id; (** The account to query *)
604
-
filter : email_query_filter option; (** Same filter as the original query *)
605
-
sort : comparator list option; (** Same sort as the original query *)
606
-
collapse_threads : bool option; (** Same collapse_threads as the original query *)
607
-
since_query_state : string; (** The query_state from the previous result *)
608
-
max_changes : unsigned_int option; (** Maximum number of changes to return *)
609
-
up_to_id : id option; (** ID of the last email to check for changes *)
610
-
}
611
-
612
-
(** Email/queryChanges response as defined in RFC8621 Section 4.7.
613
-
Reports changes to an email query since the previous state.
614
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.7>
615
-
*)
616
-
type email_query_changes_response = {
617
-
account_id : id; (** The account that was queried *)
618
-
old_query_state : string; (** The query_state from the request *)
619
-
new_query_state : string; (** The current query_state on the server *)
620
-
total : unsigned_int option; (** Updated total number of matches, if requested *)
621
-
removed : id list; (** IDs that were in the old results but not the new *)
622
-
added : email_query_changes_added list; (** IDs that are in the new results but not the old *)
623
-
}
624
-
625
-
(** Added item in email query changes as defined in RFC8621 Section 4.7.
626
-
Represents an email added to query results.
627
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.7>
628
-
*)
629
-
and email_query_changes_added = {
630
-
id : id; (** ID of the added email *)
631
-
index : unsigned_int; (** Zero-based index of the added email in the results *)
632
-
}
633
-
634
-
(** Email/set request arguments as defined in RFC8621 Section 4.8.
635
-
Used to create, update, and destroy emails.
636
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.8>
637
-
*)
638
-
type email_set_arguments = {
639
-
account_id : id; (** The account to make changes in *)
640
-
if_in_state : string option; (** Only apply changes if in this state *)
641
-
create : (id * email_creation) list option; (** Map of creation IDs to emails to create *)
642
-
update : (id * email_update) list option; (** Map of IDs to update properties *)
643
-
destroy : id list option; (** List of IDs to destroy *)
644
-
}
645
-
646
-
(** Properties for email creation as defined in RFC8621 Section 4.8.
647
-
Used to create new emails.
648
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.8>
649
-
*)
650
-
and email_creation = {
651
-
mailbox_ids : (id * bool) list; (** Map of mailbox IDs to boolean (whether message belongs to mailbox) *)
652
-
keywords : (keyword * bool) list option; (** Map of keywords to boolean (whether message has keyword) *)
653
-
received_at : utc_date option; (** When the message was received by the server *)
654
-
message_id : string list option; (** Message-ID header values *)
655
-
in_reply_to : string list option; (** In-Reply-To header values *)
656
-
references : string list option; (** References header values *)
657
-
sender : email_address list option; (** Sender header addresses *)
658
-
from : email_address list option; (** From header addresses *)
659
-
to_ : email_address list option; (** To header addresses *)
660
-
cc : email_address list option; (** Cc header addresses *)
661
-
bcc : email_address list option; (** Bcc header addresses *)
662
-
reply_to : email_address list option; (** Reply-To header addresses *)
663
-
subject : string option; (** Subject header value *)
664
-
body_values : (string * string) list option; (** Map of part IDs to text content *)
665
-
text_body : email_body_part list option; (** Plain text message body parts *)
666
-
html_body : email_body_part list option; (** HTML message body parts *)
667
-
attachments : email_body_part list option; (** Attachment parts in the message *)
668
-
headers : header list option; (** All headers in the message *)
669
-
}
670
-
671
-
(** Properties for email update as defined in RFC8621 Section 4.8.
672
-
Used to update existing emails.
673
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.8>
674
-
*)
675
-
and email_update = {
676
-
keywords : (keyword * bool) list option; (** New keywords to set on the email *)
677
-
mailbox_ids : (id * bool) list option; (** New mailboxes to set for the email *)
678
-
}
679
-
680
-
(** Email/set response as defined in RFC8621 Section 4.8.
681
-
Reports the results of email changes.
682
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.8>
683
-
*)
684
-
type email_set_response = {
685
-
account_id : id; (** The account that was modified *)
686
-
old_state : string option; (** The state before processing, if changed *)
687
-
new_state : string; (** The current state on the server *)
688
-
created : (id * email) list option; (** Map of creation IDs to created emails *)
689
-
updated : id list option; (** List of IDs that were successfully updated *)
690
-
destroyed : id list option; (** List of IDs that were successfully destroyed *)
691
-
not_created : (id * set_error) list option; (** Map of IDs to errors for failed creates *)
692
-
not_updated : (id * set_error) list option; (** Map of IDs to errors for failed updates *)
693
-
not_destroyed : (id * set_error) list option; (** Map of IDs to errors for failed destroys *)
694
-
}
695
-
696
-
(** Email/copy request arguments as defined in RFC8621 Section 4.9.
697
-
Used to copy emails between accounts.
698
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.9>
699
-
*)
700
-
type email_copy_arguments = {
701
-
from_account_id : id; (** The account to copy emails from *)
702
-
account_id : id; (** The account to copy emails to *)
703
-
create : (id * email_creation) list; (** Map of creation IDs to email creation properties *)
704
-
on_success_destroy_original : bool option; (** Whether to destroy originals after copying *)
705
-
}
706
-
707
-
(** Email/copy response as defined in RFC8621 Section 4.9.
708
-
Reports the results of copying emails.
709
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.9>
710
-
*)
711
-
type email_copy_response = {
712
-
from_account_id : id; (** The account emails were copied from *)
713
-
account_id : id; (** The account emails were copied to *)
714
-
created : (id * email) list option; (** Map of creation IDs to created emails *)
715
-
not_created : (id * set_error) list option; (** Map of IDs to errors for failed copies *)
716
-
}
717
-
718
-
(** Email/import request arguments as defined in RFC8621 Section 4.10.
719
-
Used to import raw emails from blobs.
720
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.10>
721
-
*)
722
-
type email_import_arguments = {
723
-
account_id : id; (** The account to import emails into *)
724
-
emails : (id * email_import) list; (** Map of creation IDs to import properties *)
725
-
}
726
-
727
-
(** Properties for email import as defined in RFC8621 Section 4.10.
728
-
Used to import raw emails from blobs.
729
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.10>
730
-
*)
731
-
and email_import = {
732
-
blob_id : id; (** ID of the blob containing the raw message *)
733
-
mailbox_ids : (id * bool) list; (** Map of mailbox IDs to boolean (whether message belongs to mailbox) *)
734
-
keywords : (keyword * bool) list option; (** Map of keywords to boolean (whether message has keyword) *)
735
-
received_at : utc_date option; (** When the message was received, defaults to now *)
736
-
}
737
-
738
-
(** Email/import response as defined in RFC8621 Section 4.10.
739
-
Reports the results of importing emails.
740
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.10>
741
-
*)
742
-
type email_import_response = {
743
-
account_id : id; (** The account emails were imported into *)
744
-
created : (id * email) list option; (** Map of creation IDs to created emails *)
745
-
not_created : (id * set_error) list option; (** Map of IDs to errors for failed imports *)
746
-
}
747
-
748
-
(** {1:search_snippet Search snippets}
749
-
Search snippet types as defined in RFC8621 Section 4.11
750
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.11>
751
-
*)
752
-
753
-
(** SearchSnippet/get request arguments as defined in RFC8621 Section 4.11.
754
-
Used to get highlighted snippets from emails matching a search.
755
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.11>
756
-
*)
757
-
type search_snippet_get_arguments = {
758
-
account_id : id; (** The account to search in *)
759
-
email_ids : id list; (** The IDs of emails to get snippets for *)
760
-
filter : email_filter_condition; (** Filter containing the text to find and highlight *)
761
-
}
762
-
763
-
(** SearchSnippet/get response as defined in RFC8621 Section 4.11.
764
-
Contains search result snippets with highlighted text.
765
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.11>
766
-
*)
767
-
type search_snippet_get_response = {
768
-
account_id : id; (** The account that was searched *)
769
-
list : (id * search_snippet) list; (** Map of email IDs to their search snippets *)
770
-
not_found : id list; (** IDs for which no snippet could be generated *)
771
-
}
772
-
773
-
(** Search snippet for an email as defined in RFC8621 Section 4.11.
774
-
Contains highlighted parts of emails matching a search.
775
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-4.11>
776
-
*)
777
-
and search_snippet = {
778
-
subject : string option; (** Subject with search terms highlighted *)
779
-
preview : string option; (** Email body preview with search terms highlighted *)
780
-
}
781
-
782
-
(** {1:submission EmailSubmission objects}
783
-
Email submission types as defined in RFC8621 Section 5
784
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5>
785
-
*)
786
-
787
-
(** EmailSubmission address as defined in RFC8621 Section 5.1.
788
-
Represents an email address for mail submission.
789
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.1>
790
-
*)
791
-
type submission_address = {
792
-
email : string; (** The email address (e.g., "john@example.com") *)
793
-
parameters : (string * string) list option; (** SMTP extension parameters *)
794
-
}
795
-
796
-
(** Email submission object as defined in RFC8621 Section 5.1.
797
-
Represents an email that has been or will be sent.
798
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.1>
799
-
*)
800
-
type email_submission = {
801
-
id : id; (** Server-assigned ID for the submission *)
802
-
identity_id : id; (** ID of the identity used to send the email *)
803
-
email_id : id; (** ID of the email to send *)
804
-
thread_id : id; (** ID of the thread containing the message *)
805
-
envelope : envelope option; (** SMTP envelope for the message *)
806
-
send_at : utc_date option; (** When to send the email, null for immediate *)
807
-
undo_status : [
808
-
| `pending (** Submission can still be canceled *)
809
-
| `final (** Submission can no longer be canceled *)
810
-
| `canceled (** Submission was canceled *)
811
-
] option; (** Current undo status of the submission *)
812
-
delivery_status : (string * submission_status) list option; (** Map of recipient to delivery status *)
813
-
dsn_blob_ids : (string * id) list option; (** Map of recipient to DSN blob ID *)
814
-
mdn_blob_ids : (string * id) list option; (** Map of recipient to MDN blob ID *)
815
-
}
816
-
817
-
(** Envelope for mail submission as defined in RFC8621 Section 5.1.
818
-
Represents the SMTP envelope for a message.
819
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.1>
820
-
*)
821
-
and envelope = {
822
-
mail_from : submission_address; (** Return path for the message *)
823
-
rcpt_to : submission_address list; (** Recipients for the message *)
824
-
}
825
-
826
-
(** Delivery status for submitted email as defined in RFC8621 Section 5.1.
827
-
Represents the SMTP status of a delivery attempt.
828
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.1>
829
-
*)
830
-
and submission_status = {
831
-
smtp_reply : string; (** SMTP response from the server *)
832
-
delivered : string option; (** Timestamp when message was delivered, if successful *)
833
-
}
834
-
835
-
(** EmailSubmission/get request arguments as defined in RFC8621 Section 5.3.
836
-
Used to fetch email submissions by ID.
837
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.3>
838
-
*)
839
-
type email_submission_get_arguments = {
840
-
account_id : id; (** The account to fetch submissions from *)
841
-
ids : id list option; (** The IDs of submissions to fetch, null means all *)
842
-
properties : string list option; (** Properties to return, null means all *)
843
-
}
844
-
845
-
(** EmailSubmission/get response as defined in RFC8621 Section 5.3.
846
-
Contains requested email submissions.
847
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.3>
848
-
*)
849
-
type email_submission_get_response = {
850
-
account_id : id; (** The account from which submissions were fetched *)
851
-
state : string; (** A string representing the state on the server *)
852
-
list : email_submission list; (** The list of submissions requested *)
853
-
not_found : id list; (** IDs requested that could not be found *)
854
-
}
855
-
856
-
(** EmailSubmission/changes request arguments as defined in RFC8621 Section 5.4.
857
-
Used to get submission changes since a previous state.
858
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.4>
859
-
*)
860
-
type email_submission_changes_arguments = {
861
-
account_id : id; (** The account to get changes for *)
862
-
since_state : string; (** The previous state to compare to *)
863
-
max_changes : unsigned_int option; (** Maximum number of changes to return *)
864
-
}
865
-
866
-
(** EmailSubmission/changes response as defined in RFC8621 Section 5.4.
867
-
Reports submissions that have changed since a previous state.
868
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.4>
869
-
*)
870
-
type email_submission_changes_response = {
871
-
account_id : id; (** The account changes are for *)
872
-
old_state : string; (** The state provided in the request *)
873
-
new_state : string; (** The current state on the server *)
874
-
has_more_changes : bool; (** If true, more changes are available *)
875
-
created : id list; (** IDs of submissions created since old_state *)
876
-
updated : id list; (** IDs of submissions updated since old_state *)
877
-
destroyed : id list; (** IDs of submissions destroyed since old_state *)
878
-
}
879
-
880
-
(** EmailSubmission/query filter condition as defined in RFC8621 Section 5.5.
881
-
Specifies conditions for filtering email submissions in queries.
882
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.5>
883
-
*)
884
-
type email_submission_filter_condition = {
885
-
identity_id : id option; (** Only include submissions with this identity *)
886
-
email_id : id option; (** Only include submissions for this email *)
887
-
thread_id : id option; (** Only include submissions for emails in this thread *)
888
-
before : utc_date option; (** Only include submissions created before this date-time *)
889
-
after : utc_date option; (** Only include submissions created after this date-time *)
890
-
subject : string option; (** Only include submissions with matching subjects *)
891
-
}
892
-
893
-
(** Filter for email submission queries as defined in RFC8621 Section 5.5.
894
-
Complex filter for EmailSubmission/query method.
895
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.5>
896
-
*)
897
-
type email_submission_query_filter = [
898
-
| `And of email_submission_query_filter list (** Logical AND of filters *)
899
-
| `Or of email_submission_query_filter list (** Logical OR of filters *)
900
-
| `Not of email_submission_query_filter (** Logical NOT of a filter *)
901
-
| `Condition of email_submission_filter_condition (** Simple condition filter *)
902
-
]
903
-
904
-
(** EmailSubmission/query request arguments as defined in RFC8621 Section 5.5.
905
-
Used to query email submissions based on filter criteria.
906
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.5>
907
-
*)
908
-
type email_submission_query_arguments = {
909
-
account_id : id; (** The account to query *)
910
-
filter : email_submission_query_filter option; (** Filter to match submissions against *)
911
-
sort : comparator list option; (** Sort criteria *)
912
-
position : unsigned_int option; (** Zero-based index of first result to return *)
913
-
anchor : id option; (** ID of submission to use as reference point *)
914
-
anchor_offset : int_t option; (** Offset from anchor to start returning results *)
915
-
limit : unsigned_int option; (** Maximum number of results to return *)
916
-
calculate_total : bool option; (** Whether to calculate the total number of matching submissions *)
917
-
}
918
-
919
-
(** EmailSubmission/query response as defined in RFC8621 Section 5.5.
920
-
Contains IDs of email submissions matching the query.
921
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.5>
922
-
*)
923
-
type email_submission_query_response = {
924
-
account_id : id; (** The account that was queried *)
925
-
query_state : string; (** State string for the query results *)
926
-
can_calculate_changes : bool; (** Whether queryChanges can be used with these results *)
927
-
position : unsigned_int; (** Zero-based index of the first result *)
928
-
ids : id list; (** IDs of email submissions matching the query *)
929
-
total : unsigned_int option; (** Total number of matches if requested *)
930
-
}
931
-
932
-
(** EmailSubmission/set request arguments as defined in RFC8621 Section 5.6.
933
-
Used to create, update, and destroy email submissions.
934
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.6>
935
-
*)
936
-
type email_submission_set_arguments = {
937
-
account_id : id; (** The account to make changes in *)
938
-
if_in_state : string option; (** Only apply changes if in this state *)
939
-
create : (id * email_submission_creation) list option; (** Map of creation IDs to submissions to create *)
940
-
update : (id * email_submission_update) list option; (** Map of IDs to update properties *)
941
-
destroy : id list option; (** List of IDs to destroy *)
942
-
on_success_update_email : (id * email_update) list option; (** Emails to update if submissions succeed *)
943
-
}
944
-
945
-
(** Properties for email submission creation as defined in RFC8621 Section 5.6.
946
-
Used to create new email submissions.
947
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.6>
948
-
*)
949
-
and email_submission_creation = {
950
-
email_id : id; (** ID of the email to send *)
951
-
identity_id : id; (** ID of the identity to send from *)
952
-
envelope : envelope option; (** Custom envelope, if needed *)
953
-
send_at : utc_date option; (** When to send the email, defaults to now *)
954
-
}
955
-
956
-
(** Properties for email submission update as defined in RFC8621 Section 5.6.
957
-
Used to update existing email submissions.
958
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.6>
959
-
*)
960
-
and email_submission_update = {
961
-
email_id : id option; (** New email ID to use for this submission *)
962
-
identity_id : id option; (** New identity ID to use for this submission *)
963
-
envelope : envelope option; (** New envelope to use for this submission *)
964
-
undo_status : [`canceled] option; (** Set to cancel a pending submission *)
965
-
}
966
-
967
-
(** EmailSubmission/set response as defined in RFC8621 Section 5.6.
968
-
Reports the results of email submission changes.
969
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-5.6>
970
-
*)
971
-
type email_submission_set_response = {
972
-
account_id : id; (** The account that was modified *)
973
-
old_state : string option; (** The state before processing, if changed *)
974
-
new_state : string; (** The current state on the server *)
975
-
created : (id * email_submission) list option; (** Map of creation IDs to created submissions *)
976
-
updated : id list option; (** List of IDs that were successfully updated *)
977
-
destroyed : id list option; (** List of IDs that were successfully destroyed *)
978
-
not_created : (id * set_error) list option; (** Map of IDs to errors for failed creates *)
979
-
not_updated : (id * set_error) list option; (** Map of IDs to errors for failed updates *)
980
-
not_destroyed : (id * set_error) list option; (** Map of IDs to errors for failed destroys *)
981
-
}
982
-
983
-
(** {1:identity Identity objects}
984
-
Identity types as defined in RFC8621 Section 6
985
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-6>
986
-
*)
987
-
988
-
(** Identity for sending mail as defined in RFC8621 Section 6.
989
-
Represents an email identity that can be used to send messages.
990
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-6>
991
-
*)
992
-
type identity = {
993
-
id : id; (** Server-assigned ID for the identity *)
994
-
name : string; (** Display name for the identity *)
995
-
email : string; (** Email address for the identity *)
996
-
reply_to : email_address list option; (** Reply-To addresses to use when sending *)
997
-
bcc : email_address list option; (** BCC addresses to automatically include *)
998
-
text_signature : string option; (** Plain text signature for the identity *)
999
-
html_signature : string option; (** HTML signature for the identity *)
1000
-
may_delete : bool; (** Whether this identity can be deleted *)
1001
-
}
1002
-
1003
-
(** Identity/get request arguments as defined in RFC8621 Section 6.1.
1004
-
Used to fetch identities by ID.
1005
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-6.1>
1006
-
*)
1007
-
type identity_get_arguments = {
1008
-
account_id : id; (** The account to fetch identities from *)
1009
-
ids : id list option; (** The IDs of identities to fetch, null means all *)
1010
-
properties : string list option; (** Properties to return, null means all *)
1011
-
}
1012
-
1013
-
(** Identity/get response as defined in RFC8621 Section 6.1.
1014
-
Contains requested identities.
1015
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-6.1>
1016
-
*)
1017
-
type identity_get_response = {
1018
-
account_id : id; (** The account from which identities were fetched *)
1019
-
state : string; (** A string representing the state on the server *)
1020
-
list : identity list; (** The list of identities requested *)
1021
-
not_found : id list; (** IDs requested that could not be found *)
1022
-
}
1023
-
1024
-
(** Identity/changes request arguments as defined in RFC8621 Section 6.2.
1025
-
Used to get identity changes since a previous state.
1026
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-6.2>
1027
-
*)
1028
-
type identity_changes_arguments = {
1029
-
account_id : id; (** The account to get changes for *)
1030
-
since_state : string; (** The previous state to compare to *)
1031
-
max_changes : unsigned_int option; (** Maximum number of changes to return *)
1032
-
}
1033
-
1034
-
(** Identity/changes response as defined in RFC8621 Section 6.2.
1035
-
Reports identities that have changed since a previous state.
1036
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-6.2>
1037
-
*)
1038
-
type identity_changes_response = {
1039
-
account_id : id; (** The account changes are for *)
1040
-
old_state : string; (** The state provided in the request *)
1041
-
new_state : string; (** The current state on the server *)
1042
-
has_more_changes : bool; (** If true, more changes are available *)
1043
-
created : id list; (** IDs of identities created since old_state *)
1044
-
updated : id list; (** IDs of identities updated since old_state *)
1045
-
destroyed : id list; (** IDs of identities destroyed since old_state *)
1046
-
}
1047
-
1048
-
(** Identity/set request arguments as defined in RFC8621 Section 6.3.
1049
-
Used to create, update, and destroy identities.
1050
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-6.3>
1051
-
*)
1052
-
type identity_set_arguments = {
1053
-
account_id : id; (** The account to make changes in *)
1054
-
if_in_state : string option; (** Only apply changes if in this state *)
1055
-
create : (id * identity_creation) list option; (** Map of creation IDs to identities to create *)
1056
-
update : (id * identity_update) list option; (** Map of IDs to update properties *)
1057
-
destroy : id list option; (** List of IDs to destroy *)
1058
-
}
1059
-
1060
-
(** Properties for identity creation as defined in RFC8621 Section 6.3.
1061
-
Used to create new identities.
1062
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-6.3>
1063
-
*)
1064
-
and identity_creation = {
1065
-
name : string; (** Display name for the identity *)
1066
-
email : string; (** Email address for the identity *)
1067
-
reply_to : email_address list option; (** Reply-To addresses to use when sending *)
1068
-
bcc : email_address list option; (** BCC addresses to automatically include *)
1069
-
text_signature : string option; (** Plain text signature for the identity *)
1070
-
html_signature : string option; (** HTML signature for the identity *)
1071
-
}
1072
-
1073
-
(** Properties for identity update as defined in RFC8621 Section 6.3.
1074
-
Used to update existing identities.
1075
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-6.3>
1076
-
*)
1077
-
and identity_update = {
1078
-
name : string option; (** New display name for the identity *)
1079
-
email : string option; (** New email address for the identity *)
1080
-
reply_to : email_address list option; (** New Reply-To addresses to use *)
1081
-
bcc : email_address list option; (** New BCC addresses to automatically include *)
1082
-
text_signature : string option; (** New plain text signature *)
1083
-
html_signature : string option; (** New HTML signature *)
1084
-
}
1085
-
1086
-
(** Identity/set response as defined in RFC8621 Section 6.3.
1087
-
Reports the results of identity changes.
1088
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-6.3>
1089
-
*)
1090
-
type identity_set_response = {
1091
-
account_id : id; (** The account that was modified *)
1092
-
old_state : string option; (** The state before processing, if changed *)
1093
-
new_state : string; (** The current state on the server *)
1094
-
created : (id * identity) list option; (** Map of creation IDs to created identities *)
1095
-
updated : id list option; (** List of IDs that were successfully updated *)
1096
-
destroyed : id list option; (** List of IDs that were successfully destroyed *)
1097
-
not_created : (id * set_error) list option; (** Map of IDs to errors for failed creates *)
1098
-
not_updated : (id * set_error) list option; (** Map of IDs to errors for failed updates *)
1099
-
not_destroyed : (id * set_error) list option; (** Map of IDs to errors for failed destroys *)
1100
-
}
1101
-
1102
-
(** {1:vacation_response VacationResponse objects}
1103
-
Vacation response types as defined in RFC8621 Section 7
1104
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-7>
1105
-
*)
1106
-
1107
-
(** Vacation auto-reply setting as defined in RFC8621 Section 7.
1108
-
Represents an automatic vacation/out-of-office response.
1109
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-7>
1110
-
*)
1111
-
type vacation_response = {
1112
-
id : id; (** Server-assigned ID for the vacation response *)
1113
-
is_enabled : bool; (** Whether the vacation response is active *)
1114
-
from_date : utc_date option; (** Start date-time of the vacation period *)
1115
-
to_date : utc_date option; (** End date-time of the vacation period *)
1116
-
subject : string option; (** Subject line for the vacation response *)
1117
-
text_body : string option; (** Plain text body for the vacation response *)
1118
-
html_body : string option; (** HTML body for the vacation response *)
1119
-
}
1120
-
1121
-
(** VacationResponse/get request arguments as defined in RFC8621 Section 7.2.
1122
-
Used to fetch vacation responses by ID.
1123
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-7.2>
1124
-
*)
1125
-
type vacation_response_get_arguments = {
1126
-
account_id : id; (** The account to fetch vacation responses from *)
1127
-
ids : id list option; (** The IDs of vacation responses to fetch, null means all *)
1128
-
properties : string list option; (** Properties to return, null means all *)
1129
-
}
1130
-
1131
-
(** VacationResponse/get response as defined in RFC8621 Section 7.2.
1132
-
Contains requested vacation responses.
1133
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-7.2>
1134
-
*)
1135
-
type vacation_response_get_response = {
1136
-
account_id : id; (** The account from which vacation responses were fetched *)
1137
-
state : string; (** A string representing the state on the server *)
1138
-
list : vacation_response list; (** The list of vacation responses requested *)
1139
-
not_found : id list; (** IDs requested that could not be found *)
1140
-
}
1141
-
1142
-
(** VacationResponse/set request arguments as defined in RFC8621 Section 7.3.
1143
-
Used to update vacation responses.
1144
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-7.3>
1145
-
*)
1146
-
type vacation_response_set_arguments = {
1147
-
account_id : id; (** The account to make changes in *)
1148
-
if_in_state : string option; (** Only apply changes if in this state *)
1149
-
update : (id * vacation_response_update) list; (** Map of IDs to update properties *)
1150
-
}
1151
-
1152
-
(** Properties for vacation response update as defined in RFC8621 Section 7.3.
1153
-
Used to update existing vacation responses.
1154
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-7.3>
1155
-
*)
1156
-
and vacation_response_update = {
1157
-
is_enabled : bool option; (** Whether the vacation response is active *)
1158
-
from_date : utc_date option; (** Start date-time of the vacation period *)
1159
-
to_date : utc_date option; (** End date-time of the vacation period *)
1160
-
subject : string option; (** Subject line for the vacation response *)
1161
-
text_body : string option; (** Plain text body for the vacation response *)
1162
-
html_body : string option; (** HTML body for the vacation response *)
1163
-
}
1164
-
1165
-
(** VacationResponse/set response as defined in RFC8621 Section 7.3.
1166
-
Reports the results of vacation response changes.
1167
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-7.3>
1168
-
*)
1169
-
type vacation_response_set_response = {
1170
-
account_id : id; (** The account that was modified *)
1171
-
old_state : string option; (** The state before processing, if changed *)
1172
-
new_state : string; (** The current state on the server *)
1173
-
updated : id list option; (** List of IDs that were successfully updated *)
1174
-
not_updated : (id * set_error) list option; (** Map of IDs to errors for failed updates *)
1175
-
}
1176
-
1177
-
(** {1:message_flags Message Flags and Mailbox Attributes}
1178
-
Message flag types as defined in draft-ietf-mailmaint-messageflag-mailboxattribute-02
1179
-
@see <https://datatracker.ietf.org/doc/html/draft-ietf-mailmaint-messageflag-mailboxattribute>
1180
-
*)
1181
-
1182
-
(** Flag color defined by the combination of MailFlagBit0, MailFlagBit1, and MailFlagBit2 keywords
1183
-
as defined in draft-ietf-mailmaint-messageflag-mailboxattribute-02 Section 3.
1184
-
@see <https://datatracker.ietf.org/doc/html/draft-ietf-mailmaint-messageflag-mailboxattribute#section-3>
1185
-
*)
1186
-
type flag_color =
1187
-
| Red (** Bit pattern 000 - default color *)
1188
-
| Orange (** Bit pattern 100 - MailFlagBit2 set *)
1189
-
| Yellow (** Bit pattern 010 - MailFlagBit1 set *)
1190
-
| Green (** Bit pattern 111 - all bits set *)
1191
-
| Blue (** Bit pattern 001 - MailFlagBit0 set *)
1192
-
| Purple (** Bit pattern 101 - MailFlagBit2 and MailFlagBit0 set *)
1193
-
| Gray (** Bit pattern 011 - MailFlagBit1 and MailFlagBit0 set *)
1194
-
1195
-
(** Standard message keywords as defined in draft-ietf-mailmaint-messageflag-mailboxattribute-02 Section 4.1.
1196
-
These are standardized keywords that can be applied to email messages.
1197
-
@see <https://datatracker.ietf.org/doc/html/draft-ietf-mailmaint-messageflag-mailboxattribute#section-4.1>
1198
-
*)
1199
-
type message_keyword =
1200
-
| Notify (** Indicate a notification should be shown for this message *)
1201
-
| Muted (** User is not interested in future replies to this thread *)
1202
-
| Followed (** User is particularly interested in future replies to this thread *)
1203
-
| Memo (** Message is a note-to-self about another message in the same thread *)
1204
-
| HasMemo (** Message has an associated memo with the $memo keyword *)
1205
-
| HasAttachment (** Message has an attachment *)
1206
-
| HasNoAttachment (** Message does not have an attachment *)
1207
-
| AutoSent (** Message was sent automatically as a response due to a user rule *)
1208
-
| Unsubscribed (** User has unsubscribed from the thread this message is in *)
1209
-
| CanUnsubscribe (** Message has an RFC8058-compliant List-Unsubscribe header *)
1210
-
| Imported (** Message was imported from another mailbox *)
1211
-
| IsTrusted (** Server has verified authenticity of the from name and email *)
1212
-
| MaskedEmail (** Message was received via an alias created for an individual sender *)
1213
-
| New (** Message should be made more prominent due to a recent action *)
1214
-
| MailFlagBit0 (** Bit 0 of the 3-bit flag color pattern *)
1215
-
| MailFlagBit1 (** Bit 1 of the 3-bit flag color pattern *)
1216
-
| MailFlagBit2 (** Bit 2 of the 3-bit flag color pattern *)
1217
-
| OtherKeyword of string (** Other non-standard keywords *)
1218
-
1219
-
(** Special mailbox attribute names as defined in draft-ietf-mailmaint-messageflag-mailboxattribute-02 Section 4.2.
1220
-
These are standardized attributes for special-purpose mailboxes.
1221
-
@see <https://datatracker.ietf.org/doc/html/draft-ietf-mailmaint-messageflag-mailboxattribute#section-4.2>
1222
-
*)
1223
-
type mailbox_attribute =
1224
-
| Snoozed (** Mailbox containing messages that have been snoozed *)
1225
-
| Scheduled (** Mailbox containing messages scheduled to be sent later *)
1226
-
| Memos (** Mailbox containing messages with the $memo keyword *)
1227
-
| OtherAttribute of string (** Other non-standard mailbox attributes *)
1228
-
1229
-
(** Convert bit values to a flag color
1230
-
@param bit0 Value of bit 0 (least significant bit)
1231
-
@param bit1 Value of bit 1
1232
-
@param bit2 Value of bit 2 (most significant bit)
1233
-
@return The corresponding flag color
1234
-
*)
1235
-
val flag_color_of_bits : bool -> bool -> bool -> flag_color
1236
-
1237
-
(** Get the bit values for a flag color
1238
-
@param color The flag color
1239
-
@return Tuple of (bit2, bit1, bit0) values
1240
-
*)
1241
-
val bits_of_flag_color : flag_color -> bool * bool * bool
1242
-
1243
-
(** Check if a message has a flag color based on its keywords
1244
-
@param keywords The list of keywords for the message
1245
-
@return True if the message has one or more flag color bits set
1246
-
*)
1247
-
val has_flag_color : (keyword * bool) list -> bool
1248
-
1249
-
(** Get the flag color from a message's keywords, if present
1250
-
@param keywords The list of keywords for the message
1251
-
@return The flag color if all required bits are present, None otherwise
1252
-
*)
1253
-
val get_flag_color : (keyword * bool) list -> flag_color option
1254
-
1255
-
(** Convert a message keyword to its string representation
1256
-
@param keyword The message keyword
1257
-
@return String representation with $ prefix (e.g., "$notify")
1258
-
*)
1259
-
val string_of_message_keyword : message_keyword -> string
1260
-
1261
-
(** Parse a string into a message keyword
1262
-
@param s The string to parse (with or without $ prefix)
1263
-
@return The corresponding message keyword
1264
-
*)
1265
-
val message_keyword_of_string : string -> message_keyword
1266
-
1267
-
(** Convert a mailbox attribute to its string representation
1268
-
@param attr The mailbox attribute
1269
-
@return String representation with $ prefix (e.g., "$snoozed")
1270
-
*)
1271
-
val string_of_mailbox_attribute : mailbox_attribute -> string
1272
-
1273
-
(** Parse a string into a mailbox attribute
1274
-
@param s The string to parse (with or without $ prefix)
1275
-
@return The corresponding mailbox attribute
1276
-
*)
1277
-
val mailbox_attribute_of_string : string -> mailbox_attribute
1278
-
1279
-
(** Get a human-readable representation of a flag color
1280
-
@param color The flag color
1281
-
@return Human-readable name of the color
1282
-
*)
1283
-
val human_readable_flag_color : flag_color -> string
1284
-
1285
-
(** Get a human-readable representation of a message keyword
1286
-
@param keyword The message keyword
1287
-
@return Human-readable description of the keyword
1288
-
*)
1289
-
val human_readable_message_keyword : message_keyword -> string
1290
-
1291
-
(** Format email keywords into a human-readable string representation
1292
-
@param keywords The list of keywords and their values
1293
-
@return Human-readable comma-separated list of keywords
1294
-
*)
1295
-
val format_email_keywords : (keyword * bool) list -> string
1296
-
end
1297
-
1298
-
(** {1 JSON serialization}
1299
-
Functions for serializing and deserializing JMAP Mail objects to/from JSON
1300
-
*)
1301
-
1302
-
module Json : sig
1303
-
open Types
1304
-
1305
-
(** {2 Helper functions for serialization}
1306
-
Utility functions for converting between OCaml types and JSON representation
1307
-
*)
1308
-
1309
-
(** Convert a mailbox role to its string representation
1310
-
@param role The mailbox role
1311
-
@return String representation (e.g., "inbox", "drafts", etc.)
1312
-
*)
1313
-
val string_of_mailbox_role : mailbox_role -> string
1314
-
1315
-
(** Parse a string into a mailbox role
1316
-
@param s The string to parse
1317
-
@return The corresponding mailbox role, or Unknown if not recognized
1318
-
*)
1319
-
val mailbox_role_of_string : string -> mailbox_role
1320
-
1321
-
(** Convert an email keyword to its string representation
1322
-
@param keyword The email keyword
1323
-
@return String representation with $ prefix (e.g., "$flagged")
1324
-
*)
1325
-
val string_of_keyword : keyword -> string
1326
-
1327
-
(** Parse a string into an email keyword
1328
-
@param s The string to parse (with or without $ prefix)
1329
-
@return The corresponding email keyword
1330
-
*)
1331
-
val keyword_of_string : string -> keyword
1332
-
1333
-
(** {2 Mailbox serialization}
1334
-
Functions for serializing and deserializing mailbox objects
1335
-
*)
1336
-
1337
-
(** TODO:claude - Need to implement all JSON serialization functions
1338
-
for each type we've defined. This would be a substantial amount of
1339
-
code and likely require additional understanding of the ezjsonm API.
1340
-
1341
-
The interface would include functions like:
1342
-
1343
-
val mailbox_to_json : mailbox -> Ezjsonm.value
1344
-
val mailbox_of_json : Ezjsonm.value -> mailbox result
1345
-
1346
-
And similarly for all other types.
1347
-
*)
1348
-
end
1349
-
1350
-
(** {1 API functions}
1351
-
High-level functions for interacting with JMAP Mail servers
1352
-
*)
1353
-
1354
-
(** Authentication credentials for a JMAP server *)
1355
-
type credentials = {
1356
-
username: string; (** Username for authentication *)
1357
-
password: string; (** Password for authentication *)
1358
-
}
1359
-
1360
-
(** Connection to a JMAP mail server *)
1361
-
type connection = {
1362
-
session: Jmap.Types.session; (** Session information from the server *)
1363
-
config: Jmap.Api.config; (** Configuration for API requests *)
1364
-
}
1365
-
1366
-
(** Login to a JMAP server and establish a connection
1367
-
@param uri The URI of the JMAP server
1368
-
@param credentials Authentication credentials
1369
-
@return A connection object if successful
1370
-
1371
-
Creates a new connection to a JMAP server using username/password authentication.
1372
-
*)
1373
-
val login :
1374
-
uri:string ->
1375
-
credentials:credentials ->
1376
-
(connection, Jmap.Api.error) result Lwt.t
1377
-
1378
-
(** Login to a JMAP server using an API token
1379
-
@param uri The URI of the JMAP server
1380
-
@param api_token The API token for authentication
1381
-
@return A connection object if successful
1382
-
1383
-
Creates a new connection to a JMAP server using Bearer token authentication.
1384
-
*)
1385
-
val login_with_token :
1386
-
uri:string ->
1387
-
api_token:string ->
1388
-
(connection, Jmap.Api.error) result Lwt.t
1389
-
1390
-
(** Get all mailboxes for an account
1391
-
@param conn The JMAP connection
1392
-
@param account_id The account ID to get mailboxes for
1393
-
@return A list of mailboxes if successful
1394
-
1395
-
Retrieves all mailboxes (folders) in the specified account.
1396
-
*)
1397
-
val get_mailboxes :
1398
-
connection ->
1399
-
account_id:Jmap.Types.id ->
1400
-
(Types.mailbox list, Jmap.Api.error) result Lwt.t
1401
-
1402
-
(** Get a specific mailbox by ID
1403
-
@param conn The JMAP connection
1404
-
@param account_id The account ID
1405
-
@param mailbox_id The mailbox ID to retrieve
1406
-
@return The mailbox if found
1407
-
1408
-
Retrieves a single mailbox by its ID.
1409
-
*)
1410
-
val get_mailbox :
1411
-
connection ->
1412
-
account_id:Jmap.Types.id ->
1413
-
mailbox_id:Jmap.Types.id ->
1414
-
(Types.mailbox, Jmap.Api.error) result Lwt.t
1415
-
1416
-
(** Get messages in a mailbox
1417
-
@param conn The JMAP connection
1418
-
@param account_id The account ID
1419
-
@param mailbox_id The mailbox ID to get messages from
1420
-
@param limit Optional limit on number of messages to return
1421
-
@return The list of email messages if successful
1422
-
1423
-
Retrieves email messages in the specified mailbox, with optional limit.
1424
-
*)
1425
-
val get_messages_in_mailbox :
1426
-
connection ->
1427
-
account_id:Jmap.Types.id ->
1428
-
mailbox_id:Jmap.Types.id ->
1429
-
?limit:int ->
1430
-
unit ->
1431
-
(Types.email list, Jmap.Api.error) result Lwt.t
1432
-
1433
-
(** Get a single email message by ID
1434
-
@param conn The JMAP connection
1435
-
@param account_id The account ID
1436
-
@param email_id The email ID to retrieve
1437
-
@return The email message if found
1438
-
1439
-
Retrieves a single email message by its ID.
1440
-
*)
1441
-
val get_email :
1442
-
connection ->
1443
-
account_id:Jmap.Types.id ->
1444
-
email_id:Jmap.Types.id ->
1445
-
(Types.email, Jmap.Api.error) result Lwt.t
1446
-
1447
-
(** Check if an email has a specific message keyword
1448
-
@param email The email to check
1449
-
@param keyword The message keyword to look for
1450
-
@return true if the email has the keyword, false otherwise
1451
-
1452
-
Tests whether an email has a particular keyword (flag) set.
1453
-
*)
1454
-
val has_message_keyword :
1455
-
Types.email ->
1456
-
Types.message_keyword ->
1457
-
bool
1458
-
1459
-
(** Add a message keyword to an email
1460
-
@param conn The JMAP connection
1461
-
@param account_id The account ID
1462
-
@param email_id The email ID
1463
-
@param keyword The message keyword to add
1464
-
@return Success or error
1465
-
1466
-
Adds a keyword (flag) to an email message.
1467
-
*)
1468
-
val add_message_keyword :
1469
-
connection ->
1470
-
account_id:Jmap.Types.id ->
1471
-
email_id:Jmap.Types.id ->
1472
-
keyword:Types.message_keyword ->
1473
-
(unit, Jmap.Api.error) result Lwt.t
1474
-
1475
-
(** Set a flag color for an email
1476
-
@param conn The JMAP connection
1477
-
@param account_id The account ID
1478
-
@param email_id The email ID
1479
-
@param color The flag color to set
1480
-
@return Success or error
1481
-
1482
-
Sets a flag color on an email message by setting the appropriate bit flags.
1483
-
*)
1484
-
val set_flag_color :
1485
-
connection ->
1486
-
account_id:Jmap.Types.id ->
1487
-
email_id:Jmap.Types.id ->
1488
-
color:Types.flag_color ->
1489
-
(unit, Jmap.Api.error) result Lwt.t
1490
-
1491
-
(** Convert an email's keywords to typed message_keyword list
1492
-
@param email The email to analyze
1493
-
@return List of message keywords
1494
-
1495
-
Extracts all message keywords from an email's keyword list.
1496
-
*)
1497
-
val get_message_keywords :
1498
-
Types.email ->
1499
-
Types.message_keyword list
1500
-
1501
-
(** Get emails with a specific message keyword
1502
-
@param conn The JMAP connection
1503
-
@param account_id The account ID
1504
-
@param keyword The message keyword to search for
1505
-
@param limit Optional limit on number of emails to return
1506
-
@return List of emails with the keyword if successful
1507
-
1508
-
Retrieves all emails that have a specific keyword (flag) set.
1509
-
*)
1510
-
val get_emails_with_keyword :
1511
-
connection ->
1512
-
account_id:Jmap.Types.id ->
1513
-
keyword:Types.message_keyword ->
1514
-
?limit:int ->
1515
-
unit ->
1516
-
(Types.email list, Jmap.Api.error) result Lwt.t
1517
-
1518
-
(** {1 Email Submission}
1519
-
Functions for sending emails
1520
-
*)
1521
-
1522
-
(** Create a new email draft
1523
-
@param conn The JMAP connection
1524
-
@param account_id The account ID
1525
-
@param mailbox_id The mailbox ID to store the draft in (usually "drafts")
1526
-
@param from The sender's email address
1527
-
@param to_addresses List of recipient email addresses
1528
-
@param subject The email subject line
1529
-
@param text_body Plain text message body
1530
-
@param html_body Optional HTML message body
1531
-
@return The created email ID if successful
1532
-
1533
-
Creates a new email draft in the specified mailbox with the provided content.
1534
-
*)
1535
-
val create_email_draft :
1536
-
connection ->
1537
-
account_id:Jmap.Types.id ->
1538
-
mailbox_id:Jmap.Types.id ->
1539
-
from:string ->
1540
-
to_addresses:string list ->
1541
-
subject:string ->
1542
-
text_body:string ->
1543
-
?html_body:string ->
1544
-
unit ->
1545
-
(Jmap.Types.id, Jmap.Api.error) result Lwt.t
1546
-
1547
-
(** Get all identities for an account
1548
-
@param conn The JMAP connection
1549
-
@param account_id The account ID
1550
-
@return A list of identities if successful
1551
-
1552
-
Retrieves all identities (email addresses that can be used for sending) for an account.
1553
-
*)
1554
-
val get_identities :
1555
-
connection ->
1556
-
account_id:Jmap.Types.id ->
1557
-
(Types.identity list, Jmap.Api.error) result Lwt.t
1558
-
1559
-
(** Find a suitable identity by email address
1560
-
@param conn The JMAP connection
1561
-
@param account_id The account ID
1562
-
@param email The email address to match
1563
-
@return The identity if found, otherwise Error
1564
-
1565
-
Finds an identity that matches the given email address, either exactly or
1566
-
via a wildcard pattern (e.g., *@domain.com).
1567
-
*)
1568
-
val find_identity_by_email :
1569
-
connection ->
1570
-
account_id:Jmap.Types.id ->
1571
-
email:string ->
1572
-
(Types.identity, Jmap.Api.error) result Lwt.t
1573
-
1574
-
(** Submit an email for delivery
1575
-
@param conn The JMAP connection
1576
-
@param account_id The account ID
1577
-
@param identity_id The identity ID to send from
1578
-
@param email_id The email ID to submit
1579
-
@param envelope Optional custom envelope
1580
-
@return The submission ID if successful
1581
-
1582
-
Submits an existing email (usually a draft) for delivery using the specified identity.
1583
-
*)
1584
-
val submit_email :
1585
-
connection ->
1586
-
account_id:Jmap.Types.id ->
1587
-
identity_id:Jmap.Types.id ->
1588
-
email_id:Jmap.Types.id ->
1589
-
?envelope:Types.envelope ->
1590
-
unit ->
1591
-
(Jmap.Types.id, Jmap.Api.error) result Lwt.t
1592
-
1593
-
(** Create and submit an email in one operation
1594
-
@param conn The JMAP connection
1595
-
@param account_id The account ID
1596
-
@param from The sender's email address
1597
-
@param to_addresses List of recipient email addresses
1598
-
@param subject The email subject line
1599
-
@param text_body Plain text message body
1600
-
@param html_body Optional HTML message body
1601
-
@return The submission ID if successful
1602
-
1603
-
Creates a new email and immediately submits it for delivery.
1604
-
This is a convenience function that combines create_email_draft and submit_email.
1605
-
*)
1606
-
val create_and_submit_email :
1607
-
connection ->
1608
-
account_id:Jmap.Types.id ->
1609
-
from:string ->
1610
-
to_addresses:string list ->
1611
-
subject:string ->
1612
-
text_body:string ->
1613
-
?html_body:string ->
1614
-
unit ->
1615
-
(Jmap.Types.id, Jmap.Api.error) result Lwt.t
1616
-
1617
-
(** Get status of an email submission
1618
-
@param conn The JMAP connection
1619
-
@param account_id The account ID
1620
-
@param submission_id The email submission ID
1621
-
@return The submission status if successful
1622
-
1623
-
Retrieves the current status of an email submission, including delivery status if available.
1624
-
*)
1625
-
val get_submission_status :
1626
-
connection ->
1627
-
account_id:Jmap.Types.id ->
1628
-
submission_id:Jmap.Types.id ->
1629
-
(Types.email_submission, Jmap.Api.error) result Lwt.t
1630
-
1631
-
(** {1 Email Address Utilities}
1632
-
Utilities for working with email addresses
1633
-
*)
1634
-
1635
-
(** Check if an email address matches a filter string
1636
-
@param email The email address to check
1637
-
@param pattern The filter pattern to match against
1638
-
@return True if the email address matches the filter
1639
-
1640
-
The filter supports simple wildcards:
1641
-
- "*" matches any sequence of characters
1642
-
- "?" matches any single character
1643
-
- Case-insensitive matching is used
1644
-
- If no wildcards are present, substring matching is used
1645
-
*)
1646
-
val email_address_matches : string -> string -> bool
1647
-
1648
-
(** Check if an email matches a sender filter
1649
-
@param email The email object to check
1650
-
@param pattern The sender filter pattern
1651
-
@return True if any sender address matches the filter
1652
-
1653
-
Tests whether any of an email's sender addresses match the provided pattern.
1654
-
*)
1655
-
val email_matches_sender : Types.email -> string -> bool
+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. *)
+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