anil.recoil.org
+1
-22
.gitignore
+1
-22
.gitignore
···
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
1
+
_build
20
2
.env
21
-
.api-key
22
-
.api-key-rw
23
-
.api-url
-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
+99
CLAUDE.md
+99
CLAUDE.md
···
1
+
I wish to generate a set of OCaml module signatures and types (no implementations) that will type check, for an implementation of the JMAP protocol (RFC8620) and the associated email extensions (RFC8621). The code you generate should have ocamldoc that references the relevant sections of the RFC it is implementing, using <https://www.rfc-editor.org/rfc/rfc8620.html#section-1.2> as a template for the hyperlinks (replace the fragment with the appropriate section identifier). There are local copy of the specifications in the `spec/` directory in this repository. The `spec/rfc8620.txt` is the core JMAP protocol, which we are aiming to implement in OCaml code in this project. We must accurately capture the specification in the OCaml interface and never violate it without clear indication.
2
+
3
+
The architecture of the modules should be one portable set that implement core JMAP (RFC8620) as an OCaml module called `Jmap` (with module aliases to the submodules that implement that). Then generate another set of modules that implement the email-specific extensions (RFC8621) including flag handling for (e.g.) Apple Mail under a module called `Jmap_email`. These should all be portable OCaml type signatures (the mli files), and then generate another module that implements the interface for a Unix implementation that uses the Unix module to perform real connections. You do not need to implement TLS support for this first iteration of the code interfaces.
4
+
5
+
You should also generate a module index file called jmap.mli that explains how all the generated modules fit together, along with a sketch of some example OCaml code that uses it to connect to a JMAP server and list recent unread emails from a particular sender.
6
+
7
+
When selecting dependencies, ONLY use Yojson, Uri and Unix in your type signatures aside from the OCaml standard library. The standard Hashtbl is fine for any k/v datastructures and do not use Maps or other functor applications for this. DO NOT generate any AST attributes, and do not use any PPX derivers or other syntax extensions. Just generate clean, conventional OCaml type signatures. DO NOT generate any references to Lwt or Async, and only use the Unix module to access basic network and storage functions if the standard library does not suffice.
8
+
9
+
You can run commands with:
10
+
11
+
- clean: `opam exec -- dune clean`
12
+
- build: `opam exec -- dune build @check`
13
+
- docs: `opam exec -- dune build @doc`
14
+
- build while ignoring warnings: add `--profile=release` to the CLI to activate the profile that ignores warnings
15
+
16
+
# Tips on fixing bugs
17
+
18
+
If you see errors like this:
19
+
20
+
```
21
+
File "../../.jmap.objs/byte/jmap.odoc":
22
+
Warning: Hidden fields in type 'Jmap.Email.Identity.identity_create'
23
+
```
24
+
25
+
Then examine the HTML docs built for that module. You will see that there are module references with __ in them, e.g. "Jmap__.Jmap_email_types.Email_address.t" which indicate that the module is being accessed directly instead of via the module aliases defined.
26
+
27
+
## Documentation Comments
28
+
29
+
When adding OCaml documentation comments, be careful about ambiguous documentation comments. If you see errors like:
30
+
31
+
```
32
+
Error (warning 50 [unexpected-docstring]): ambiguous documentation comment
33
+
```
34
+
35
+
This usually means there isn't enough whitespace between the documentation comment and the code element it's documenting. Always:
36
+
37
+
1. Add blank lines between consecutive documentation comments
38
+
2. Add a blank line before a documentation comment for a module/type/value declaration
39
+
3. When documenting record fields or variant constructors, place the comment after the field with at least one space
40
+
41
+
Example of correct documentation spacing:
42
+
43
+
```ocaml
44
+
(** Module documentation. *)
45
+
46
+
(** Value documentation. *)
47
+
val some_value : int
48
+
49
+
(** Type documentation. *)
50
+
type t =
51
+
| First (** First constructor *)
52
+
| Second (** Second constructor *)
53
+
54
+
(** Record documentation. *)
55
+
type record = {
56
+
field1 : int; (** Field1 documentation *)
57
+
field2 : string (** Field2 documentation *)
58
+
}
59
+
```
60
+
61
+
If in doubt, add more whitespace lines than needed - you can always clean this up later with `dune build @fmt` to get ocamlformat to sort out the whitespace properly.
62
+
63
+
# Module Structure Guidelines
64
+
65
+
IMPORTANT: For all modules, use a nested module structure with a canonical `type t` inside each submodule. This approach ensures consistent type naming and logical grouping of related functionality.
66
+
67
+
1. Top-level files should define their main types directly (e.g., `jmap_identity.mli` should define identity-related types at the top level).
68
+
69
+
2. Related operations or specialized subtypes should be defined in nested modules within the file:
70
+
```ocaml
71
+
module Create : sig
72
+
type t (* NOT 'type create' or any other name *)
73
+
(* Functions operating on creation requests *)
74
+
75
+
module Response : sig
76
+
type t
77
+
(* Functions for creation responses *)
78
+
end
79
+
end
80
+
```
81
+
82
+
3. Consistently use `type t` for the main type in each module and submodule.
83
+
84
+
4. Functions operating on a type should be placed in the same module as the type.
85
+
86
+
5. When a file is named after a concept (e.g., `jmap_identity.mli`), there's no need to have a matching nested module inside the file (e.g., `module Identity : sig...`), as the file itself represents that namespace.
87
+
88
+
This structured approach promotes encapsulation, consistent type naming, and clearer organization of related functionality.
89
+
90
+
# Software engineering
91
+
92
+
We will go through a multi step process to build this library. We are currently at STEP 2.
93
+
94
+
1) we will generate OCaml interface files only, and no module implementations. The purpose here is to write and document the necessary type signatures. Once we generate these, we can check that they work with "dune build @check". Once that succeeds, we will build HTML documentation with "dune build @doc" in order to ensure the interfaces are reasonable.
95
+
96
+
2) once these interface files exist, we will build a series of sample binaries that will attempt to implement the JMAP protocol for some sample usecases, using only the Unix module. This binary will not fully link, but it should type check. The only linking error that we get should be from the missing Jmap library implementation.
97
+
98
+
3) we will calculate the dependency order for each module in the Jmap library, and work through an implementation of each one in increasing dependency order (that is, the module with the fewest dependencies should be handled first). For each module interface, we will generate a corresponding module implementation. We will also add test cases for this specific module, and update the dune files. Before proceeding to the next module, a `dune build` should be done to ensure the implementation builds and type checks as far as is possible.
99
+
-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.
+52
-34
README.md
+52
-34
README.md
···
1
-
# ocaml-jmap - JMAP Protocol Implementation for OCaml
1
+
# JMAP OCaml Libraries
2
2
3
-
A complete implementation of the JSON Meta Application Protocol (JMAP) as specified in RFC 8620 (core) and RFC 8621 (mail).
3
+
This project implements OCaml libraries for the JMAP protocol, following the specifications in RFC 8620 (Core) and RFC 8621 (Mail).
4
4
5
-
## Packages
5
+
## Project Structure
6
6
7
-
- **jmap** - Core JMAP protocol types and serialization
8
-
- **jmap-eio** - JMAP client using Eio for async I/O
9
-
- **jmap-brr** - JMAP client for browsers using js_of_ocaml
7
+
The code is organized into three main libraries:
10
8
11
-
## Key Features
9
+
1. `jmap` - Core JMAP protocol (RFC 8620)
10
+
- Basic data types
11
+
- Error handling
12
+
- Wire protocol
13
+
- Session handling
14
+
- Standard methods (get, set, changes, query)
15
+
- Binary data handling
16
+
- Push notifications
17
+
18
+
2. `jmap-unix` - Unix-specific implementation of JMAP
19
+
- HTTP connections to JMAP endpoints
20
+
- Authentication
21
+
- Session discovery
22
+
- Request/response handling
23
+
- Blob upload/download
24
+
- Unix-specific I/O
12
25
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
26
+
3. `jmap-email` - JMAP Mail extension (RFC 8621)
27
+
- Email specific types
28
+
- Mailbox handling
29
+
- Thread management
30
+
- Search snippet functionality
31
+
- Identity management
32
+
- Email submission
33
+
- Vacation response
18
34
19
35
## Usage
20
36
37
+
The libraries are designed to be used together. For example:
38
+
21
39
```ocaml
22
-
(* Query emails from a mailbox *)
40
+
(* Using the core JMAP protocol library *)
23
41
open Jmap
42
+
open Jmap.Types
43
+
open Jmap.Wire
24
44
25
-
let query_emails ~client ~account_id ~mailbox_id =
26
-
let filter = Email.Query.Filter.(in_mailbox mailbox_id) in
27
-
let query = Email.Query.make ~account_id ~filter () in
28
-
Client.call client query
29
-
```
45
+
(* Using the Unix implementation *)
46
+
open Jmap_unix
30
47
31
-
## Installation
48
+
(* Using the JMAP Email extension library *)
49
+
open Jmap_email
50
+
open Jmap_email.Types
32
51
33
-
```
34
-
opam install jmap jmap-eio
52
+
(* Example: Connecting to a JMAP server *)
53
+
let connect_to_server () =
54
+
let credentials = Jmap_unix.Basic("username", "password") in
55
+
let (ctx, session) = Jmap_unix.quick_connect ~host:"jmap.example.com" ~username:"user" ~password:"pass" in
56
+
...
35
57
```
36
58
37
-
For browser-based applications:
59
+
## Building
38
60
39
-
```
40
-
opam install jmap jmap-brr
41
-
```
61
+
```sh
62
+
# Build
63
+
opam exec -- dune build @check
42
64
43
-
## Documentation
44
-
45
-
API documentation is available via:
46
-
47
-
```
48
-
opam install jmap
49
-
odig doc jmap
65
+
# Generate documentation
66
+
opam exec -- dune build @doc
50
67
```
51
68
52
-
## License
69
+
## References
53
70
54
-
ISC
71
+
- [RFC 8620: The JSON Meta Application Protocol (JMAP)](https://www.rfc-editor.org/rfc/rfc8620.html)
72
+
- [RFC 8621: The JSON Meta Application Protocol (JMAP) for Mail](https://www.rfc-editor.org/rfc/rfc8621.html)
+57
-10
bin/dune
+57
-10
bin/dune
···
1
1
(executable
2
-
(name jmap)
3
-
(public_name jmap)
2
+
(name jmap_email_search)
3
+
(public_name jmap-email-search)
4
+
(package jmap)
5
+
(libraries jmap jmap-email cmdliner unix jmap_unix)
6
+
(modules jmap_email_search))
7
+
8
+
(executable
9
+
(name jmap_thread_analyzer)
10
+
(public_name jmap-thread-analyzer)
11
+
(package jmap)
12
+
(libraries jmap jmap-email cmdliner unix)
13
+
(modules jmap_thread_analyzer))
14
+
15
+
(executable
16
+
(name jmap_mailbox_explorer)
17
+
(public_name jmap-mailbox-explorer)
18
+
(package jmap)
19
+
(libraries jmap jmap-email cmdliner unix)
20
+
(modules jmap_mailbox_explorer))
21
+
22
+
(executable
23
+
(name jmap_flag_manager)
24
+
(public_name jmap-flag-manager)
25
+
(package jmap)
26
+
(libraries jmap jmap-email cmdliner unix)
27
+
(modules jmap_flag_manager))
28
+
29
+
(executable
30
+
(name jmap_identity_monitor)
31
+
(public_name jmap-identity-monitor)
32
+
(package jmap)
33
+
(libraries jmap jmap-email cmdliner unix)
34
+
(modules jmap_identity_monitor))
35
+
36
+
(executable
37
+
(name jmap_blob_downloader)
38
+
(public_name jmap-blob-downloader)
39
+
(package jmap)
40
+
(libraries jmap jmap-email jmap-unix cmdliner unix)
41
+
(modules jmap_blob_downloader))
42
+
43
+
(executable
44
+
(name jmap_email_composer)
45
+
(public_name jmap-email-composer)
46
+
(package jmap)
47
+
(libraries jmap jmap-email jmap-unix cmdliner unix)
48
+
(modules jmap_email_composer))
49
+
50
+
(executable
51
+
(name jmap_push_listener)
52
+
(public_name jmap-push-listener)
4
53
(package jmap)
5
-
(optional)
6
-
(modules jmap)
7
-
(libraries jmap.eio eio_main))
54
+
(libraries jmap jmap-email jmap-unix cmdliner unix)
55
+
(modules jmap_push_listener))
8
56
9
57
(executable
10
-
(name jmapq)
11
-
(public_name jmapq)
58
+
(name jmap_vacation_manager)
59
+
(public_name jmap-vacation-manager)
12
60
(package jmap)
13
-
(optional)
14
-
(modules jmapq)
15
-
(libraries jmap.eio eio_main re jsont.bytesrw))
61
+
(libraries jmap jmap-email jmap-unix cmdliner unix)
62
+
(modules jmap_vacation_manager))
-298
bin/fastmail_list.ml
-298
bin/fastmail_list.ml
···
1
-
(**
2
-
* fastmail_list - Lists emails from a Fastmail account using JMAP API
3
-
*
4
-
* This binary connects to the Fastmail JMAP API using an authentication token
5
-
* from the JMAP_API_TOKEN environment variable and lists the most recent 100
6
-
* emails with their subjects, sender details, and labels.
7
-
*
8
-
* Usage:
9
-
* JMAP_API_TOKEN=your_api_token ./fastmail_list [options]
10
-
*
11
-
* Options:
12
-
* --unread List only unread messages
13
-
* --labels Show labels/keywords associated with messages
14
-
* --debug=LEVEL Set debug level (0-4, where 4 is most verbose)
15
-
* --from=PATTERN Filter messages by sender email address
16
-
* --demo-refs Demonstrate result references feature
17
-
*)
18
-
19
-
open Lwt.Syntax
20
-
open Jmap
21
-
open Jmap.Mail
22
-
open Cmdliner
23
-
module Mail = Jmap.Proto.Types
24
-
25
-
(** Prints the email details *)
26
-
let print_email ~show_labels (email : Mail.email) =
27
-
let sender =
28
-
match email.from with
29
-
| Some (addr :: _) ->
30
-
(match addr.name with
31
-
| Some name -> Printf.sprintf "%s <%s>" name addr.email
32
-
| None -> addr.email)
33
-
| _ -> "<unknown>"
34
-
in
35
-
let subject =
36
-
match email.subject with
37
-
| Some s -> s
38
-
| None -> "<no subject>"
39
-
in
40
-
let date = email.received_at in
41
-
42
-
(* Format labels/keywords if requested *)
43
-
let labels_str =
44
-
if show_labels then
45
-
let formatted = Jmap.Proto.Types.format_email_keywords email.keywords in
46
-
if formatted <> "" then
47
-
" [" ^ formatted ^ "]"
48
-
else
49
-
""
50
-
else
51
-
""
52
-
in
53
-
54
-
Printf.printf "%s | %s | %s%s\n" date sender subject labels_str
55
-
56
-
(** Check if an email is unread *)
57
-
let is_unread (email : Mail.email) =
58
-
let is_unread_keyword =
59
-
List.exists (fun (kw, active) ->
60
-
kw = Mail.Unread && active
61
-
) email.keywords
62
-
in
63
-
let is_not_seen =
64
-
not (List.exists (fun (kw, active) ->
65
-
kw = Mail.Seen && active
66
-
) email.keywords)
67
-
in
68
-
is_unread_keyword || is_not_seen
69
-
70
-
(** Example function demonstrating how to use higher-level library functions for JMAP requests *)
71
-
let demo_result_references conn account_id =
72
-
Printf.printf "\nResult Reference Demo:\n";
73
-
Printf.printf "=====================\n";
74
-
75
-
(* Step 1: Get all mailboxes *)
76
-
let* mailboxes_result = Jmap.Proto.get_mailboxes conn ~account_id in
77
-
match mailboxes_result with
78
-
| Error err ->
79
-
Printf.printf "Error getting mailboxes: %s\n" (Api.string_of_error err);
80
-
Lwt.return_unit
81
-
82
-
| Ok mailboxes ->
83
-
(* Step 2: Get the first mailbox for this demonstration *)
84
-
match mailboxes with
85
-
| [] ->
86
-
Printf.printf "No mailboxes found.\n";
87
-
Lwt.return_unit
88
-
89
-
| first_mailbox :: _ ->
90
-
Printf.printf "Using mailbox: %s\n" first_mailbox.Mail.name;
91
-
92
-
(* Step 3: Get emails from the selected mailbox *)
93
-
let* emails_result = Jmap.Proto.get_messages_in_mailbox
94
-
conn
95
-
~account_id
96
-
~mailbox_id:first_mailbox.Mail.id
97
-
~limit:10
98
-
()
99
-
in
100
-
101
-
match emails_result with
102
-
| Error err ->
103
-
Printf.printf "Error getting emails: %s\n" (Api.string_of_error err);
104
-
Lwt.return_unit
105
-
106
-
| Ok emails ->
107
-
Printf.printf "Successfully retrieved %d emails using the high-level library API!\n"
108
-
(List.length emails);
109
-
110
-
(* Display some basic information about the emails *)
111
-
List.iteri (fun i (email:Jmap.Proto.Types.email) ->
112
-
let subject = Option.value ~default:"<no subject>" email.Mail.subject in
113
-
Printf.printf " %d. %s\n" (i + 1) subject
114
-
) emails;
115
-
116
-
Lwt.return_unit
117
-
118
-
(** Main function for listing emails *)
119
-
let list_emails unread_only show_labels debug_level demo_refs sender_filter =
120
-
(* Configure logging *)
121
-
init_logging ~level:debug_level ~enable_logs:(debug_level > 0) ~redact_sensitive:true ();
122
-
123
-
match Sys.getenv_opt "JMAP_API_TOKEN" with
124
-
| None ->
125
-
Printf.eprintf "Error: JMAP_API_TOKEN environment variable not set\n";
126
-
Printf.eprintf "Usage: JMAP_API_TOKEN=your_token fastmail-list [options]\n";
127
-
exit 1
128
-
| Some token ->
129
-
(* Only print token info at Info level or higher *)
130
-
Logs.info (fun m -> m "Using API token: %s" (redact_token token));
131
-
132
-
(* Connect to Fastmail JMAP API *)
133
-
let formatted_token = token in
134
-
135
-
(* Only print instructions at Info level *)
136
-
let level = match Logs.level () with
137
-
| None -> 0
138
-
| Some Logs.Error -> 1
139
-
| Some Logs.Info -> 2
140
-
| Some Logs.Debug -> 3
141
-
| _ -> 2
142
-
in
143
-
if level >= 2 then begin
144
-
Printf.printf "\nFastmail API Instructions:\n";
145
-
Printf.printf "1. Get a token from: https://app.fastmail.com/settings/tokens\n";
146
-
Printf.printf "2. Create a new token with Mail scope (read/write)\n";
147
-
Printf.printf "3. Copy the full token (example: 3de40-5fg1h2-a1b2c3...)\n";
148
-
Printf.printf "4. Run: env JMAP_API_TOKEN=\"your_full_token\" fastmail-list [options]\n\n";
149
-
Printf.printf "Note: This example is working correctly but needs a valid Fastmail token.\n\n";
150
-
end;
151
-
let* result = login_with_token
152
-
~uri:"https://api.fastmail.com/jmap/session"
153
-
~api_token:formatted_token
154
-
in
155
-
match result with
156
-
| Error err ->
157
-
Printf.eprintf "%s\n" (Api.string_of_error err);
158
-
Lwt.return 1
159
-
| Ok conn ->
160
-
(* Get the primary account ID *)
161
-
let primary_account_id =
162
-
let mail_capability = Jmap.Proto.Capability.to_string Jmap.Proto.Capability.Mail in
163
-
match List.assoc_opt mail_capability conn.session.primary_accounts with
164
-
| Some id -> id
165
-
| None ->
166
-
match conn.session.accounts with
167
-
| (id, _) :: _ -> id
168
-
| [] ->
169
-
Printf.eprintf "No accounts found\n";
170
-
exit 1
171
-
in
172
-
173
-
(* Run result references demo if requested *)
174
-
let* () =
175
-
if demo_refs then
176
-
demo_result_references conn primary_account_id
177
-
else
178
-
Lwt.return_unit
179
-
in
180
-
181
-
(* Get the Inbox mailbox *)
182
-
let* mailboxes_result = get_mailboxes conn ~account_id:primary_account_id in
183
-
match mailboxes_result with
184
-
| Error err ->
185
-
Printf.eprintf "Failed to get mailboxes: %s\n" (Api.string_of_error err);
186
-
Lwt.return 1
187
-
| Ok mailboxes ->
188
-
(* If there's a mailbox list, just use the first one for this example *)
189
-
let inbox_id =
190
-
match mailboxes with
191
-
| mailbox :: _ -> mailbox.Mail.id
192
-
| [] ->
193
-
Printf.eprintf "No mailboxes found\n";
194
-
exit 1
195
-
in
196
-
197
-
(* Get messages from inbox *)
198
-
let* emails_result = get_messages_in_mailbox
199
-
conn
200
-
~account_id:primary_account_id
201
-
~mailbox_id:inbox_id
202
-
~limit:1000
203
-
()
204
-
in
205
-
match emails_result with
206
-
| Error err ->
207
-
Printf.eprintf "Failed to get emails: %s\n" (Api.string_of_error err);
208
-
Lwt.return 1
209
-
| Ok emails ->
210
-
(* Apply filters based on command line arguments *)
211
-
let filtered_by_unread =
212
-
if unread_only then
213
-
List.filter is_unread emails
214
-
else
215
-
emails
216
-
in
217
-
218
-
(* Apply sender filter if specified *)
219
-
let filtered_emails =
220
-
if sender_filter <> "" then begin
221
-
Printf.printf "Filtering by sender: %s\n" sender_filter;
222
-
List.filter (fun email ->
223
-
Jmap.Proto.email_matches_sender email sender_filter
224
-
) filtered_by_unread
225
-
end else
226
-
filtered_by_unread
227
-
in
228
-
229
-
(* Create description of applied filters *)
230
-
let filter_description =
231
-
let parts = [] in
232
-
let parts = if unread_only then "unread" :: parts else parts in
233
-
let parts = if sender_filter <> "" then ("from \"" ^ sender_filter ^ "\"") :: parts else parts in
234
-
match parts with
235
-
| [] -> "the most recent"
236
-
| [p] -> p
237
-
| _ -> String.concat " and " parts
238
-
in
239
-
240
-
Printf.printf "Listing %s %d emails in your inbox:\n"
241
-
filter_description
242
-
(List.length filtered_emails);
243
-
Printf.printf "--------------------------------------------\n";
244
-
List.iter (print_email ~show_labels) filtered_emails;
245
-
Lwt.return 0
246
-
247
-
(** Command line interface *)
248
-
let unread_only =
249
-
let doc = "List only unread messages" in
250
-
Arg.(value & flag & info ["unread"] ~doc)
251
-
252
-
let show_labels =
253
-
let doc = "Show labels/keywords associated with messages" in
254
-
Arg.(value & flag & info ["labels"] ~doc)
255
-
256
-
let debug_level =
257
-
let doc = "Set debug level (0-4, where 4 is most verbose)" in
258
-
Arg.(value & opt int 0 & info ["debug"] ~docv:"LEVEL" ~doc)
259
-
260
-
let demo_refs =
261
-
let doc = "Demonstrate result references feature" in
262
-
Arg.(value & flag & info ["demo-refs"] ~doc)
263
-
264
-
let sender_filter =
265
-
let doc = "Filter messages by sender email address (supports wildcards: * and ?)" in
266
-
Arg.(value & opt string "" & info ["from"] ~docv:"PATTERN" ~doc)
267
-
268
-
let cmd =
269
-
let doc = "List emails from a Fastmail account using JMAP API" in
270
-
let man = [
271
-
`S Manpage.s_description;
272
-
`P "This program connects to the Fastmail JMAP API using an authentication token
273
-
from the JMAP_API_TOKEN environment variable and lists the most recent emails
274
-
with their subjects, sender details, and labels.";
275
-
`P "You must obtain a Fastmail API token from https://app.fastmail.com/settings/tokens
276
-
and set it in the JMAP_API_TOKEN environment variable.";
277
-
`S Manpage.s_environment;
278
-
`P "$(b,JMAP_API_TOKEN) The Fastmail API authentication token (required)";
279
-
`S Manpage.s_examples;
280
-
`P "List all emails:";
281
-
`P " $(mname) $(i,JMAP_API_TOKEN=your_token)";
282
-
`P "List only unread emails:";
283
-
`P " $(mname) $(i,JMAP_API_TOKEN=your_token) --unread";
284
-
`P "List emails from a specific sender:";
285
-
`P " $(mname) $(i,JMAP_API_TOKEN=your_token) --from=user@example.com";
286
-
`P "List unread emails with labels:";
287
-
`P " $(mname) $(i,JMAP_API_TOKEN=your_token) --unread --labels";
288
-
] in
289
-
let info = Cmd.info "fastmail-list" ~doc ~man in
290
-
Cmd.v info Term.(const (fun u l d r s ->
291
-
Lwt_main.run (list_emails u l d r s)
292
-
) $ unread_only $ show_labels $ debug_level $ demo_refs $ sender_filter)
293
-
294
-
(** Program entry point *)
295
-
let () = exit (Cmd.eval_value cmd |> function
296
-
| Ok (`Ok exit_code) -> exit_code
297
-
| Ok (`Version | `Help) -> 0
298
-
| Error _ -> 1)
-177
bin/fastmail_send.ml
-177
bin/fastmail_send.ml
···
1
-
(** JMAP email sending utility for Fastmail
2
-
3
-
This utility sends an email via JMAP to recipients specified on the command line.
4
-
The subject is provided as a command-line argument, and the message body is read
5
-
from standard input.
6
-
7
-
Usage:
8
-
fastmail_send --to=recipient@example.com [--to=another@example.com ...] --subject="Email subject"
9
-
10
-
Environment variables:
11
-
- JMAP_API_TOKEN: Required. The Fastmail API token for authentication.
12
-
- JMAP_FROM_EMAIL: Optional. The sender's email address. If not provided, uses the first identity.
13
-
14
-
@see <https://datatracker.ietf.org/doc/html/rfc8621#section-7> RFC8621 Section 7
15
-
*)
16
-
17
-
open Lwt.Syntax
18
-
open Cmdliner
19
-
20
-
let log_error fmt = Fmt.epr ("\u{1b}[1;31mError: \u{1b}[0m" ^^ fmt ^^ "@.")
21
-
let log_info fmt = Fmt.pr ("\u{1b}[1;34mInfo: \u{1b}[0m" ^^ fmt ^^ "@.")
22
-
let log_success fmt = Fmt.pr ("\u{1b}[1;32mSuccess: \u{1b}[0m" ^^ fmt ^^ "@.")
23
-
24
-
(** Read the entire message body from stdin *)
25
-
let read_message_body () =
26
-
let buffer = Buffer.create 1024 in
27
-
let rec read_lines () =
28
-
try
29
-
let line = input_line stdin in
30
-
Buffer.add_string buffer line;
31
-
Buffer.add_char buffer '\n';
32
-
read_lines ()
33
-
with
34
-
| End_of_file -> Buffer.contents buffer
35
-
in
36
-
read_lines ()
37
-
38
-
(** Main function to send an email *)
39
-
let send_email to_addresses subject from_email =
40
-
(* Check for API token in environment *)
41
-
match Sys.getenv_opt "JMAP_API_TOKEN" with
42
-
| None ->
43
-
log_error "JMAP_API_TOKEN environment variable not set";
44
-
exit 1
45
-
| Some token ->
46
-
(* Read message body from stdin *)
47
-
log_info "Reading message body from stdin (press Ctrl+D when finished)...";
48
-
let message_body = read_message_body () in
49
-
if message_body = "" then
50
-
log_info "No message body entered, using a blank message";
51
-
52
-
(* Initialize JMAP connection *)
53
-
let fastmail_uri = "https://api.fastmail.com/jmap/session" in
54
-
Lwt_main.run begin
55
-
let* conn_result = Jmap.Proto.login_with_token ~uri:fastmail_uri ~api_token:token in
56
-
match conn_result with
57
-
| Error err ->
58
-
let msg = Jmap.Api.string_of_error err in
59
-
log_error "Failed to connect to Fastmail: %s" msg;
60
-
Lwt.return 1
61
-
| Ok conn ->
62
-
(* Get primary account ID *)
63
-
let account_id =
64
-
(* Get the primary account - first personal account in the list *)
65
-
let (_, _account) = List.find (fun (_, acc) ->
66
-
acc.Jmap.Types.is_personal) conn.session.accounts in
67
-
(* Use the first account id as primary *)
68
-
(match conn.session.primary_accounts with
69
-
| (_, id) :: _ -> id
70
-
| [] ->
71
-
(* Fallback if no primary accounts defined *)
72
-
let (id, _) = List.hd conn.session.accounts in
73
-
id)
74
-
in
75
-
76
-
(* Determine sender email address *)
77
-
let* from_email_result = match from_email with
78
-
| Some email -> Lwt.return_ok email
79
-
| None ->
80
-
(* Get first available identity *)
81
-
let* identities_result = Jmap.Proto.get_identities conn ~account_id in
82
-
match identities_result with
83
-
| Ok [] ->
84
-
log_error "No identities found for account";
85
-
Lwt.return_error "No identities found"
86
-
| Ok (identity :: _) -> Lwt.return_ok identity.email
87
-
| Error err ->
88
-
let msg = Jmap.Api.string_of_error err in
89
-
log_error "Failed to get identities: %s" msg;
90
-
Lwt.return_error msg
91
-
in
92
-
93
-
match from_email_result with
94
-
| Error _msg -> Lwt.return 1
95
-
| Ok from_email ->
96
-
(* Send the email *)
97
-
log_info "Sending email from %s to %s"
98
-
from_email
99
-
(String.concat ", " to_addresses);
100
-
101
-
let* submission_result =
102
-
Jmap.Proto.create_and_submit_email
103
-
conn
104
-
~account_id
105
-
~from:from_email
106
-
~to_addresses
107
-
~subject
108
-
~text_body:message_body
109
-
()
110
-
in
111
-
112
-
match submission_result with
113
-
| Error err ->
114
-
let msg = Jmap.Api.string_of_error err in
115
-
log_error "Failed to send email: %s" msg;
116
-
Lwt.return 1
117
-
| Ok submission_id ->
118
-
log_success "Email sent successfully (Submission ID: %s)" submission_id;
119
-
(* Wait briefly then check submission status *)
120
-
let* () = Lwt_unix.sleep 1.0 in
121
-
let* status_result = Jmap.Proto.get_submission_status
122
-
conn
123
-
~account_id
124
-
~submission_id
125
-
in
126
-
127
-
(match status_result with
128
-
| Ok status ->
129
-
let status_text = match status.Jmap.Proto.Types.undo_status with
130
-
| Some `pending -> "Pending"
131
-
| Some `final -> "Final (delivered)"
132
-
| Some `canceled -> "Canceled"
133
-
| None -> "Unknown"
134
-
in
135
-
log_info "Submission status: %s" status_text;
136
-
137
-
(match status.Jmap.Proto.Types.delivery_status with
138
-
| Some statuses ->
139
-
List.iter (fun (email, status) ->
140
-
let delivery = match status.Jmap.Proto.Types.delivered with
141
-
| Some "yes" -> "Delivered"
142
-
| Some "no" -> "Failed"
143
-
| Some "queued" -> "Queued"
144
-
| Some s -> s
145
-
| None -> "Unknown"
146
-
in
147
-
log_info "Delivery to %s: %s" email delivery
148
-
) statuses
149
-
| None -> ());
150
-
Lwt.return 0
151
-
| Error _ ->
152
-
(* We don't fail if status check fails, as the email might still be sent *)
153
-
Lwt.return 0)
154
-
end
155
-
156
-
(** Command line interface *)
157
-
let to_addresses =
158
-
let doc = "Email address of the recipient (can be specified multiple times)" in
159
-
Arg.(value & opt_all string [] & info ["to"] ~docv:"EMAIL" ~doc)
160
-
161
-
let subject =
162
-
let doc = "Subject line for the email" in
163
-
Arg.(required & opt (some string) None & info ["subject"] ~docv:"SUBJECT" ~doc)
164
-
165
-
let from_email =
166
-
let doc = "Sender's email address (optional, defaults to primary identity)" in
167
-
Arg.(value & opt (some string) None & info ["from"] ~docv:"EMAIL" ~doc)
168
-
169
-
let cmd =
170
-
let doc = "Send an email via JMAP to Fastmail" in
171
-
let info = Cmd.info "fastmail_send" ~doc in
172
-
Cmd.v info Term.(const send_email $ to_addresses $ subject $ from_email)
173
-
174
-
let () = match Cmd.eval_value cmd with
175
-
| Ok (`Ok code) -> exit code
176
-
| Ok (`Version | `Help) -> exit 0
177
-
| Error _ -> exit 1
-1552
bin/jmap.ml
-1552
bin/jmap.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP command-line client *)
7
-
8
-
open Cmdliner
9
-
10
-
(** {1 Helpers} *)
11
-
12
-
let ptime_to_string t =
13
-
let (y, m, d), ((hh, mm, ss), _tz) = Ptime.to_date_time t in
14
-
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" y m d hh mm ss
15
-
16
-
let truncate_string max_len s =
17
-
if String.length s <= max_len then s
18
-
else String.sub s 0 (max_len - 3) ^ "..."
19
-
20
-
let format_email_address (addr : Jmap.Proto.Email_address.t) =
21
-
match addr.name with
22
-
| Some name -> Printf.sprintf "%s <%s>" name addr.email
23
-
| None -> addr.email
24
-
25
-
let format_email_addresses addrs =
26
-
String.concat ", " (List.map format_email_address addrs)
27
-
28
-
let format_keywords keywords =
29
-
keywords
30
-
|> List.filter_map (fun (k, v) -> if v then Some k else None)
31
-
|> String.concat " "
32
-
33
-
(* Helpers for optional Email fields *)
34
-
let email_id (e : Jmap.Proto.Email.t) =
35
-
match e.id with Some id -> Jmap.Proto.Id.to_string id | None -> "?"
36
-
37
-
let email_received_at (e : Jmap.Proto.Email.t) =
38
-
match e.received_at with Some t -> ptime_to_string t | None -> "?"
39
-
40
-
let email_keywords (e : Jmap.Proto.Email.t) =
41
-
Option.value ~default:[] e.keywords
42
-
43
-
let email_preview (e : Jmap.Proto.Email.t) =
44
-
Option.value ~default:"" e.preview
45
-
46
-
let email_thread_id (e : Jmap.Proto.Email.t) =
47
-
match e.thread_id with Some id -> Jmap.Proto.Id.to_string id | None -> "?"
48
-
49
-
let email_size (e : Jmap.Proto.Email.t) =
50
-
Option.value ~default:0L e.size
51
-
52
-
let email_mailbox_ids (e : Jmap.Proto.Email.t) =
53
-
Option.value ~default:[] e.mailbox_ids
54
-
55
-
(** {1 Session Command} *)
56
-
57
-
let session_cmd =
58
-
let run cfg =
59
-
Eio_main.run @@ fun env ->
60
-
Eio.Switch.run @@ fun sw ->
61
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
62
-
let session = Jmap_eio.Client.session client in
63
-
64
-
Fmt.pr "@[<v>%a@," Fmt.(styled `Bold string) "Session Information:";
65
-
Fmt.pr " Username: %a@," Fmt.(styled `Green string) session.username;
66
-
Fmt.pr " State: %s@," session.state;
67
-
Fmt.pr " API URL: %s@," session.api_url;
68
-
Fmt.pr " Upload URL: %s@," session.upload_url;
69
-
Fmt.pr " Download URL: %s@," session.download_url;
70
-
Fmt.pr "@, %a@," Fmt.(styled `Bold string) "Capabilities:";
71
-
List.iter (fun (cap, _) ->
72
-
Fmt.pr " %s@," cap
73
-
) session.capabilities;
74
-
Fmt.pr "@, %a@," Fmt.(styled `Bold string) "Accounts:";
75
-
List.iter (fun (id, acct) ->
76
-
let acct : Jmap.Proto.Session.Account.t = acct in
77
-
Fmt.pr " %a: %s (personal=%b, read_only=%b)@,"
78
-
Fmt.(styled `Cyan string) (Jmap.Proto.Id.to_string id)
79
-
acct.name acct.is_personal acct.is_read_only
80
-
) session.accounts;
81
-
Fmt.pr "@, %a@," Fmt.(styled `Bold string) "Primary Accounts:";
82
-
List.iter (fun (cap, id) ->
83
-
Fmt.pr " %s: %s@," cap (Jmap.Proto.Id.to_string id)
84
-
) session.primary_accounts;
85
-
Fmt.pr "@]@."
86
-
in
87
-
let doc = "Show JMAP session information" in
88
-
let info = Cmd.info "session" ~doc in
89
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term)
90
-
91
-
(** {1 Mailboxes Command} *)
92
-
93
-
let mailboxes_cmd =
94
-
let run cfg =
95
-
Eio_main.run @@ fun env ->
96
-
Eio.Switch.run @@ fun sw ->
97
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
98
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
99
-
100
-
Jmap_eio.Cli.debug cfg "Fetching mailboxes for account %s" (Jmap.Proto.Id.to_string account_id);
101
-
102
-
let req = Jmap_eio.Client.Build.(
103
-
make_request
104
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
105
-
[mailbox_get ~call_id:"m1" ~account_id ()]
106
-
) in
107
-
108
-
match Jmap_eio.Client.request client req with
109
-
| Error e ->
110
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
111
-
exit 1
112
-
| Ok response ->
113
-
match Jmap_eio.Client.Parse.parse_mailbox_get ~call_id:"m1" response with
114
-
| Error e ->
115
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
116
-
exit 1
117
-
| Ok result ->
118
-
Fmt.pr "@[<v>%a (state: %s)@,@,"
119
-
Fmt.(styled `Bold string) "Mailboxes"
120
-
result.state;
121
-
(* Sort by sort_order then name *)
122
-
let sorted = List.sort (fun (a : Jmap.Proto.Mailbox.t) (b : Jmap.Proto.Mailbox.t) ->
123
-
let sort_a = Option.value ~default:0L a.sort_order in
124
-
let sort_b = Option.value ~default:0L b.sort_order in
125
-
let cmp = Int64.compare sort_a sort_b in
126
-
let name_a = Option.value ~default:"" a.name in
127
-
let name_b = Option.value ~default:"" b.name in
128
-
if cmp <> 0 then cmp else String.compare name_a name_b
129
-
) result.list in
130
-
List.iter (fun (mbox : Jmap.Proto.Mailbox.t) ->
131
-
let role_str = match mbox.role with
132
-
| Some role -> Printf.sprintf " [%s]" (Jmap.Proto.Mailbox.role_to_string role)
133
-
| None -> ""
134
-
in
135
-
let id_str = match mbox.id with
136
-
| Some id -> Jmap.Proto.Id.to_string id
137
-
| None -> "?"
138
-
in
139
-
let name = Option.value ~default:"(unnamed)" mbox.name in
140
-
let total = Option.value ~default:0L mbox.total_emails in
141
-
let unread = Option.value ~default:0L mbox.unread_emails in
142
-
Fmt.pr " %a %s%a (%Ld total, %Ld unread)@,"
143
-
Fmt.(styled `Cyan string) id_str
144
-
name
145
-
Fmt.(styled `Yellow string) role_str
146
-
total unread
147
-
) sorted;
148
-
Fmt.pr "@]@."
149
-
in
150
-
let doc = "List mailboxes" in
151
-
let info = Cmd.info "mailboxes" ~doc in
152
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term)
153
-
154
-
(** {1 Emails Command} *)
155
-
156
-
let emails_cmd =
157
-
let limit_term =
158
-
let doc = "Maximum number of emails to list" in
159
-
Arg.(value & opt int 20 & info ["limit"; "n"] ~docv:"N" ~doc)
160
-
in
161
-
let mailbox_term =
162
-
let doc = "Mailbox ID to filter by" in
163
-
Arg.(value & opt (some string) None & info ["mailbox"; "m"] ~docv:"ID" ~doc)
164
-
in
165
-
let run cfg limit mailbox_id_str =
166
-
Eio_main.run @@ fun env ->
167
-
Eio.Switch.run @@ fun sw ->
168
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
169
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
170
-
171
-
Jmap_eio.Cli.debug cfg "Querying emails with limit %d" limit;
172
-
173
-
(* Build filter if mailbox specified *)
174
-
let filter = match mailbox_id_str with
175
-
| Some id_str ->
176
-
let mailbox_id = Jmap.Proto.Id.of_string_exn id_str in
177
-
let cond : Jmap.Proto.Email.Filter_condition.t = {
178
-
in_mailbox = Some mailbox_id;
179
-
in_mailbox_other_than = None;
180
-
before = None; after = None;
181
-
min_size = None; max_size = None;
182
-
all_in_thread_have_keyword = None;
183
-
some_in_thread_have_keyword = None;
184
-
none_in_thread_have_keyword = None;
185
-
has_keyword = None; not_keyword = None;
186
-
has_attachment = None;
187
-
text = None; from = None; to_ = None;
188
-
cc = None; bcc = None; subject = None;
189
-
body = None; header = None;
190
-
} in
191
-
Some (Jmap.Proto.Filter.Condition cond)
192
-
| None -> None
193
-
in
194
-
195
-
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
196
-
let query_inv = Jmap_eio.Client.Build.email_query
197
-
~call_id:"q1"
198
-
~account_id
199
-
?filter
200
-
~sort
201
-
~limit:(Int64.of_int limit)
202
-
()
203
-
in
204
-
205
-
let req = Jmap_eio.Client.Build.(
206
-
make_request
207
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
208
-
[query_inv]
209
-
) in
210
-
211
-
match Jmap_eio.Client.request client req with
212
-
| Error e ->
213
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
214
-
exit 1
215
-
| Ok response ->
216
-
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
217
-
| Error e ->
218
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
219
-
exit 1
220
-
| Ok query_result ->
221
-
let email_ids = query_result.ids in
222
-
Jmap_eio.Cli.debug cfg "Found %d email IDs" (List.length email_ids);
223
-
224
-
if List.length email_ids = 0 then (
225
-
Fmt.pr "No emails found.@.";
226
-
) else (
227
-
(* Fetch email details *)
228
-
let get_inv = Jmap_eio.Client.Build.email_get
229
-
~call_id:"g1"
230
-
~account_id
231
-
~ids:email_ids
232
-
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
233
-
"size"; "receivedAt"; "subject"; "from"; "preview"]
234
-
()
235
-
in
236
-
let req2 = Jmap_eio.Client.Build.(
237
-
make_request
238
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
239
-
[get_inv]
240
-
) in
241
-
242
-
match Jmap_eio.Client.request client req2 with
243
-
| Error e ->
244
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
245
-
exit 1
246
-
| Ok response2 ->
247
-
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
248
-
| Error e ->
249
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
250
-
exit 1
251
-
| Ok get_result ->
252
-
Fmt.pr "@[<v>%a (showing %d of %s)@,@,"
253
-
Fmt.(styled `Bold string) "Emails"
254
-
(List.length get_result.list)
255
-
(match query_result.total with
256
-
| Some n -> Int64.to_string n
257
-
| None -> "?");
258
-
List.iter (fun (email : Jmap.Proto.Email.t) ->
259
-
let from_str = match email.from with
260
-
| Some addrs -> format_email_addresses addrs
261
-
| None -> "(unknown)"
262
-
in
263
-
let subject = Option.value email.subject ~default:"(no subject)" in
264
-
let keywords = Option.value ~default:[] email.keywords in
265
-
let flags = format_keywords keywords in
266
-
let flag_str = if flags = "" then "" else " [" ^ flags ^ "]" in
267
-
let id_str = match email.id with
268
-
| Some id -> Jmap.Proto.Id.to_string id
269
-
| None -> "?"
270
-
in
271
-
let received = match email.received_at with
272
-
| Some t -> ptime_to_string t
273
-
| None -> "?"
274
-
in
275
-
let preview = Option.value ~default:"" email.preview in
276
-
Fmt.pr " %a %s@,"
277
-
Fmt.(styled `Cyan string) id_str
278
-
received;
279
-
Fmt.pr " From: %s@," (truncate_string 60 from_str);
280
-
Fmt.pr " Subject: %a%s@,"
281
-
Fmt.(styled `White string) (truncate_string 60 subject)
282
-
flag_str;
283
-
Fmt.pr " Preview: %s@,@,"
284
-
(truncate_string 70 preview);
285
-
) get_result.list;
286
-
Fmt.pr "@]@."
287
-
)
288
-
in
289
-
let doc = "List emails" in
290
-
let info = Cmd.info "emails" ~doc in
291
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ limit_term $ mailbox_term)
292
-
293
-
(** {1 Search Command} *)
294
-
295
-
let search_cmd =
296
-
let query_term =
297
-
let doc = "Search query text" in
298
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"QUERY" ~doc)
299
-
in
300
-
let limit_term =
301
-
let doc = "Maximum number of results" in
302
-
Arg.(value & opt int 20 & info ["limit"; "n"] ~docv:"N" ~doc)
303
-
in
304
-
let run cfg query limit =
305
-
Eio_main.run @@ fun env ->
306
-
Eio.Switch.run @@ fun sw ->
307
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
308
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
309
-
310
-
Jmap_eio.Cli.debug cfg "Searching for: %s" query;
311
-
312
-
(* Build text filter *)
313
-
let cond : Jmap.Proto.Email.Filter_condition.t = {
314
-
in_mailbox = None; in_mailbox_other_than = None;
315
-
before = None; after = None;
316
-
min_size = None; max_size = None;
317
-
all_in_thread_have_keyword = None;
318
-
some_in_thread_have_keyword = None;
319
-
none_in_thread_have_keyword = None;
320
-
has_keyword = None; not_keyword = None;
321
-
has_attachment = None;
322
-
text = Some query;
323
-
from = None; to_ = None;
324
-
cc = None; bcc = None; subject = None;
325
-
body = None; header = None;
326
-
} in
327
-
let filter = Jmap.Proto.Filter.Condition cond in
328
-
329
-
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
330
-
let query_inv = Jmap_eio.Client.Build.email_query
331
-
~call_id:"q1"
332
-
~account_id
333
-
~filter
334
-
~sort
335
-
~limit:(Int64.of_int limit)
336
-
()
337
-
in
338
-
339
-
let req = Jmap_eio.Client.Build.(
340
-
make_request
341
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
342
-
[query_inv]
343
-
) in
344
-
345
-
match Jmap_eio.Client.request client req with
346
-
| Error e ->
347
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
348
-
exit 1
349
-
| Ok response ->
350
-
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
351
-
| Error e ->
352
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
353
-
exit 1
354
-
| Ok query_result ->
355
-
let email_ids = query_result.ids in
356
-
357
-
if List.length email_ids = 0 then (
358
-
Fmt.pr "No emails found matching: %s@." query;
359
-
) else (
360
-
(* Fetch email details *)
361
-
let get_inv = Jmap_eio.Client.Build.email_get
362
-
~call_id:"g1"
363
-
~account_id
364
-
~ids:email_ids
365
-
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
366
-
"size"; "receivedAt"; "subject"; "from"; "preview"]
367
-
()
368
-
in
369
-
let req2 = Jmap_eio.Client.Build.(
370
-
make_request
371
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
372
-
[get_inv]
373
-
) in
374
-
375
-
match Jmap_eio.Client.request client req2 with
376
-
| Error e ->
377
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
378
-
exit 1
379
-
| Ok response2 ->
380
-
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
381
-
| Error e ->
382
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
383
-
exit 1
384
-
| Ok get_result ->
385
-
Fmt.pr "@[<v>%a for \"%s\" (%d results)@,@,"
386
-
Fmt.(styled `Bold string) "Search results"
387
-
query
388
-
(List.length get_result.list);
389
-
List.iter (fun (email : Jmap.Proto.Email.t) ->
390
-
let from_str = match email.from with
391
-
| Some addrs -> format_email_addresses addrs
392
-
| None -> "(unknown)"
393
-
in
394
-
let subject = Option.value email.subject ~default:"(no subject)" in
395
-
let id_str = match email.id with
396
-
| Some id -> Jmap.Proto.Id.to_string id
397
-
| None -> "?"
398
-
in
399
-
let received = match email.received_at with
400
-
| Some t -> ptime_to_string t
401
-
| None -> "?"
402
-
in
403
-
let preview = Option.value ~default:"" email.preview in
404
-
Fmt.pr " %a %s@,"
405
-
Fmt.(styled `Cyan string) id_str
406
-
received;
407
-
Fmt.pr " From: %s@," (truncate_string 60 from_str);
408
-
Fmt.pr " Subject: %a@,"
409
-
Fmt.(styled `White string) (truncate_string 60 subject);
410
-
Fmt.pr " Preview: %s@,@,"
411
-
(truncate_string 70 preview);
412
-
) get_result.list;
413
-
Fmt.pr "@]@."
414
-
)
415
-
in
416
-
let doc = "Search emails by text" in
417
-
let info = Cmd.info "search" ~doc in
418
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ query_term $ limit_term)
419
-
420
-
(** {1 Recent Command - chains query + get for detailed listing} *)
421
-
422
-
let recent_cmd =
423
-
let limit_term =
424
-
let doc = "Number of recent emails to show (max 100)" in
425
-
Arg.(value & opt int 100 & info ["limit"; "n"] ~docv:"N" ~doc)
426
-
in
427
-
let format_term =
428
-
let doc = "Output format: table, compact, or detailed" in
429
-
Arg.(value & opt (enum ["table", `Table; "compact", `Compact; "detailed", `Detailed])
430
-
`Table & info ["format"; "f"] ~docv:"FORMAT" ~doc)
431
-
in
432
-
let run cfg limit format =
433
-
let limit = min limit 100 in
434
-
Eio_main.run @@ fun env ->
435
-
Eio.Switch.run @@ fun sw ->
436
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
437
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
438
-
439
-
Jmap_eio.Cli.debug cfg "Fetching %d most recent emails" limit;
440
-
441
-
(* Query for recent emails *)
442
-
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
443
-
let query_inv = Jmap_eio.Client.Build.email_query
444
-
~call_id:"q1"
445
-
~account_id
446
-
~sort
447
-
~limit:(Int64.of_int limit)
448
-
()
449
-
in
450
-
451
-
let req = Jmap_eio.Client.Build.(
452
-
make_request
453
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
454
-
[query_inv]
455
-
) in
456
-
457
-
match Jmap_eio.Client.request client req with
458
-
| Error e ->
459
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
460
-
exit 1
461
-
| Ok response ->
462
-
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
463
-
| Error e ->
464
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
465
-
exit 1
466
-
| Ok query_result ->
467
-
let email_ids = query_result.ids in
468
-
Jmap_eio.Cli.debug cfg "Query returned %d email IDs" (List.length email_ids);
469
-
470
-
if List.length email_ids = 0 then (
471
-
Fmt.pr "No emails found.@."
472
-
) else (
473
-
(* Fetch full details for all emails *)
474
-
let properties = [
475
-
"id"; "blobId"; "threadId"; "mailboxIds"; "keywords"; "size";
476
-
"receivedAt"; "subject"; "from"; "to"; "cc"; "preview"
477
-
] in
478
-
let get_inv = Jmap_eio.Client.Build.email_get
479
-
~call_id:"g1"
480
-
~account_id
481
-
~ids:email_ids
482
-
~properties
483
-
()
484
-
in
485
-
let req2 = Jmap_eio.Client.Build.(
486
-
make_request
487
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
488
-
[get_inv]
489
-
) in
490
-
491
-
Jmap_eio.Cli.debug cfg "Fetching email details...";
492
-
493
-
match Jmap_eio.Client.request client req2 with
494
-
| Error e ->
495
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
496
-
exit 1
497
-
| Ok response2 ->
498
-
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
499
-
| Error e ->
500
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
501
-
exit 1
502
-
| Ok get_result ->
503
-
Jmap_eio.Cli.debug cfg "Got %d emails" (List.length get_result.list);
504
-
505
-
(* Output based on format *)
506
-
match format with
507
-
| `Compact ->
508
-
List.iter (fun (email : Jmap.Proto.Email.t) ->
509
-
let from_str = match email.from with
510
-
| Some (addr :: _) ->
511
-
Option.value addr.name ~default:addr.email
512
-
| _ -> "?"
513
-
in
514
-
let subject = Option.value email.subject ~default:"(no subject)" in
515
-
let flags = format_keywords (email_keywords email) in
516
-
Printf.printf "%s\t%s\t%s\t%s\t%s\n"
517
-
(email_id email)
518
-
(email_received_at email)
519
-
(truncate_string 20 from_str)
520
-
(truncate_string 50 subject)
521
-
flags
522
-
) get_result.list
523
-
524
-
| `Table ->
525
-
Fmt.pr "@[<v>%a (%d emails, state: %s)@,@,"
526
-
Fmt.(styled `Bold string) "Recent Emails"
527
-
(List.length get_result.list)
528
-
get_result.state;
529
-
(* Header *)
530
-
Fmt.pr "%-12s %-19s %-20s %-40s %s@,"
531
-
"ID" "Date" "From" "Subject" "Flags";
532
-
Fmt.pr "%s@," (String.make 110 '-');
533
-
List.iter (fun (email : Jmap.Proto.Email.t) ->
534
-
let from_str = match email.from with
535
-
| Some (addr :: _) ->
536
-
Option.value addr.name ~default:addr.email
537
-
| _ -> "?"
538
-
in
539
-
let subject = Option.value email.subject ~default:"(no subject)" in
540
-
let flags = format_keywords (email_keywords email) in
541
-
let id_short =
542
-
let id = email_id email in
543
-
if String.length id > 12 then String.sub id 0 12 else id
544
-
in
545
-
Fmt.pr "%-12s %s %-20s %-40s %s@,"
546
-
id_short
547
-
(email_received_at email)
548
-
(truncate_string 20 from_str)
549
-
(truncate_string 40 subject)
550
-
flags
551
-
) get_result.list;
552
-
Fmt.pr "@]@."
553
-
554
-
| `Detailed ->
555
-
Fmt.pr "@[<v>%a (%d emails)@,@,"
556
-
Fmt.(styled `Bold string) "Recent Emails"
557
-
(List.length get_result.list);
558
-
List.iteri (fun i (email : Jmap.Proto.Email.t) ->
559
-
let from_str = match email.from with
560
-
| Some addrs -> format_email_addresses addrs
561
-
| None -> "(unknown)"
562
-
in
563
-
let to_str = match email.to_ with
564
-
| Some addrs -> format_email_addresses addrs
565
-
| None -> ""
566
-
in
567
-
let cc_str = match email.cc with
568
-
| Some addrs -> format_email_addresses addrs
569
-
| None -> ""
570
-
in
571
-
let subject = Option.value email.subject ~default:"(no subject)" in
572
-
let flags = format_keywords (email_keywords email) in
573
-
let mailbox_count = List.length (email_mailbox_ids email) in
574
-
575
-
Fmt.pr "@[<v 2>%a Email %d of %d@,"
576
-
Fmt.(styled `Bold string) "---"
577
-
(i + 1) (List.length get_result.list);
578
-
Fmt.pr "ID: %a@,"
579
-
Fmt.(styled `Cyan string) (email_id email);
580
-
Fmt.pr "Thread: %s@," (email_thread_id email);
581
-
Fmt.pr "Date: %s@," (email_received_at email);
582
-
Fmt.pr "From: %s@," from_str;
583
-
if to_str <> "" then Fmt.pr "To: %s@," to_str;
584
-
if cc_str <> "" then Fmt.pr "Cc: %s@," cc_str;
585
-
Fmt.pr "Subject: %a@,"
586
-
Fmt.(styled `White string) subject;
587
-
Fmt.pr "Size: %Ld bytes@," (email_size email);
588
-
Fmt.pr "Mailboxes: %d@," mailbox_count;
589
-
if flags <> "" then Fmt.pr "Flags: %s@," flags;
590
-
Fmt.pr "Preview: %s@]@,@," (email_preview email);
591
-
) get_result.list;
592
-
Fmt.pr "@]@."
593
-
)
594
-
in
595
-
let doc = "List recent emails with full details (chains query + get)" in
596
-
let info = Cmd.info "recent" ~doc in
597
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ limit_term $ format_term)
598
-
599
-
(** {1 Threads Command} *)
600
-
601
-
let threads_cmd =
602
-
let email_id_term =
603
-
let doc = "Email ID to get thread for" in
604
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"EMAIL_ID" ~doc)
605
-
in
606
-
let run cfg email_id_str =
607
-
Eio_main.run @@ fun env ->
608
-
Eio.Switch.run @@ fun sw ->
609
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
610
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
611
-
612
-
let target_email_id = Jmap.Proto.Id.of_string_exn email_id_str in
613
-
614
-
(* First get the email to find its thread ID - include required properties *)
615
-
let get_inv = Jmap_eio.Client.Build.email_get
616
-
~call_id:"e1"
617
-
~account_id
618
-
~ids:[target_email_id]
619
-
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"]
620
-
()
621
-
in
622
-
let req = Jmap_eio.Client.Build.(
623
-
make_request
624
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
625
-
[get_inv]
626
-
) in
627
-
628
-
match Jmap_eio.Client.request client req with
629
-
| Error e ->
630
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
631
-
exit 1
632
-
| Ok response ->
633
-
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"e1" response with
634
-
| Error e ->
635
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
636
-
exit 1
637
-
| Ok email_result ->
638
-
match email_result.list with
639
-
| [] ->
640
-
Fmt.epr "Email not found: %s@." email_id_str;
641
-
exit 1
642
-
| email :: _ ->
643
-
let thread_id = match email.thread_id with
644
-
| Some id -> id
645
-
| None ->
646
-
Fmt.epr "Email has no thread ID@.";
647
-
exit 1
648
-
in
649
-
Jmap_eio.Cli.debug cfg "Thread ID: %s" (Jmap.Proto.Id.to_string thread_id);
650
-
651
-
(* Get the thread *)
652
-
let thread_inv = Jmap_eio.Client.Build.thread_get
653
-
~call_id:"t1"
654
-
~account_id
655
-
~ids:[thread_id]
656
-
()
657
-
in
658
-
let req2 = Jmap_eio.Client.Build.(
659
-
make_request
660
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
661
-
[thread_inv]
662
-
) in
663
-
664
-
match Jmap_eio.Client.request client req2 with
665
-
| Error e ->
666
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
667
-
exit 1
668
-
| Ok response2 ->
669
-
match Jmap_eio.Client.Parse.parse_thread_get ~call_id:"t1" response2 with
670
-
| Error e ->
671
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
672
-
exit 1
673
-
| Ok thread_result ->
674
-
match thread_result.list with
675
-
| [] ->
676
-
Fmt.epr "Thread not found@.";
677
-
exit 1
678
-
| thread :: _ ->
679
-
let thread_id_str = match thread.id with
680
-
| Some id -> Jmap.Proto.Id.to_string id
681
-
| None -> "?"
682
-
in
683
-
let email_ids = Option.value ~default:[] thread.email_ids in
684
-
Fmt.pr "@[<v>%a %s (%d emails)@,@,"
685
-
Fmt.(styled `Bold string) "Thread"
686
-
thread_id_str
687
-
(List.length email_ids);
688
-
689
-
(* Fetch all emails in thread *)
690
-
let get_inv2 = Jmap_eio.Client.Build.email_get
691
-
~call_id:"e2"
692
-
~account_id
693
-
~ids:email_ids
694
-
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
695
-
"size"; "receivedAt"; "subject"; "from"; "preview"]
696
-
()
697
-
in
698
-
let req3 = Jmap_eio.Client.Build.(
699
-
make_request
700
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
701
-
[get_inv2]
702
-
) in
703
-
704
-
match Jmap_eio.Client.request client req3 with
705
-
| Error e ->
706
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
707
-
exit 1
708
-
| Ok response3 ->
709
-
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"e2" response3 with
710
-
| Error e ->
711
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
712
-
exit 1
713
-
| Ok emails_result ->
714
-
List.iter (fun (email : Jmap.Proto.Email.t) ->
715
-
let from_str = match email.from with
716
-
| Some addrs -> format_email_addresses addrs
717
-
| None -> "(unknown)"
718
-
in
719
-
let subject = Option.value email.subject ~default:"(no subject)" in
720
-
Fmt.pr " %a %s@,"
721
-
Fmt.(styled `Cyan string) (email_id email)
722
-
(email_received_at email);
723
-
Fmt.pr " From: %s@," (truncate_string 60 from_str);
724
-
Fmt.pr " Subject: %a@,@,"
725
-
Fmt.(styled `White string) (truncate_string 60 subject);
726
-
) emails_result.list;
727
-
Fmt.pr "@]@."
728
-
in
729
-
let doc = "Show email thread" in
730
-
let info = Cmd.info "thread" ~doc in
731
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_id_term)
732
-
733
-
(** {1 Identities Command} *)
734
-
735
-
let identities_cmd =
736
-
let run cfg =
737
-
Eio_main.run @@ fun env ->
738
-
Eio.Switch.run @@ fun sw ->
739
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
740
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
741
-
742
-
let req = Jmap_eio.Client.Build.(
743
-
make_request
744
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail;
745
-
Jmap.Proto.Capability.submission]
746
-
[identity_get ~call_id:"i1" ~account_id ()]
747
-
) in
748
-
749
-
match Jmap_eio.Client.request client req with
750
-
| Error e ->
751
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
752
-
exit 1
753
-
| Ok response ->
754
-
match Jmap_eio.Client.Parse.parse_response ~call_id:"i1"
755
-
(Jmap_eio.Client.Parse.get_response Jmap.Proto.Identity.jsont)
756
-
response with
757
-
| Error e ->
758
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
759
-
exit 1
760
-
| Ok result ->
761
-
Fmt.pr "@[<v>%a (state: %s)@,@,"
762
-
Fmt.(styled `Bold string) "Identities"
763
-
result.state;
764
-
List.iter (fun (ident : Jmap.Proto.Identity.t) ->
765
-
let ident_id = match ident.id with Some id -> Jmap.Proto.Id.to_string id | None -> "?" in
766
-
let ident_name = Option.value ~default:"(unnamed)" ident.name in
767
-
let ident_email = Option.value ~default:"(no email)" ident.email in
768
-
let ident_sig = Option.value ~default:"" ident.text_signature in
769
-
let ident_may_delete = Option.value ~default:false ident.may_delete in
770
-
Fmt.pr " %a@,"
771
-
Fmt.(styled `Cyan string) ident_id;
772
-
Fmt.pr " Name: %s@," ident_name;
773
-
Fmt.pr " Email: %a@,"
774
-
Fmt.(styled `Green string) ident_email;
775
-
if ident_sig <> "" then
776
-
Fmt.pr " Signature: %s@," (truncate_string 50 ident_sig);
777
-
Fmt.pr " May delete: %b@,@," ident_may_delete
778
-
) result.list;
779
-
Fmt.pr "@]@."
780
-
in
781
-
let doc = "List email identities" in
782
-
let info = Cmd.info "identities" ~doc in
783
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term)
784
-
785
-
(** {1 Chained Commands - Using the Chain monad} *)
786
-
787
-
(** Inbox command - demonstrates simple query+get chain *)
788
-
let inbox_cmd =
789
-
let limit_term =
790
-
let doc = "Maximum number of emails to show" in
791
-
Arg.(value & opt int 20 & info ["limit"; "n"] ~docv:"N" ~doc)
792
-
in
793
-
let run cfg limit =
794
-
Eio_main.run @@ fun env ->
795
-
Eio.Switch.run @@ fun sw ->
796
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
797
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
798
-
799
-
Jmap_eio.Cli.debug cfg "Fetching inbox emails using Chain API";
800
-
801
-
(* Find inbox mailbox first *)
802
-
let mbox_req = Jmap_eio.Client.Build.(
803
-
make_request
804
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
805
-
[mailbox_get ~call_id:"m1" ~account_id ()]
806
-
) in
807
-
808
-
match Jmap_eio.Client.request client mbox_req with
809
-
| Error e ->
810
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
811
-
exit 1
812
-
| Ok mbox_response ->
813
-
match Jmap_eio.Client.Parse.parse_mailbox_get ~call_id:"m1" mbox_response with
814
-
| Error e ->
815
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
816
-
exit 1
817
-
| Ok mbox_result ->
818
-
(* Find inbox *)
819
-
let inbox =
820
-
List.find_opt (fun (m : Jmap.Proto.Mailbox.t) ->
821
-
m.role = Some `Inbox
822
-
) mbox_result.list
823
-
in
824
-
match inbox with
825
-
| None ->
826
-
Fmt.epr "No inbox found@.";
827
-
exit 1
828
-
| Some inbox ->
829
-
let inbox_id = match inbox.id with
830
-
| Some id -> id
831
-
| None ->
832
-
Fmt.epr "Inbox has no ID@.";
833
-
exit 1
834
-
in
835
-
Jmap_eio.Cli.debug cfg "Found inbox: %s" (Jmap.Proto.Id.to_string inbox_id);
836
-
837
-
(* Now use Chain API to query and get emails in one request *)
838
-
let open Jmap_eio.Chain in
839
-
let filter_cond : Jmap.Proto.Email.Filter_condition.t = {
840
-
in_mailbox = Some inbox_id;
841
-
in_mailbox_other_than = None;
842
-
before = None; after = None;
843
-
min_size = None; max_size = None;
844
-
all_in_thread_have_keyword = None;
845
-
some_in_thread_have_keyword = None;
846
-
none_in_thread_have_keyword = None;
847
-
has_keyword = None; not_keyword = None;
848
-
has_attachment = None;
849
-
text = None; from = None; to_ = None;
850
-
cc = None; bcc = None; subject = None;
851
-
body = None; header = None;
852
-
} in
853
-
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
854
-
855
-
let request, email_handle = build
856
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
857
-
begin
858
-
let* query = email_query ~account_id
859
-
~filter:(Jmap.Proto.Filter.Condition filter_cond)
860
-
~sort
861
-
~limit:(Int64.of_int limit)
862
-
()
863
-
in
864
-
let* emails = email_get ~account_id
865
-
~ids:(from_query query)
866
-
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "preview"; "keywords"]
867
-
()
868
-
in
869
-
return emails
870
-
end in
871
-
872
-
Jmap_eio.Cli.debug cfg "Sending chained request (query + get in one round trip)";
873
-
874
-
match Jmap_eio.Client.request client request with
875
-
| Error e ->
876
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
877
-
exit 1
878
-
| Ok response ->
879
-
match parse email_handle response with
880
-
| Error e ->
881
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
882
-
exit 1
883
-
| Ok result ->
884
-
Fmt.pr "@[<v>%a (%d emails in inbox)@,@,"
885
-
Fmt.(styled `Bold string) "Inbox"
886
-
(List.length result.list);
887
-
List.iter (fun (email : Jmap.Proto.Email.t) ->
888
-
let from_str = match email.from with
889
-
| Some (addr :: _) ->
890
-
Option.value addr.name ~default:addr.email
891
-
| _ -> "?"
892
-
in
893
-
let subject = Option.value email.subject ~default:"(no subject)" in
894
-
let flags = format_keywords (email_keywords email) in
895
-
Fmt.pr " %a %s@,"
896
-
Fmt.(styled `Cyan string) (email_id email)
897
-
(email_received_at email);
898
-
Fmt.pr " From: %s@," (truncate_string 40 from_str);
899
-
Fmt.pr " Subject: %a%s@,"
900
-
Fmt.(styled `White string) (truncate_string 50 subject)
901
-
(if flags = "" then "" else " [" ^ flags ^ "]");
902
-
Fmt.pr "@,"
903
-
) result.list;
904
-
Fmt.pr "@]@."
905
-
in
906
-
let doc = "List inbox emails (uses Chain API for query+get in single request)" in
907
-
let info = Cmd.info "inbox" ~doc in
908
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ limit_term)
909
-
910
-
(** Thread-view command - demonstrates multi-step chaining (RFC 8620 example) *)
911
-
let thread_view_cmd =
912
-
let limit_term =
913
-
let doc = "Number of threads to show" in
914
-
Arg.(value & opt int 10 & info ["limit"; "n"] ~docv:"N" ~doc)
915
-
in
916
-
let run cfg limit =
917
-
Eio_main.run @@ fun env ->
918
-
Eio.Switch.run @@ fun sw ->
919
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
920
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
921
-
922
-
Jmap_eio.Cli.debug cfg "Fetching threaded view using multi-step Chain API";
923
-
924
-
(*
925
-
This implements the RFC 8620 example:
926
-
1. Email/query with collapseThreads to get one email per thread
927
-
2. Email/get to fetch threadId for each
928
-
3. Thread/get to fetch all emailIds in each thread
929
-
4. Email/get to fetch details for all emails in those threads
930
-
*)
931
-
let open Jmap_eio.Chain in
932
-
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
933
-
934
-
let request, (query_h, final_emails_h) = build
935
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
936
-
begin
937
-
(* Step 1: Query for recent emails, collapsing threads *)
938
-
let* query = email_query ~account_id
939
-
~sort
940
-
~collapse_threads:true
941
-
~limit:(Int64.of_int limit)
942
-
()
943
-
in
944
-
(* Step 2: Get just threadId for those emails *)
945
-
let* emails1 = email_get ~account_id
946
-
~ids:(from_query query)
947
-
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"]
948
-
()
949
-
in
950
-
(* Step 3: Get threads using threadIds from step 2 *)
951
-
let* threads = thread_get ~account_id
952
-
~ids:(from_get_field emails1 "threadId")
953
-
()
954
-
in
955
-
(* Step 4: Get all emails in those threads *)
956
-
let* emails2 = email_get ~account_id
957
-
~ids:(from_get_field threads "emailIds")
958
-
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "preview"]
959
-
()
960
-
in
961
-
return (query, emails2)
962
-
end in
963
-
964
-
Jmap_eio.Cli.debug cfg "Sending 4-step chained request in single round trip";
965
-
966
-
match Jmap_eio.Client.request client request with
967
-
| Error e ->
968
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
969
-
exit 1
970
-
| Ok response ->
971
-
let query_result = parse_exn query_h response in
972
-
let emails_result = parse_exn final_emails_h response in
973
-
974
-
(* Group emails by thread *)
975
-
let threads_map = Hashtbl.create 16 in
976
-
List.iter (fun (email : Jmap.Proto.Email.t) ->
977
-
let tid = email_thread_id email in
978
-
let existing = try Hashtbl.find threads_map tid with Not_found -> [] in
979
-
Hashtbl.replace threads_map tid (email :: existing)
980
-
) emails_result.list;
981
-
982
-
Fmt.pr "@[<v>%a (%d threads, %d total emails)@,@,"
983
-
Fmt.(styled `Bold string) "Threaded View"
984
-
(Hashtbl.length threads_map)
985
-
(List.length emails_result.list);
986
-
Fmt.pr "Query found %s total matching emails@,@,"
987
-
(match query_result.total with Some n -> Int64.to_string n | None -> "?");
988
-
989
-
(* Print threads *)
990
-
Hashtbl.iter (fun _tid emails ->
991
-
let emails = List.sort (fun (a : Jmap.Proto.Email.t) (b : Jmap.Proto.Email.t) ->
992
-
let a_time = Option.value ~default:Ptime.epoch a.received_at in
993
-
let b_time = Option.value ~default:Ptime.epoch b.received_at in
994
-
Ptime.compare a_time b_time
995
-
) emails in
996
-
let first_email = List.hd emails in
997
-
let subject = Option.value first_email.subject ~default:"(no subject)" in
998
-
Fmt.pr " %a Thread: %s (%d emails)@,"
999
-
Fmt.(styled `Bold string) "โธ"
1000
-
(truncate_string 50 subject)
1001
-
(List.length emails);
1002
-
List.iter (fun (email : Jmap.Proto.Email.t) ->
1003
-
let from_str = match email.from with
1004
-
| Some (addr :: _) -> Option.value addr.name ~default:addr.email
1005
-
| _ -> "?"
1006
-
in
1007
-
Fmt.pr " %s %s %s@,"
1008
-
(email_id email |> truncate_string 12)
1009
-
(email_received_at email)
1010
-
(truncate_string 30 from_str)
1011
-
) emails;
1012
-
Fmt.pr "@,"
1013
-
) threads_map;
1014
-
Fmt.pr "@]@."
1015
-
in
1016
-
let doc = "Show threaded view (demonstrates RFC 8620 multi-step chain)" in
1017
-
let info = Cmd.info "thread-view" ~doc in
1018
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ limit_term)
1019
-
1020
-
(** Mark-read command - demonstrates email_set for updating keywords *)
1021
-
let mark_read_cmd =
1022
-
let email_id_term =
1023
-
let doc = "Email ID to mark as read" in
1024
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"EMAIL_ID" ~doc)
1025
-
in
1026
-
let unread_term =
1027
-
let doc = "Mark as unread instead of read" in
1028
-
Arg.(value & flag & info ["unread"; "u"] ~doc)
1029
-
in
1030
-
let run cfg email_id_str unread =
1031
-
Eio_main.run @@ fun env ->
1032
-
Eio.Switch.run @@ fun sw ->
1033
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1034
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1035
-
let email_id = Jmap.Proto.Id.of_string_exn email_id_str in
1036
-
1037
-
Jmap_eio.Cli.debug cfg "%s email %s"
1038
-
(if unread then "Marking as unread" else "Marking as read")
1039
-
email_id_str;
1040
-
1041
-
(* Build the patch object - set or unset $seen keyword *)
1042
-
let patch =
1043
-
let open Jmap_eio.Chain in
1044
-
if unread then
1045
-
json_obj [("keywords/$seen", json_null)]
1046
-
else
1047
-
json_obj [("keywords/$seen", json_bool true)]
1048
-
in
1049
-
1050
-
let open Jmap_eio.Chain in
1051
-
let request, set_h = build
1052
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1053
-
begin
1054
-
email_set ~account_id
1055
-
~update:[(email_id, patch)]
1056
-
()
1057
-
end in
1058
-
1059
-
match Jmap_eio.Client.request client request with
1060
-
| Error e ->
1061
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1062
-
exit 1
1063
-
| Ok response ->
1064
-
match parse set_h response with
1065
-
| Error e ->
1066
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1067
-
exit 1
1068
-
| Ok result ->
1069
-
(* Check if update succeeded *)
1070
-
let updated_ids =
1071
-
result.updated
1072
-
|> Option.value ~default:[]
1073
-
|> List.map (fun (id, _) -> Jmap.Proto.Id.to_string id)
1074
-
in
1075
-
if List.mem email_id_str updated_ids then
1076
-
Fmt.pr "Email %s marked as %s@."
1077
-
email_id_str
1078
-
(if unread then "unread" else "read")
1079
-
else (
1080
-
Fmt.epr "Failed to update email. ";
1081
-
let not_updated = Option.value ~default:[] result.not_updated in
1082
-
(match List.find_opt (fun (id, _) -> Jmap.Proto.Id.to_string id = email_id_str) not_updated with
1083
-
| Some (_, err) ->
1084
-
let open Jmap.Proto.Error in
1085
-
let err_type = set_error_type_to_string err.type_ in
1086
-
let err_desc = Option.value ~default:"" err.description in
1087
-
Fmt.epr "Error: %s (%s)@." err_type err_desc
1088
-
| None ->
1089
-
Fmt.epr "Unknown error@.");
1090
-
exit 1
1091
-
)
1092
-
in
1093
-
let doc = "Mark an email as read/unread (demonstrates Email/set)" in
1094
-
let info = Cmd.info "mark-read" ~doc in
1095
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_id_term $ unread_term)
1096
-
1097
-
(** Delete email command - demonstrates email_set destroy *)
1098
-
let delete_email_cmd =
1099
-
let email_ids_term =
1100
-
let doc = "Email IDs to delete" in
1101
-
Arg.(non_empty & pos_all string [] & info [] ~docv:"EMAIL_ID" ~doc)
1102
-
in
1103
-
let run cfg email_id_strs =
1104
-
Eio_main.run @@ fun env ->
1105
-
Eio.Switch.run @@ fun sw ->
1106
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1107
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1108
-
let email_ids = List.map Jmap.Proto.Id.of_string_exn email_id_strs in
1109
-
1110
-
Jmap_eio.Cli.debug cfg "Deleting %d email(s)" (List.length email_ids);
1111
-
1112
-
let open Jmap_eio.Chain in
1113
-
let request, set_h = build
1114
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1115
-
begin
1116
-
email_set ~account_id
1117
-
~destroy:(ids email_ids)
1118
-
()
1119
-
end in
1120
-
1121
-
match Jmap_eio.Client.request client request with
1122
-
| Error e ->
1123
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1124
-
exit 1
1125
-
| Ok response ->
1126
-
match parse set_h response with
1127
-
| Error e ->
1128
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1129
-
exit 1
1130
-
| Ok result ->
1131
-
let destroyed = Option.value ~default:[] result.destroyed in
1132
-
let destroyed_ids = List.map Jmap.Proto.Id.to_string destroyed in
1133
-
Fmt.pr "Deleted %d email(s):@." (List.length destroyed_ids);
1134
-
List.iter (fun id -> Fmt.pr " %s@." id) destroyed_ids;
1135
-
(* Report any failures *)
1136
-
let not_destroyed = Option.value ~default:[] result.not_destroyed in
1137
-
if not_destroyed <> [] then begin
1138
-
Fmt.epr "Failed to delete %d email(s):@." (List.length not_destroyed);
1139
-
List.iter (fun (id, err) ->
1140
-
let open Jmap.Proto.Error in
1141
-
let err_type = set_error_type_to_string err.type_ in
1142
-
Fmt.epr " %s: %s@."
1143
-
(Jmap.Proto.Id.to_string id)
1144
-
err_type
1145
-
) not_destroyed
1146
-
end
1147
-
in
1148
-
let doc = "Delete emails (demonstrates Email/set destroy)" in
1149
-
let info = Cmd.info "delete" ~doc in
1150
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_ids_term)
1151
-
1152
-
(** Changes command - demonstrates email_changes for sync *)
1153
-
let changes_cmd =
1154
-
let state_term =
1155
-
let doc = "State to get changes since (use 'current' to just show current state)" in
1156
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"STATE" ~doc)
1157
-
in
1158
-
let run cfg state_str =
1159
-
Eio_main.run @@ fun env ->
1160
-
Eio.Switch.run @@ fun sw ->
1161
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1162
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1163
-
1164
-
if state_str = "current" then (
1165
-
(* Just get current state by doing a minimal query *)
1166
-
let open Jmap_eio.Chain in
1167
-
let request, get_h = build
1168
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1169
-
begin
1170
-
(* Get empty list just to see state *)
1171
-
email_get ~account_id ~ids:(ids []) ()
1172
-
end in
1173
-
1174
-
match Jmap_eio.Client.request client request with
1175
-
| Error e ->
1176
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1177
-
exit 1
1178
-
| Ok response ->
1179
-
match parse get_h response with
1180
-
| Error e ->
1181
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1182
-
exit 1
1183
-
| Ok result ->
1184
-
Fmt.pr "Current email state: %a@."
1185
-
Fmt.(styled `Cyan string) result.state
1186
-
) else (
1187
-
Jmap_eio.Cli.debug cfg "Getting changes since state: %s" state_str;
1188
-
1189
-
let open Jmap_eio.Chain in
1190
-
let request, changes_h = build
1191
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1192
-
begin
1193
-
email_changes ~account_id ~since_state:state_str ()
1194
-
end in
1195
-
1196
-
match Jmap_eio.Client.request client request with
1197
-
| Error e ->
1198
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1199
-
exit 1
1200
-
| Ok response ->
1201
-
match parse changes_h response with
1202
-
| Error e ->
1203
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1204
-
exit 1
1205
-
| Ok result ->
1206
-
Fmt.pr "@[<v>%a@,@,"
1207
-
Fmt.(styled `Bold string) "Email Changes";
1208
-
Fmt.pr "Old state: %s@," result.old_state;
1209
-
Fmt.pr "New state: %a@," Fmt.(styled `Cyan string) result.new_state;
1210
-
Fmt.pr "Has more changes: %b@,@," result.has_more_changes;
1211
-
Fmt.pr "Created: %d email(s)@," (List.length result.created);
1212
-
List.iter (fun id ->
1213
-
Fmt.pr " + %s@," (Jmap.Proto.Id.to_string id)
1214
-
) result.created;
1215
-
Fmt.pr "Updated: %d email(s)@," (List.length result.updated);
1216
-
List.iter (fun id ->
1217
-
Fmt.pr " ~ %s@," (Jmap.Proto.Id.to_string id)
1218
-
) result.updated;
1219
-
Fmt.pr "Destroyed: %d email(s)@," (List.length result.destroyed);
1220
-
List.iter (fun id ->
1221
-
Fmt.pr " - %s@," (Jmap.Proto.Id.to_string id)
1222
-
) result.destroyed;
1223
-
Fmt.pr "@]@."
1224
-
)
1225
-
in
1226
-
let doc = "Show email changes since a state (demonstrates Email/changes)" in
1227
-
let info = Cmd.info "changes" ~doc in
1228
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ state_term)
1229
-
1230
-
(** Sync command - demonstrates changes + get pattern for incremental sync *)
1231
-
let sync_cmd =
1232
-
let state_term =
1233
-
let doc = "State to sync from" in
1234
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"STATE" ~doc)
1235
-
in
1236
-
let run cfg state_str =
1237
-
Eio_main.run @@ fun env ->
1238
-
Eio.Switch.run @@ fun sw ->
1239
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1240
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1241
-
1242
-
Jmap_eio.Cli.debug cfg "Syncing from state: %s" state_str;
1243
-
1244
-
(* Chain: changes โ get created โ get updated *)
1245
-
let open Jmap_eio.Chain in
1246
-
let request, (changes_h, created_h, updated_h) = build
1247
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1248
-
begin
1249
-
let* changes = email_changes ~account_id ~since_state:state_str () in
1250
-
let* created = email_get ~account_id
1251
-
~ids:(from_changes_created changes)
1252
-
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "preview"]
1253
-
()
1254
-
in
1255
-
let* updated = email_get ~account_id
1256
-
~ids:(from_changes_updated changes)
1257
-
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "size"; "receivedAt"; "subject"; "from"; "keywords"]
1258
-
()
1259
-
in
1260
-
return (changes, created, updated)
1261
-
end in
1262
-
1263
-
Jmap_eio.Cli.debug cfg "Sending chained sync request";
1264
-
1265
-
match Jmap_eio.Client.request client request with
1266
-
| Error e ->
1267
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1268
-
exit 1
1269
-
| Ok response ->
1270
-
let changes_result = parse_exn changes_h response in
1271
-
let created_result = parse_exn created_h response in
1272
-
let updated_result = parse_exn updated_h response in
1273
-
1274
-
Fmt.pr "@[<v>%a (state: %s โ %s)@,@,"
1275
-
Fmt.(styled `Bold string) "Sync Results"
1276
-
changes_result.old_state
1277
-
changes_result.new_state;
1278
-
1279
-
if List.length created_result.list > 0 then begin
1280
-
Fmt.pr "%a (%d)@,"
1281
-
Fmt.(styled `Green string) "New emails"
1282
-
(List.length created_result.list);
1283
-
List.iter (fun (email : Jmap.Proto.Email.t) ->
1284
-
let from_str = match email.from with
1285
-
| Some (addr :: _) -> Option.value addr.name ~default:addr.email
1286
-
| _ -> "?"
1287
-
in
1288
-
let subject = Option.value email.subject ~default:"(no subject)" in
1289
-
Fmt.pr " + %s %s %s@,"
1290
-
(email_id email |> truncate_string 12)
1291
-
(truncate_string 20 from_str)
1292
-
(truncate_string 40 subject)
1293
-
) created_result.list;
1294
-
Fmt.pr "@,"
1295
-
end;
1296
-
1297
-
if List.length updated_result.list > 0 then begin
1298
-
Fmt.pr "%a (%d)@,"
1299
-
Fmt.(styled `Yellow string) "Updated emails"
1300
-
(List.length updated_result.list);
1301
-
List.iter (fun (email : Jmap.Proto.Email.t) ->
1302
-
let flags = format_keywords (email_keywords email) in
1303
-
Fmt.pr " ~ %s [%s]@,"
1304
-
(email_id email |> truncate_string 12)
1305
-
flags
1306
-
) updated_result.list;
1307
-
Fmt.pr "@,"
1308
-
end;
1309
-
1310
-
if List.length changes_result.destroyed > 0 then begin
1311
-
Fmt.pr "%a (%d)@,"
1312
-
Fmt.(styled `Red string) "Deleted emails"
1313
-
(List.length changes_result.destroyed);
1314
-
List.iter (fun id ->
1315
-
Fmt.pr " - %s@," (Jmap.Proto.Id.to_string id)
1316
-
) changes_result.destroyed;
1317
-
Fmt.pr "@,"
1318
-
end;
1319
-
1320
-
if changes_result.has_more_changes then
1321
-
Fmt.pr "%a - call sync again with state %s@,"
1322
-
Fmt.(styled `Bold string) "More changes available"
1323
-
changes_result.new_state;
1324
-
1325
-
Fmt.pr "@]@."
1326
-
in
1327
-
let doc = "Incremental sync (demonstrates changes + get chain)" in
1328
-
let info = Cmd.info "sync" ~doc in
1329
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ state_term)
1330
-
1331
-
(** Headers command - demonstrates RFC 8621 ยง4.1 header property queries *)
1332
-
let headers_cmd =
1333
-
let email_id_term =
1334
-
let doc = "Email ID to get headers for" in
1335
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"EMAIL_ID" ~doc)
1336
-
in
1337
-
1338
-
(* Format a header value for display *)
1339
-
let format_header_value = function
1340
-
| Jmap.Proto.Email_header.String_single None -> "(null)"
1341
-
| Jmap.Proto.Email_header.String_single (Some s) -> s
1342
-
| Jmap.Proto.Email_header.String_all [] -> "(empty list)"
1343
-
| Jmap.Proto.Email_header.String_all strs -> String.concat "; " strs
1344
-
| Jmap.Proto.Email_header.Addresses_single None -> "(null)"
1345
-
| Jmap.Proto.Email_header.Addresses_single (Some []) -> "(empty)"
1346
-
| Jmap.Proto.Email_header.Addresses_single (Some addrs) ->
1347
-
String.concat ", " (List.map (fun a ->
1348
-
match a.Jmap.Proto.Email_address.name with
1349
-
| Some n -> Printf.sprintf "%s <%s>" n a.email
1350
-
| None -> a.email
1351
-
) addrs)
1352
-
| Jmap.Proto.Email_header.Addresses_all [] -> "(empty list)"
1353
-
| Jmap.Proto.Email_header.Addresses_all groups ->
1354
-
String.concat " | " (List.map (fun addrs ->
1355
-
String.concat ", " (List.map (fun a ->
1356
-
match a.Jmap.Proto.Email_address.name with
1357
-
| Some n -> Printf.sprintf "%s <%s>" n a.email
1358
-
| None -> a.email
1359
-
) addrs)
1360
-
) groups)
1361
-
| Jmap.Proto.Email_header.Grouped_single None -> "(null)"
1362
-
| Jmap.Proto.Email_header.Grouped_single (Some groups) ->
1363
-
String.concat "; " (List.map (fun g ->
1364
-
let name = Option.value ~default:"(ungrouped)" g.Jmap.Proto.Email_address.Group.name in
1365
-
let addrs = String.concat ", " (List.map (fun a ->
1366
-
match a.Jmap.Proto.Email_address.name with
1367
-
| Some n -> Printf.sprintf "%s <%s>" n a.email
1368
-
| None -> a.email
1369
-
) g.addresses) in
1370
-
Printf.sprintf "%s: %s" name addrs
1371
-
) groups)
1372
-
| Jmap.Proto.Email_header.Grouped_all _ -> "(grouped addresses list)"
1373
-
| Jmap.Proto.Email_header.Date_single None -> "(null)"
1374
-
| Jmap.Proto.Email_header.Date_single (Some t) -> ptime_to_string t
1375
-
| Jmap.Proto.Email_header.Date_all [] -> "(empty list)"
1376
-
| Jmap.Proto.Email_header.Date_all dates ->
1377
-
String.concat "; " (List.map (function
1378
-
| None -> "(null)"
1379
-
| Some t -> ptime_to_string t
1380
-
) dates)
1381
-
| Jmap.Proto.Email_header.Strings_single None -> "(null)"
1382
-
| Jmap.Proto.Email_header.Strings_single (Some []) -> "(empty)"
1383
-
| Jmap.Proto.Email_header.Strings_single (Some strs) -> String.concat ", " strs
1384
-
| Jmap.Proto.Email_header.Strings_all [] -> "(empty list)"
1385
-
| Jmap.Proto.Email_header.Strings_all groups ->
1386
-
String.concat " | " (List.map (function
1387
-
| None -> "(null)"
1388
-
| Some strs -> String.concat ", " strs
1389
-
) groups)
1390
-
in
1391
-
1392
-
let run cfg email_id_str =
1393
-
Eio_main.run @@ fun env ->
1394
-
Eio.Switch.run @@ fun sw ->
1395
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
1396
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
1397
-
let target_email_id = Jmap.Proto.Id.of_string_exn email_id_str in
1398
-
1399
-
Jmap_eio.Cli.debug cfg "Fetching headers for email %s" email_id_str;
1400
-
1401
-
(* Demonstrate various header forms from RFC 8621 ยง4.1.2:
1402
-
- header:name - Raw value
1403
-
- header:name:asText - Text decoded
1404
-
- header:name:asAddresses - Address list
1405
-
- header:name:asGroupedAddresses - Address groups
1406
-
- header:name:asMessageIds - Message-ID list
1407
-
- header:name:asDate - RFC 3339 date
1408
-
- header:name:asURLs - URL list
1409
-
- header:name:all - All values (not just first)
1410
-
*)
1411
-
let header_props = [
1412
-
(* Raw and text forms *)
1413
-
"header:Subject";
1414
-
"header:Subject:asText";
1415
-
(* Address headers *)
1416
-
"header:From:asAddresses";
1417
-
"header:To:asAddresses";
1418
-
"header:Cc:asAddresses";
1419
-
"header:Bcc:asAddresses";
1420
-
"header:Reply-To:asAddresses";
1421
-
"header:Sender:asAddresses";
1422
-
(* Grouped addresses *)
1423
-
"header:From:asGroupedAddresses";
1424
-
(* Message ID headers *)
1425
-
"header:Message-ID:asMessageIds";
1426
-
"header:In-Reply-To:asMessageIds";
1427
-
"header:References:asMessageIds";
1428
-
(* Date header *)
1429
-
"header:Date:asDate";
1430
-
(* List headers as URLs *)
1431
-
"header:List-Unsubscribe:asURLs";
1432
-
"header:List-Post:asURLs";
1433
-
"header:List-Archive:asURLs";
1434
-
(* Custom headers *)
1435
-
"header:X-Mailer:asText";
1436
-
"header:X-Priority";
1437
-
"header:X-Spam-Status:asText";
1438
-
"header:Content-Type";
1439
-
"header:MIME-Version";
1440
-
(* Get all Received headers (typically multiple) *)
1441
-
"header:Received:all";
1442
-
] in
1443
-
1444
-
let properties = "id" :: "threadId" :: "subject" :: header_props in
1445
-
1446
-
let get_inv = Jmap_eio.Client.Build.email_get
1447
-
~call_id:"h1"
1448
-
~account_id
1449
-
~ids:[target_email_id]
1450
-
~properties
1451
-
()
1452
-
in
1453
-
let req = Jmap_eio.Client.Build.(
1454
-
make_request
1455
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
1456
-
[get_inv]
1457
-
) in
1458
-
1459
-
match Jmap_eio.Client.request client req with
1460
-
| Error e ->
1461
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
1462
-
exit 1
1463
-
| Ok response ->
1464
-
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"h1" response with
1465
-
| Error e ->
1466
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
1467
-
exit 1
1468
-
| Ok email_result ->
1469
-
match email_result.list with
1470
-
| [] ->
1471
-
Fmt.epr "Email not found: %s@." email_id_str;
1472
-
exit 1
1473
-
| email :: _ ->
1474
-
Fmt.pr "@[<v>%a@," Fmt.(styled `Bold string) "Email Headers (RFC 8621 ยง4.1)";
1475
-
Fmt.pr "ID: %s@," (email_id email);
1476
-
Fmt.pr "Thread: %s@," (email_thread_id email);
1477
-
(match email.subject with
1478
-
| Some s -> Fmt.pr "Subject (convenience): %s@," s
1479
-
| None -> ());
1480
-
Fmt.pr "@,";
1481
-
1482
-
(* Print dynamic headers grouped by category *)
1483
-
let raw_headers = Jmap.Proto.Email.dynamic_headers_raw email in
1484
-
if raw_headers = [] then
1485
-
Fmt.pr "%a@," Fmt.(styled `Yellow string) "No dynamic headers returned"
1486
-
else begin
1487
-
Fmt.pr "%a (%d properties)@,@,"
1488
-
Fmt.(styled `Bold string) "Dynamic Header Properties"
1489
-
(List.length raw_headers);
1490
-
1491
-
List.iter (fun (name, json) ->
1492
-
match Jmap.Proto.Email.decode_header_value name json with
1493
-
| None ->
1494
-
Fmt.pr " %a: (decode failed)@,"
1495
-
Fmt.(styled `Red string) name
1496
-
| Some value ->
1497
-
let formatted = format_header_value value in
1498
-
if String.length formatted > 80 then
1499
-
Fmt.pr " %a:@, %s@,"
1500
-
Fmt.(styled `Cyan string) name
1501
-
formatted
1502
-
else
1503
-
Fmt.pr " %a: %s@,"
1504
-
Fmt.(styled `Cyan string) name
1505
-
formatted
1506
-
) raw_headers
1507
-
end;
1508
-
Fmt.pr "@]@."
1509
-
in
1510
-
let doc = "Show email headers in various forms (demonstrates RFC 8621 ยง4.1)" in
1511
-
let info = Cmd.info "headers" ~doc in
1512
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ email_id_term)
1513
-
1514
-
(** {1 Main Command Group} *)
1515
-
1516
-
let main_cmd =
1517
-
let doc = "JMAP command-line client" in
1518
-
let man = [
1519
-
`S Manpage.s_description;
1520
-
`P "A command-line client for JMAP (JSON Meta Application Protocol) email servers.";
1521
-
`S Manpage.s_environment;
1522
-
`P Jmap_eio.Cli.env_docs;
1523
-
`S Manpage.s_examples;
1524
-
`P "List mailboxes:";
1525
-
`Pre " jmap mailboxes --url https://api.fastmail.com/jmap/session -k YOUR_API_KEY";
1526
-
`P "Show recent emails:";
1527
-
`Pre " jmap recent -n 50 --format detailed";
1528
-
`P "Search emails:";
1529
-
`Pre " jmap search \"meeting notes\" -n 10";
1530
-
] in
1531
-
let info = Cmd.info "jmap" ~version:"0.1.0" ~doc ~man in
1532
-
Cmd.group info [
1533
-
session_cmd;
1534
-
mailboxes_cmd;
1535
-
emails_cmd;
1536
-
search_cmd;
1537
-
recent_cmd;
1538
-
threads_cmd;
1539
-
identities_cmd;
1540
-
headers_cmd;
1541
-
(* Chain API examples *)
1542
-
inbox_cmd;
1543
-
thread_view_cmd;
1544
-
mark_read_cmd;
1545
-
delete_email_cmd;
1546
-
changes_cmd;
1547
-
sync_cmd;
1548
-
]
1549
-
1550
-
let () =
1551
-
Fmt_tty.setup_std_outputs ();
1552
-
exit (Cmd.eval main_cmd)
+245
bin/jmap_blob_downloader.ml
+245
bin/jmap_blob_downloader.ml
···
1
+
(*
2
+
* jmap_blob_downloader.ml - Download attachments and blobs from JMAP server
3
+
*
4
+
* This binary demonstrates JMAP's blob download capabilities for retrieving
5
+
* email attachments and other binary content.
6
+
*
7
+
* For step 2, we're only testing type checking. No implementations required.
8
+
*)
9
+
10
+
open Cmdliner
11
+
12
+
(** Command-line arguments **)
13
+
14
+
let host_arg =
15
+
Arg.(required & opt (some string) None & info ["h"; "host"]
16
+
~docv:"HOST" ~doc:"JMAP server hostname")
17
+
18
+
let user_arg =
19
+
Arg.(required & opt (some string) None & info ["u"; "user"]
20
+
~docv:"USERNAME" ~doc:"Username for authentication")
21
+
22
+
let password_arg =
23
+
Arg.(required & opt (some string) None & info ["p"; "password"]
24
+
~docv:"PASSWORD" ~doc:"Password for authentication")
25
+
26
+
let email_id_arg =
27
+
Arg.(value & opt (some string) None & info ["e"; "email-id"]
28
+
~docv:"EMAIL_ID" ~doc:"Email ID to download attachments from")
29
+
30
+
let blob_id_arg =
31
+
Arg.(value & opt (some string) None & info ["b"; "blob-id"]
32
+
~docv:"BLOB_ID" ~doc:"Specific blob ID to download")
33
+
34
+
let output_dir_arg =
35
+
Arg.(value & opt string "." & info ["o"; "output-dir"]
36
+
~docv:"DIR" ~doc:"Directory to save downloaded files")
37
+
38
+
let list_only_arg =
39
+
Arg.(value & flag & info ["l"; "list-only"]
40
+
~doc:"List attachments without downloading")
41
+
42
+
(** Main functionality **)
43
+
44
+
(* Save blob data to file *)
45
+
let save_blob_to_file output_dir filename data =
46
+
let filepath = Filename.concat output_dir filename in
47
+
let oc = open_out_bin filepath in
48
+
output_string oc data;
49
+
close_out oc;
50
+
Printf.printf "Saved: %s (%d bytes)\n" filepath (String.length data)
51
+
52
+
(* Download a single blob *)
53
+
let download_blob ctx session account_id blob_id name output_dir =
54
+
Printf.printf "Downloading blob %s as '%s'...\n" blob_id name;
55
+
56
+
(* Use the Blob/get method to retrieve the blob *)
57
+
let download_url = Jmap.Session.Session.download_url session in
58
+
let blob_url = Printf.sprintf "%s/%s/%s" (Uri.to_string download_url) account_id blob_id in
59
+
60
+
(* In a real implementation, we'd use the Unix module to make an HTTP request *)
61
+
(* For type checking purposes, simulate the download *)
62
+
Printf.printf " Would download from: %s\n" blob_url;
63
+
Printf.printf " Simulating download...\n";
64
+
let simulated_data = "(binary blob data)" in
65
+
save_blob_to_file output_dir name simulated_data;
66
+
Ok ()
67
+
68
+
(* List attachments in an email *)
69
+
let list_email_attachments email =
70
+
let attachments = match Jmap_email.Types.Email.attachments email with
71
+
| Some parts -> parts
72
+
| None -> []
73
+
in
74
+
75
+
Printf.printf "\nAttachments found:\n";
76
+
if attachments = [] then
77
+
Printf.printf " No attachments in this email\n"
78
+
else
79
+
List.iteri (fun i part ->
80
+
let blob_id = match Jmap_email.Types.Email_body_part.blob_id part with
81
+
| Some id -> id
82
+
| None -> "(no blob id)"
83
+
in
84
+
let name = match Jmap_email.Types.Email_body_part.name part with
85
+
| Some n -> n
86
+
| None -> Printf.sprintf "attachment_%d" (i + 1)
87
+
in
88
+
let size = Jmap_email.Types.Email_body_part.size part in
89
+
let mime_type = Jmap_email.Types.Email_body_part.mime_type part in
90
+
91
+
Printf.printf " %d. %s\n" (i + 1) name;
92
+
Printf.printf " Blob ID: %s\n" blob_id;
93
+
Printf.printf " Type: %s\n" mime_type;
94
+
Printf.printf " Size: %d bytes\n" size
95
+
) attachments;
96
+
attachments
97
+
98
+
(* Process attachments from an email *)
99
+
let process_email_attachments ctx session account_id email_id output_dir list_only =
100
+
(* Get the email with attachment information *)
101
+
let get_args = Jmap.Methods.Get_args.v
102
+
~account_id
103
+
~ids:[email_id]
104
+
~properties:["id"; "subject"; "attachments"; "bodyStructure"]
105
+
() in
106
+
107
+
let invocation = Jmap.Wire.Invocation.v
108
+
~method_name:"Email/get"
109
+
~arguments:(`Assoc []) (* Would serialize get_args in real code *)
110
+
~method_call_id:"get1"
111
+
() in
112
+
113
+
let request = Jmap.Wire.Request.v
114
+
~using:[Jmap.capability_core; Jmap_email.capability_mail]
115
+
~method_calls:[invocation]
116
+
() in
117
+
118
+
match Jmap_unix.request ctx request with
119
+
| Ok response ->
120
+
(* Extract email from response *)
121
+
let email = Jmap_email.Types.Email.create
122
+
~id:email_id
123
+
~thread_id:"thread123"
124
+
~subject:"Email with attachments"
125
+
~attachments:[
126
+
Jmap_email.Types.Email_body_part.v
127
+
~blob_id:"blob123"
128
+
~name:"document.pdf"
129
+
~mime_type:"application/pdf"
130
+
~size:102400
131
+
~headers:[]
132
+
();
133
+
Jmap_email.Types.Email_body_part.v
134
+
~blob_id:"blob456"
135
+
~name:"image.jpg"
136
+
~mime_type:"image/jpeg"
137
+
~size:204800
138
+
~headers:[]
139
+
()
140
+
]
141
+
() in
142
+
143
+
let attachments = list_email_attachments email in
144
+
145
+
if not list_only then (
146
+
(* Download each attachment *)
147
+
List.iter (fun part ->
148
+
match Jmap_email.Types.Email_body_part.blob_id part with
149
+
| Some blob_id ->
150
+
let name = match Jmap_email.Types.Email_body_part.name part with
151
+
| Some n -> n
152
+
| None -> blob_id ^ ".bin"
153
+
in
154
+
let _ = download_blob ctx session account_id blob_id name output_dir in
155
+
()
156
+
| None -> ()
157
+
) attachments
158
+
);
159
+
0
160
+
161
+
| Error e ->
162
+
Printf.eprintf "Failed to get email: %s\n" (Jmap.Error.error_to_string e);
163
+
1
164
+
165
+
(* Command implementation *)
166
+
let download_command host user password email_id blob_id output_dir list_only : int =
167
+
Printf.printf "JMAP Blob Downloader\n";
168
+
Printf.printf "Server: %s\n" host;
169
+
Printf.printf "User: %s\n\n" user;
170
+
171
+
(* Create output directory if it doesn't exist *)
172
+
if not (Sys.file_exists output_dir) then
173
+
Unix.mkdir output_dir 0o755;
174
+
175
+
(* Connect to server *)
176
+
let ctx = Jmap_unix.create_client () in
177
+
let result = Jmap_unix.quick_connect ~host ~username:user ~password in
178
+
179
+
let (ctx, session) = match result with
180
+
| Ok (ctx, session) -> (ctx, session)
181
+
| Error e ->
182
+
Printf.eprintf "Connection failed: %s\n" (Jmap.Error.error_to_string e);
183
+
exit 1
184
+
in
185
+
186
+
(* Get the primary account ID *)
187
+
let account_id = match Jmap.get_primary_account session Jmap_email.capability_mail with
188
+
| Ok id -> id
189
+
| Error e ->
190
+
Printf.eprintf "No mail account found: %s\n" (Jmap.Error.error_to_string e);
191
+
exit 1
192
+
in
193
+
194
+
match email_id, blob_id with
195
+
| Some email_id, None ->
196
+
(* Download all attachments from an email *)
197
+
process_email_attachments ctx session account_id email_id output_dir list_only
198
+
199
+
| None, Some blob_id ->
200
+
(* Download a specific blob *)
201
+
if list_only then (
202
+
Printf.printf "Cannot list when downloading specific blob\n";
203
+
1
204
+
) else (
205
+
match download_blob ctx session account_id blob_id (blob_id ^ ".bin") output_dir with
206
+
| Ok () -> 0
207
+
| Error () -> 1
208
+
)
209
+
210
+
| None, None ->
211
+
Printf.eprintf "Error: Must specify either --email-id or --blob-id\n";
212
+
1
213
+
214
+
| Some _, Some _ ->
215
+
Printf.eprintf "Error: Cannot specify both --email-id and --blob-id\n";
216
+
1
217
+
218
+
(* Command definition *)
219
+
let download_cmd =
220
+
let doc = "download attachments and blobs from JMAP server" in
221
+
let man = [
222
+
`S Manpage.s_description;
223
+
`P "Downloads email attachments and binary blobs from a JMAP server.";
224
+
`P "Can download all attachments from an email or specific blobs by ID.";
225
+
`S Manpage.s_examples;
226
+
`P "List attachments in an email:";
227
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 -e email123 --list-only";
228
+
`P "";
229
+
`P "Download all attachments from an email:";
230
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 -e email123 -o downloads/";
231
+
`P "";
232
+
`P "Download a specific blob:";
233
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 -b blob456 -o downloads/";
234
+
] in
235
+
236
+
let cmd =
237
+
Cmd.v
238
+
(Cmd.info "jmap-blob-downloader" ~version:"1.0" ~doc ~man)
239
+
Term.(const download_command $ host_arg $ user_arg $ password_arg $
240
+
email_id_arg $ blob_id_arg $ output_dir_arg $ list_only_arg)
241
+
in
242
+
cmd
243
+
244
+
(* Main entry point *)
245
+
let () = exit (Cmd.eval' download_cmd)
+429
bin/jmap_email_composer.ml
+429
bin/jmap_email_composer.ml
···
1
+
(*
2
+
* jmap_email_composer.ml - Compose and send emails via JMAP
3
+
*
4
+
* This binary demonstrates JMAP's email creation and submission capabilities,
5
+
* including drafts, attachments, and sending.
6
+
*
7
+
* For step 2, we're only testing type checking. No implementations required.
8
+
*)
9
+
10
+
open Cmdliner
11
+
12
+
(** Email composition options **)
13
+
type compose_options = {
14
+
to_recipients : string list;
15
+
cc_recipients : string list;
16
+
bcc_recipients : string list;
17
+
subject : string;
18
+
body_text : string option;
19
+
body_html : string option;
20
+
attachments : string list;
21
+
in_reply_to : string option;
22
+
draft : bool;
23
+
send : bool;
24
+
}
25
+
26
+
(** Command-line arguments **)
27
+
28
+
let host_arg =
29
+
Arg.(required & opt (some string) None & info ["h"; "host"]
30
+
~docv:"HOST" ~doc:"JMAP server hostname")
31
+
32
+
let user_arg =
33
+
Arg.(required & opt (some string) None & info ["u"; "user"]
34
+
~docv:"USERNAME" ~doc:"Username for authentication")
35
+
36
+
let password_arg =
37
+
Arg.(required & opt (some string) None & info ["p"; "password"]
38
+
~docv:"PASSWORD" ~doc:"Password for authentication")
39
+
40
+
let to_arg =
41
+
Arg.(value & opt_all string [] & info ["t"; "to"]
42
+
~docv:"EMAIL" ~doc:"Recipient email address (can be specified multiple times)")
43
+
44
+
let cc_arg =
45
+
Arg.(value & opt_all string [] & info ["c"; "cc"]
46
+
~docv:"EMAIL" ~doc:"CC recipient email address")
47
+
48
+
let bcc_arg =
49
+
Arg.(value & opt_all string [] & info ["b"; "bcc"]
50
+
~docv:"EMAIL" ~doc:"BCC recipient email address")
51
+
52
+
let subject_arg =
53
+
Arg.(required & opt (some string) None & info ["s"; "subject"]
54
+
~docv:"SUBJECT" ~doc:"Email subject line")
55
+
56
+
let body_arg =
57
+
Arg.(value & opt (some string) None & info ["body"]
58
+
~docv:"TEXT" ~doc:"Plain text body content")
59
+
60
+
let body_file_arg =
61
+
Arg.(value & opt (some string) None & info ["body-file"]
62
+
~docv:"FILE" ~doc:"Read body content from file")
63
+
64
+
let html_arg =
65
+
Arg.(value & opt (some string) None & info ["html"]
66
+
~docv:"HTML" ~doc:"HTML body content")
67
+
68
+
let html_file_arg =
69
+
Arg.(value & opt (some string) None & info ["html-file"]
70
+
~docv:"FILE" ~doc:"Read HTML body from file")
71
+
72
+
let attach_arg =
73
+
Arg.(value & opt_all string [] & info ["a"; "attach"]
74
+
~docv:"FILE" ~doc:"File to attach (can be specified multiple times)")
75
+
76
+
let reply_to_arg =
77
+
Arg.(value & opt (some string) None & info ["r"; "reply-to"]
78
+
~docv:"EMAIL_ID" ~doc:"Email ID to reply to")
79
+
80
+
let draft_arg =
81
+
Arg.(value & flag & info ["d"; "draft"]
82
+
~doc:"Save as draft instead of sending")
83
+
84
+
let send_arg =
85
+
Arg.(value & flag & info ["send"]
86
+
~doc:"Send the email immediately (default is to create draft)")
87
+
88
+
(** Helper functions **)
89
+
90
+
(* Read file contents *)
91
+
let read_file filename =
92
+
let ic = open_in filename in
93
+
let len = in_channel_length ic in
94
+
let content = really_input_string ic len in
95
+
close_in ic;
96
+
content
97
+
98
+
(* Get MIME type from filename *)
99
+
let mime_type_from_filename filename =
100
+
match Filename.extension filename with
101
+
| ".pdf" -> "application/pdf"
102
+
| ".doc" | ".docx" -> "application/msword"
103
+
| ".xls" | ".xlsx" -> "application/vnd.ms-excel"
104
+
| ".jpg" | ".jpeg" -> "image/jpeg"
105
+
| ".png" -> "image/png"
106
+
| ".gif" -> "image/gif"
107
+
| ".txt" -> "text/plain"
108
+
| ".html" | ".htm" -> "text/html"
109
+
| ".zip" -> "application/zip"
110
+
| _ -> "application/octet-stream"
111
+
112
+
(* Upload a file as a blob *)
113
+
let upload_attachment ctx session account_id filepath =
114
+
Printf.printf "Uploading %s...\n" filepath;
115
+
116
+
let content = read_file filepath in
117
+
let filename = Filename.basename filepath in
118
+
let mime_type = mime_type_from_filename filename in
119
+
120
+
(* Upload blob using the JMAP upload endpoint *)
121
+
let upload_url = Jmap.Session.Session.upload_url session in
122
+
let upload_endpoint = Printf.sprintf "%s/%s" (Uri.to_string upload_url) account_id in
123
+
124
+
(* Simulate blob upload for type checking *)
125
+
Printf.printf " Would upload to: %s\n" upload_endpoint;
126
+
Printf.printf " Simulating upload of %s (%s, %d bytes)...\n" filename mime_type (String.length content);
127
+
128
+
(* Create simulated blob info *)
129
+
let blob_info = Jmap.Binary.Upload_response.v
130
+
~account_id:""
131
+
~blob_id:("blob-" ^ filename ^ "-" ^ string_of_int (Random.int 99999))
132
+
~type_:mime_type
133
+
~size:(String.length content)
134
+
() in
135
+
Printf.printf " Uploaded: %s (blob: %s, %d bytes)\n"
136
+
filename
137
+
(Jmap.Binary.Upload_response.blob_id blob_info)
138
+
(Jmap.Binary.Upload_response.size blob_info);
139
+
Ok blob_info
140
+
141
+
(* Create email body parts *)
142
+
let create_body_parts options attachment_blobs =
143
+
let parts = ref [] in
144
+
145
+
(* Add text body if provided *)
146
+
(match options.body_text with
147
+
| Some text ->
148
+
let text_part = Jmap_email.Types.Email_body_part.v
149
+
~id:"text"
150
+
~size:(String.length text)
151
+
~headers:[]
152
+
~mime_type:"text/plain"
153
+
~charset:"utf-8"
154
+
() in
155
+
parts := text_part :: !parts
156
+
| None -> ());
157
+
158
+
(* Add HTML body if provided *)
159
+
(match options.body_html with
160
+
| Some html ->
161
+
let html_part = Jmap_email.Types.Email_body_part.v
162
+
~id:"html"
163
+
~size:(String.length html)
164
+
~headers:[]
165
+
~mime_type:"text/html"
166
+
~charset:"utf-8"
167
+
() in
168
+
parts := html_part :: !parts
169
+
| None -> ());
170
+
171
+
(* Add attachments *)
172
+
List.iter2 (fun filepath blob_info ->
173
+
let filename = Filename.basename filepath in
174
+
let mime_type = mime_type_from_filename filename in
175
+
let attachment = Jmap_email.Types.Email_body_part.v
176
+
~blob_id:(Jmap.Binary.Upload_response.blob_id blob_info)
177
+
~size:(Jmap.Binary.Upload_response.size blob_info)
178
+
~headers:[]
179
+
~name:filename
180
+
~mime_type
181
+
~disposition:"attachment"
182
+
() in
183
+
parts := attachment :: !parts
184
+
) options.attachments attachment_blobs;
185
+
186
+
List.rev !parts
187
+
188
+
(* Main compose and send function *)
189
+
let compose_and_send ctx session account_id options =
190
+
(* 1. Upload attachments first *)
191
+
let attachment_results = List.map (fun filepath ->
192
+
upload_attachment ctx session account_id filepath
193
+
) options.attachments in
194
+
195
+
let attachment_blobs = List.filter_map (function
196
+
| Ok blob -> Some blob
197
+
| Error () -> None
198
+
) attachment_results in
199
+
200
+
if List.length attachment_blobs < List.length options.attachments then (
201
+
Printf.eprintf "Warning: Some attachments failed to upload\n"
202
+
);
203
+
204
+
(* 2. Create the email addresses *)
205
+
let to_addresses = List.map (fun email ->
206
+
Jmap_email.Types.Email_address.v ~email ()
207
+
) options.to_recipients in
208
+
209
+
let cc_addresses = List.map (fun email ->
210
+
Jmap_email.Types.Email_address.v ~email ()
211
+
) options.cc_recipients in
212
+
213
+
let bcc_addresses = List.map (fun email ->
214
+
Jmap_email.Types.Email_address.v ~email ()
215
+
) options.bcc_recipients in
216
+
217
+
(* 3. Get sender identity *)
218
+
let identity_args = Jmap.Methods.Get_args.v
219
+
~account_id
220
+
~properties:["id"; "email"; "name"]
221
+
() in
222
+
223
+
let identity_invocation = Jmap.Wire.Invocation.v
224
+
~method_name:"Identity/get"
225
+
~arguments:(`Assoc []) (* Would serialize identity_args *)
226
+
~method_call_id:"id1"
227
+
() in
228
+
229
+
let request = Jmap.Wire.Request.v
230
+
~using:[Jmap.capability_core; Jmap_email.capability_mail]
231
+
~method_calls:[identity_invocation]
232
+
() in
233
+
234
+
let default_identity = match Jmap_unix.request ctx request with
235
+
| Ok _ ->
236
+
(* Would extract from response *)
237
+
Jmap_email.Identity.v
238
+
~id:"identity1"
239
+
~email:account_id
240
+
~name:"User Name"
241
+
~may_delete:true
242
+
()
243
+
| Error _ ->
244
+
(* Fallback identity *)
245
+
Jmap_email.Identity.v
246
+
~id:"identity1"
247
+
~email:account_id
248
+
~may_delete:true
249
+
()
250
+
in
251
+
252
+
(* 4. Create the draft email *)
253
+
let body_parts = create_body_parts options attachment_blobs in
254
+
255
+
let draft_email = Jmap_email.Types.Email.create
256
+
~subject:options.subject
257
+
~from:[Jmap_email.Types.Email_address.v
258
+
~email:(Jmap_email.Identity.email default_identity)
259
+
~name:(Jmap_email.Identity.name default_identity)
260
+
()]
261
+
~to_:to_addresses
262
+
~cc:cc_addresses
263
+
~keywords:(Jmap_email.Types.Keywords.of_list [Jmap_email.Types.Keywords.Draft])
264
+
~text_body:body_parts
265
+
() in
266
+
267
+
(* 5. Create the email using Email/set *)
268
+
let create_map = Hashtbl.create 1 in
269
+
Hashtbl.add create_map "draft1" draft_email;
270
+
271
+
let create_args = Jmap.Methods.Set_args.v
272
+
~account_id
273
+
~create:create_map
274
+
() in
275
+
276
+
let create_invocation = Jmap.Wire.Invocation.v
277
+
~method_name:"Email/set"
278
+
~arguments:(`Assoc []) (* Would serialize create_args *)
279
+
~method_call_id:"create1"
280
+
() in
281
+
282
+
(* 6. If sending, also create EmailSubmission *)
283
+
let method_calls = if options.send && not options.draft then
284
+
let submission = {
285
+
Jmap_email.Submission.email_sub_create_identity_id = Jmap_email.Identity.id default_identity;
286
+
email_sub_create_email_id = "#draft1"; (* Back-reference to created email *)
287
+
email_sub_create_envelope = None;
288
+
} in
289
+
290
+
let submit_map = Hashtbl.create 1 in
291
+
Hashtbl.add submit_map "submission1" submission;
292
+
293
+
let submit_args = Jmap.Methods.Set_args.v
294
+
~account_id
295
+
~create:submit_map
296
+
() in
297
+
298
+
let submit_invocation = Jmap.Wire.Invocation.v
299
+
~method_name:"EmailSubmission/set"
300
+
~arguments:(`Assoc []) (* Would serialize submit_args *)
301
+
~method_call_id:"submit1"
302
+
() in
303
+
304
+
[create_invocation; submit_invocation]
305
+
else
306
+
[create_invocation]
307
+
in
308
+
309
+
(* 7. Send the request *)
310
+
let request = Jmap.Wire.Request.v
311
+
~using:[Jmap.capability_core; Jmap_email.capability_mail; Jmap_email.capability_submission]
312
+
~method_calls
313
+
() in
314
+
315
+
match Jmap_unix.request ctx request with
316
+
| Ok response ->
317
+
if options.send && not options.draft then
318
+
Printf.printf "\nEmail sent successfully!\n"
319
+
else
320
+
Printf.printf "\nDraft saved successfully!\n";
321
+
0
322
+
| Error e ->
323
+
Printf.eprintf "\nFailed to create email: %s\n" (Jmap.Error.error_to_string e);
324
+
1
325
+
326
+
(* Command implementation *)
327
+
let compose_command host user password to_list cc_list bcc_list subject
328
+
body body_file html html_file attachments reply_to
329
+
draft send : int =
330
+
Printf.printf "JMAP Email Composer\n";
331
+
Printf.printf "Server: %s\n" host;
332
+
Printf.printf "User: %s\n\n" user;
333
+
334
+
(* Validate arguments *)
335
+
if to_list = [] && cc_list = [] && bcc_list = [] then (
336
+
Printf.eprintf "Error: Must specify at least one recipient\n";
337
+
exit 1
338
+
);
339
+
340
+
(* Read body content *)
341
+
let body_text = match body, body_file with
342
+
| Some text, _ -> Some text
343
+
| None, Some file -> Some (read_file file)
344
+
| None, None -> None
345
+
in
346
+
347
+
let body_html = match html, html_file with
348
+
| Some text, _ -> Some text
349
+
| None, Some file -> Some (read_file file)
350
+
| None, None -> None
351
+
in
352
+
353
+
if body_text = None && body_html = None then (
354
+
Printf.eprintf "Error: Must provide email body (--body, --body-file, --html, or --html-file)\n";
355
+
exit 1
356
+
);
357
+
358
+
(* Create options record *)
359
+
let options = {
360
+
to_recipients = to_list;
361
+
cc_recipients = cc_list;
362
+
bcc_recipients = bcc_list;
363
+
subject;
364
+
body_text;
365
+
body_html;
366
+
attachments;
367
+
in_reply_to = reply_to;
368
+
draft;
369
+
send = send || not draft; (* Send by default unless draft flag is set *)
370
+
} in
371
+
372
+
(* Connect to server *)
373
+
let ctx = Jmap_unix.create_client () in
374
+
let result = Jmap_unix.quick_connect ~host ~username:user ~password in
375
+
376
+
let (ctx, session) = match result with
377
+
| Ok (ctx, session) -> (ctx, session)
378
+
| Error e ->
379
+
Printf.eprintf "Connection failed: %s\n" (Jmap.Error.error_to_string e);
380
+
exit 1
381
+
in
382
+
383
+
(* Get the primary account ID *)
384
+
let account_id = match Jmap.get_primary_account session Jmap_email.capability_mail with
385
+
| Ok id -> id
386
+
| Error e ->
387
+
Printf.eprintf "No mail account found: %s\n" (Jmap.Error.error_to_string e);
388
+
exit 1
389
+
in
390
+
391
+
(* Compose and send/save the email *)
392
+
compose_and_send ctx session account_id options
393
+
394
+
(* Command definition *)
395
+
let compose_cmd =
396
+
let doc = "compose and send emails via JMAP" in
397
+
let man = [
398
+
`S Manpage.s_description;
399
+
`P "Compose and send emails using the JMAP protocol.";
400
+
`P "Supports plain text and HTML bodies, attachments, and drafts.";
401
+
`S Manpage.s_examples;
402
+
`P "Send a simple email:";
403
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 \\";
404
+
`P " -t recipient@example.com -s \"Meeting reminder\" \\";
405
+
`P " --body \"Don't forget our meeting at 3pm!\"";
406
+
`P "";
407
+
`P "Send email with attachment:";
408
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 \\";
409
+
`P " -t recipient@example.com -s \"Report attached\" \\";
410
+
`P " --body-file message.txt -a report.pdf";
411
+
`P "";
412
+
`P "Save as draft:";
413
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 \\";
414
+
`P " -t recipient@example.com -s \"Work in progress\" \\";
415
+
`P " --body \"Still working on this...\" --draft";
416
+
] in
417
+
418
+
let cmd =
419
+
Cmd.v
420
+
(Cmd.info "jmap-email-composer" ~version:"1.0" ~doc ~man)
421
+
Term.(const compose_command $ host_arg $ user_arg $ password_arg $
422
+
to_arg $ cc_arg $ bcc_arg $ subject_arg $ body_arg $ body_file_arg $
423
+
html_arg $ html_file_arg $ attach_arg $ reply_to_arg $
424
+
draft_arg $ send_arg)
425
+
in
426
+
cmd
427
+
428
+
(* Main entry point *)
429
+
let () = exit (Cmd.eval' compose_cmd)
+436
bin/jmap_email_search.ml
+436
bin/jmap_email_search.ml
···
1
+
(*
2
+
* jmap_email_search.ml - A comprehensive email search utility using JMAP
3
+
*
4
+
* This binary demonstrates JMAP's query capabilities for email searching,
5
+
* filtering, and sorting.
6
+
*
7
+
* For step 2, we're only testing type checking. No implementations required.
8
+
*)
9
+
10
+
open Cmdliner
11
+
12
+
(** Email search arguments type *)
13
+
type email_search_args = {
14
+
query : string;
15
+
from : string option;
16
+
to_ : string option;
17
+
subject : string option;
18
+
before : string option;
19
+
after : string option;
20
+
has_attachment : bool;
21
+
mailbox : string option;
22
+
is_unread : bool;
23
+
limit : int;
24
+
sort : [`DateDesc | `DateAsc | `From | `To | `Subject | `Size];
25
+
format : [`Summary | `Json | `Detailed];
26
+
}
27
+
28
+
(* Module to convert ISO 8601 date strings to Unix timestamps *)
29
+
module Date_converter = struct
30
+
(* Convert an ISO date string (YYYY-MM-DD) to Unix timestamp *)
31
+
let parse_date date_str =
32
+
try
33
+
(* Parse YYYY-MM-DD format *)
34
+
let (year, month, day) = Scanf.sscanf date_str "%d-%d-%d" (fun y m d -> (y, m, d)) in
35
+
36
+
(* Convert to Unix timestamp (midnight UTC of that day) *)
37
+
let tm = Unix.{ tm_sec = 0; tm_min = 0; tm_hour = 0;
38
+
tm_mday = day; tm_mon = month - 1; tm_year = year - 1900;
39
+
tm_wday = 0; tm_yday = 0; tm_isdst = false } in
40
+
Some (Unix.mktime tm |> fst)
41
+
with _ ->
42
+
Printf.eprintf "Invalid date format: %s (use YYYY-MM-DD)\n" date_str;
43
+
None
44
+
45
+
(* Format a Unix timestamp as ISO 8601 *)
46
+
let format_datetime time =
47
+
let tm = Unix.gmtime time in
48
+
Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ"
49
+
(tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
50
+
tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
51
+
end
52
+
53
+
(** Command-line arguments **)
54
+
55
+
let host_arg =
56
+
Arg.(required & opt (some string) None & info ["h"; "host"]
57
+
~docv:"HOST" ~doc:"JMAP server hostname")
58
+
59
+
let user_arg =
60
+
Arg.(required & opt (some string) None & info ["u"; "user"]
61
+
~docv:"USERNAME" ~doc:"Username for authentication")
62
+
63
+
let password_arg =
64
+
Arg.(required & opt (some string) None & info ["p"; "password"]
65
+
~docv:"PASSWORD" ~doc:"Password for authentication")
66
+
67
+
let query_arg =
68
+
Arg.(value & opt string "" & info ["q"; "query"]
69
+
~docv:"QUERY" ~doc:"Text to search for in emails")
70
+
71
+
let from_arg =
72
+
Arg.(value & opt (some string) None & info ["from"]
73
+
~docv:"EMAIL" ~doc:"Filter by sender email address")
74
+
75
+
let to_arg =
76
+
Arg.(value & opt (some string) None & info ["to"]
77
+
~docv:"EMAIL" ~doc:"Filter by recipient email address")
78
+
79
+
let subject_arg =
80
+
Arg.(value & opt (some string) None & info ["subject"]
81
+
~docv:"SUBJECT" ~doc:"Filter by subject text")
82
+
83
+
let before_arg =
84
+
Arg.(value & opt (some string) None & info ["before"]
85
+
~docv:"DATE" ~doc:"Show emails before date (YYYY-MM-DD)")
86
+
87
+
let after_arg =
88
+
Arg.(value & opt (some string) None & info ["after"]
89
+
~docv:"DATE" ~doc:"Show emails after date (YYYY-MM-DD)")
90
+
91
+
let has_attachment_arg =
92
+
Arg.(value & flag & info ["has-attachment"]
93
+
~doc:"Filter to emails with attachments")
94
+
95
+
let mailbox_arg =
96
+
Arg.(value & opt (some string) None & info ["mailbox"]
97
+
~docv:"MAILBOX" ~doc:"Filter by mailbox name")
98
+
99
+
let is_unread_arg =
100
+
Arg.(value & flag & info ["unread"]
101
+
~doc:"Show only unread emails")
102
+
103
+
let limit_arg =
104
+
Arg.(value & opt int 20 & info ["limit"]
105
+
~docv:"N" ~doc:"Maximum number of results to return")
106
+
107
+
let sort_arg =
108
+
Arg.(value & opt (enum [
109
+
"date-desc", `DateDesc;
110
+
"date-asc", `DateAsc;
111
+
"from", `From;
112
+
"to", `To;
113
+
"subject", `Subject;
114
+
"size", `Size;
115
+
]) `DateDesc & info ["sort"] ~docv:"FIELD"
116
+
~doc:"Sort results by field")
117
+
118
+
let format_arg =
119
+
Arg.(value & opt (enum [
120
+
"summary", `Summary;
121
+
"json", `Json;
122
+
"detailed", `Detailed;
123
+
]) `Summary & info ["format"] ~docv:"FORMAT"
124
+
~doc:"Output format")
125
+
126
+
(** Main functionality **)
127
+
128
+
(* Create a filter based on command-line arguments - this function uses the actual JMAP API *)
129
+
let create_filter _account_id mailbox_id_opt args =
130
+
let open Jmap.Methods.Filter in
131
+
let filters = [] in
132
+
133
+
(* Add filter conditions based on command-line args *)
134
+
let filters = match args.query with
135
+
| "" -> filters
136
+
| query -> Jmap_email.Email_filter.subject query :: filters
137
+
in
138
+
139
+
let filters = match args.from with
140
+
| None -> filters
141
+
| Some sender -> Jmap_email.Email_filter.from sender :: filters
142
+
in
143
+
144
+
let filters = match args.to_ with
145
+
| None -> filters
146
+
| Some recipient -> Jmap_email.Email_filter.to_ recipient :: filters
147
+
in
148
+
149
+
let filters = match args.subject with
150
+
| None -> filters
151
+
| Some subj -> Jmap_email.Email_filter.subject subj :: filters
152
+
in
153
+
154
+
let filters = match args.before with
155
+
| None -> filters
156
+
| Some date_str ->
157
+
match Date_converter.parse_date date_str with
158
+
| Some date -> Jmap_email.Email_filter.before date :: filters
159
+
| None -> filters
160
+
in
161
+
162
+
let filters = match args.after with
163
+
| None -> filters
164
+
| Some date_str ->
165
+
match Date_converter.parse_date date_str with
166
+
| Some date -> Jmap_email.Email_filter.after date :: filters
167
+
| None -> filters
168
+
in
169
+
170
+
let filters = if args.has_attachment then Jmap_email.Email_filter.has_attachment () :: filters else filters in
171
+
172
+
let filters = if args.is_unread then Jmap_email.Email_filter.unread () :: filters else filters in
173
+
174
+
let filters = match mailbox_id_opt with
175
+
| None -> filters
176
+
| Some mailbox_id -> Jmap_email.Email_filter.in_mailbox mailbox_id :: filters
177
+
in
178
+
179
+
(* Combine all filters with AND *)
180
+
match filters with
181
+
| [] -> condition (`Assoc []) (* Empty filter *)
182
+
| [f] -> f
183
+
| filters -> and_ filters
184
+
185
+
(* Create sort comparator based on command-line arguments *)
186
+
let create_sort args =
187
+
match args.sort with
188
+
| `DateDesc -> Jmap_email.Email_sort.received_newest_first ()
189
+
| `DateAsc -> Jmap_email.Email_sort.received_oldest_first ()
190
+
| `From -> Jmap_email.Email_sort.from_asc ()
191
+
| `To -> Jmap_email.Email_sort.subject_asc () (* Using subject as proxy for 'to' *)
192
+
| `Subject -> Jmap_email.Email_sort.subject_asc ()
193
+
| `Size -> Jmap_email.Email_sort.size_largest_first ()
194
+
195
+
(* Display email results based on format option *)
196
+
let display_results emails format =
197
+
match format with
198
+
| `Summary ->
199
+
emails |> List.iteri (fun i email ->
200
+
let id = Option.value (Jmap_email.Types.Email.id email) ~default:"(no id)" in
201
+
let subject = Option.value (Jmap_email.Types.Email.subject email) ~default:"(no subject)" in
202
+
let from_list = Option.value (Jmap_email.Types.Email.from email) ~default:[] in
203
+
let from = match from_list with
204
+
| [] -> "(no sender)"
205
+
| addr::_ -> Jmap_email.Types.Email_address.email addr
206
+
in
207
+
let date = match Jmap_email.Types.Email.received_at email with
208
+
| Some d -> Date_converter.format_datetime d
209
+
| None -> "(no date)"
210
+
in
211
+
Printf.printf "%3d) [%s] %s\n From: %s\n Date: %s\n\n"
212
+
(i+1) id subject from date
213
+
);
214
+
0
215
+
216
+
| `Detailed ->
217
+
emails |> List.iteri (fun i email ->
218
+
let id = Option.value (Jmap_email.Types.Email.id email) ~default:"(no id)" in
219
+
let subject = Option.value (Jmap_email.Types.Email.subject email) ~default:"(no subject)" in
220
+
let thread_id = Option.value (Jmap_email.Types.Email.thread_id email) ~default:"(no thread)" in
221
+
222
+
let from_list = Option.value (Jmap_email.Types.Email.from email) ~default:[] in
223
+
let from = match from_list with
224
+
| [] -> "(no sender)"
225
+
| addr::_ -> Jmap_email.Types.Email_address.email addr
226
+
in
227
+
228
+
let to_list = Option.value (Jmap_email.Types.Email.to_ email) ~default:[] in
229
+
let to_str = to_list
230
+
|> List.map Jmap_email.Types.Email_address.email
231
+
|> String.concat ", " in
232
+
233
+
let date = match Jmap_email.Types.Email.received_at email with
234
+
| Some d -> Date_converter.format_datetime d
235
+
| None -> "(no date)"
236
+
in
237
+
238
+
let keywords = match Jmap_email.Types.Email.keywords email with
239
+
| Some kw -> Jmap_email.Types.Keywords.custom_keywords kw
240
+
|> String.concat ", "
241
+
| None -> "(none)"
242
+
in
243
+
244
+
let has_attachment = match Jmap_email.Types.Email.has_attachment email with
245
+
| Some true -> "Yes"
246
+
| _ -> "No"
247
+
in
248
+
249
+
Printf.printf "Email %d:\n" (i+1);
250
+
Printf.printf " ID: %s\n" id;
251
+
Printf.printf " Subject: %s\n" subject;
252
+
Printf.printf " From: %s\n" from;
253
+
Printf.printf " To: %s\n" to_str;
254
+
Printf.printf " Date: %s\n" date;
255
+
Printf.printf " Thread: %s\n" thread_id;
256
+
Printf.printf " Flags: %s\n" keywords;
257
+
Printf.printf " Attachment:%s\n" has_attachment;
258
+
259
+
match Jmap_email.Types.Email.preview email with
260
+
| Some text -> Printf.printf " Preview: %s\n" text
261
+
| None -> ();
262
+
263
+
Printf.printf "\n"
264
+
);
265
+
0
266
+
267
+
| `Json ->
268
+
(* In a real implementation, this would properly convert emails to JSON *)
269
+
Printf.printf "{\n \"results\": [\n";
270
+
emails |> List.iteri (fun i email ->
271
+
let id = Option.value (Jmap_email.Types.Email.id email) ~default:"" in
272
+
let subject = Option.value (Jmap_email.Types.Email.subject email) ~default:"" in
273
+
Printf.printf " {\"id\": \"%s\", \"subject\": \"%s\"%s\n"
274
+
id subject (if i < List.length emails - 1 then "}," else "}")
275
+
);
276
+
Printf.printf " ]\n}\n";
277
+
0
278
+
279
+
(* Command implementation - using the real JMAP interface *)
280
+
let search_command host user password query from to_ subject before after
281
+
has_attachment mailbox is_unread limit sort format : int =
282
+
(* Pack arguments into a record for easier passing *)
283
+
let args : email_search_args = {
284
+
query; from; to_ = to_; subject; before; after;
285
+
has_attachment; mailbox; is_unread; limit; sort; format
286
+
} in
287
+
288
+
Printf.printf "JMAP Email Search\n";
289
+
Printf.printf "Server: %s\n" host;
290
+
Printf.printf "User: %s\n\n" user;
291
+
292
+
(* The following code demonstrates using the JMAP library interface
293
+
but doesn't actually run it for Step 2 (it will get a linker error,
294
+
which is expected since there's no implementation yet) *)
295
+
296
+
let process_search () =
297
+
(* 1. Create client context and connect to server *)
298
+
let _orig_ctx = Jmap_unix.create_client () in
299
+
let result = Jmap_unix.quick_connect ~host ~username:user ~password in
300
+
301
+
let (ctx, session) = match result with
302
+
| Ok (ctx, session) -> (ctx, session)
303
+
| Error _ -> failwith "Could not connect to server"
304
+
in
305
+
306
+
(* 2. Get the primary account ID for mail capability *)
307
+
let account_id = match Jmap.get_primary_account session Jmap_email.capability_mail with
308
+
| Ok id -> id
309
+
| Error _ -> failwith "No mail account found"
310
+
in
311
+
312
+
(* 3. Resolve mailbox name to ID if specified *)
313
+
let mailbox_id_opt = match args.mailbox with
314
+
| None -> None
315
+
| Some _name ->
316
+
(* This would use Mailbox/query and Mailbox/get to resolve the name *)
317
+
(* For now just simulate a mailbox ID *)
318
+
Some "mailbox123"
319
+
in
320
+
321
+
(* 4. Create filter based on search criteria *)
322
+
let filter = create_filter account_id mailbox_id_opt args in
323
+
324
+
(* 5. Create sort comparator *)
325
+
let sort = create_sort args in
326
+
327
+
(* 6. Prepare Email/query request *)
328
+
let _query_args = Jmap.Methods.Query_args.v
329
+
~account_id
330
+
~filter
331
+
~sort:[sort]
332
+
~position:0
333
+
~limit:args.limit
334
+
~calculate_total:true
335
+
() in
336
+
337
+
let query_invocation = Jmap.Wire.Invocation.v
338
+
~method_name:"Email/query"
339
+
~arguments:(`Assoc []) (* In real code, we'd serialize query_args to JSON *)
340
+
~method_call_id:"q1"
341
+
() in
342
+
343
+
(* 7. Prepare Email/get request with back-reference to query results *)
344
+
let get_properties = [
345
+
"id"; "threadId"; "mailboxIds"; "keywords"; "size";
346
+
"receivedAt"; "messageId"; "inReplyTo"; "references";
347
+
"sender"; "from"; "to"; "cc"; "bcc"; "replyTo";
348
+
"subject"; "sentAt"; "hasAttachment"; "preview"
349
+
] in
350
+
351
+
let _get_args = Jmap.Methods.Get_args.v
352
+
~account_id
353
+
~properties:get_properties
354
+
() in
355
+
356
+
let get_invocation = Jmap.Wire.Invocation.v
357
+
~method_name:"Email/get"
358
+
~arguments:(`Assoc []) (* In real code, we'd serialize get_args to JSON *)
359
+
~method_call_id:"g1"
360
+
() in
361
+
362
+
(* 8. Prepare the JMAP request *)
363
+
let request = Jmap.Wire.Request.v
364
+
~using:[Jmap.capability_core; Jmap_email.capability_mail]
365
+
~method_calls:[query_invocation; get_invocation]
366
+
() in
367
+
368
+
(* 9. Send the request *)
369
+
let response = match Jmap_unix.request ctx request with
370
+
| Ok response -> response
371
+
| Error _ -> failwith "Request failed"
372
+
in
373
+
374
+
(* Helper to find a method response by ID *)
375
+
let find_method_response response id =
376
+
let open Jmap.Wire in
377
+
let responses = Response.method_responses response in
378
+
let find_by_id inv =
379
+
match inv with
380
+
| Ok invocation when Invocation.method_call_id invocation = id ->
381
+
Some (Invocation.method_name invocation, Invocation.arguments invocation)
382
+
| _ -> None
383
+
in
384
+
List.find_map find_by_id responses
385
+
in
386
+
387
+
(* 10. Process the response *)
388
+
match find_method_response response "g1" with
389
+
| Some (method_name, _) when method_name = "Email/get" ->
390
+
(* We would extract the emails from the response here *)
391
+
(* For now, just create a sample email for type checking *)
392
+
let email = Jmap_email.Types.Email.create
393
+
~id:"email123"
394
+
~thread_id:"thread456"
395
+
~subject:"Test Email"
396
+
~from:[Jmap_email.Types.Email_address.v ~name:"Sender" ~email:"sender@example.com" ()]
397
+
~to_:[Jmap_email.Types.Email_address.v ~name:"Recipient" ~email:"recipient@example.com" ()]
398
+
~received_at:1588000000.0
399
+
~has_attachment:true
400
+
~preview:"This is a test email..."
401
+
~keywords:(Jmap_email.Types.Keywords.of_list [Jmap_email.Types.Keywords.Seen])
402
+
() in
403
+
404
+
(* Display the result *)
405
+
display_results [email] args.format
406
+
| _ ->
407
+
Printf.eprintf "Error: Invalid response\n";
408
+
1
409
+
in
410
+
411
+
(* Note: Since we're only type checking, this won't actually run *)
412
+
process_search ()
413
+
414
+
(* Command definition *)
415
+
let search_cmd =
416
+
let doc = "search emails using JMAP query capabilities" in
417
+
let man = [
418
+
`S Manpage.s_description;
419
+
`P "Searches for emails on a JMAP server with powerful filtering capabilities.";
420
+
`P "Demonstrates the rich query functions available in the JMAP protocol.";
421
+
`S Manpage.s_examples;
422
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 -q \"important meeting\"";
423
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --from boss@company.com --after 2023-01-01";
424
+
] in
425
+
426
+
let cmd =
427
+
Cmd.v
428
+
(Cmd.info "jmap-email-search" ~version:"1.0" ~doc ~man)
429
+
Term.(const search_command $ host_arg $ user_arg $ password_arg $
430
+
query_arg $ from_arg $ to_arg $ subject_arg $ before_arg $ after_arg $
431
+
has_attachment_arg $ mailbox_arg $ is_unread_arg $ limit_arg $ sort_arg $ format_arg)
432
+
in
433
+
cmd
434
+
435
+
(* Main entry point *)
436
+
let () = exit (Cmd.eval' search_cmd)
+706
bin/jmap_flag_manager.ml
+706
bin/jmap_flag_manager.ml
···
1
+
(*
2
+
* jmap_flag_manager.ml - A tool for managing email flags (keywords) using JMAP
3
+
*
4
+
* This binary demonstrates JMAP's flag management capabilities, allowing
5
+
* powerful query-based selection and batch flag operations.
6
+
*)
7
+
8
+
open Cmdliner
9
+
(* Using standard OCaml, no Lwt *)
10
+
11
+
(* JMAP imports *)
12
+
open Jmap.Methods
13
+
open Jmap_email
14
+
(* For step 2, we're only testing type checking. No implementations required. *)
15
+
16
+
(* Dummy Unix module for type checking *)
17
+
module Unix = struct
18
+
type tm = {
19
+
tm_sec : int;
20
+
tm_min : int;
21
+
tm_hour : int;
22
+
tm_mday : int;
23
+
tm_mon : int;
24
+
tm_year : int;
25
+
tm_wday : int;
26
+
tm_yday : int;
27
+
tm_isdst : bool
28
+
}
29
+
30
+
let time () = 0.0
31
+
let gettimeofday () = 0.0
32
+
let mktime tm = (0.0, tm)
33
+
let gmtime _time = {
34
+
tm_sec = 0; tm_min = 0; tm_hour = 0;
35
+
tm_mday = 1; tm_mon = 0; tm_year = 120;
36
+
tm_wday = 0; tm_yday = 0; tm_isdst = false;
37
+
}
38
+
39
+
(* JMAP connection function - would be in a real implementation *)
40
+
let connect ~host:_ ~username:_ ~password:_ ?auth_method:_ () =
41
+
failwith "Not implemented"
42
+
end
43
+
44
+
(* Dummy ISO8601 module *)
45
+
module ISO8601 = struct
46
+
let string_of_datetime _tm = "2023-01-01T00:00:00Z"
47
+
end
48
+
49
+
(** Flag manager args type *)
50
+
type flag_manager_args = {
51
+
list : bool;
52
+
add_flag : string option;
53
+
remove_flag : string option;
54
+
query : string;
55
+
from : string option;
56
+
days : int;
57
+
mailbox : string option;
58
+
ids : string list;
59
+
has_flag : string option;
60
+
missing_flag : string option;
61
+
limit : int;
62
+
dry_run : bool;
63
+
color : [`Red | `Orange | `Yellow | `Green | `Blue | `Purple | `Gray | `None] option;
64
+
verbose : bool;
65
+
}
66
+
67
+
(* Helper function for converting keywords to string *)
68
+
let string_of_keyword = function
69
+
| Types.Keywords.Draft -> "$draft"
70
+
| Types.Keywords.Seen -> "$seen"
71
+
| Types.Keywords.Flagged -> "$flagged"
72
+
| Types.Keywords.Answered -> "$answered"
73
+
| Types.Keywords.Forwarded -> "$forwarded"
74
+
| Types.Keywords.Phishing -> "$phishing"
75
+
| Types.Keywords.Junk -> "$junk"
76
+
| Types.Keywords.NotJunk -> "$notjunk"
77
+
| Types.Keywords.Custom c -> c
78
+
| Types.Keywords.Notify -> "$notify"
79
+
| Types.Keywords.Muted -> "$muted"
80
+
| Types.Keywords.Followed -> "$followed"
81
+
| Types.Keywords.Memo -> "$memo"
82
+
| Types.Keywords.HasMemo -> "$hasmemo"
83
+
| Types.Keywords.Autosent -> "$autosent"
84
+
| Types.Keywords.Unsubscribed -> "$unsubscribed"
85
+
| Types.Keywords.CanUnsubscribe -> "$canunsubscribe"
86
+
| Types.Keywords.Imported -> "$imported"
87
+
| Types.Keywords.IsTrusted -> "$istrusted"
88
+
| Types.Keywords.MaskedEmail -> "$maskedemail"
89
+
| Types.Keywords.New -> "$new"
90
+
| Types.Keywords.MailFlagBit0 -> "$MailFlagBit0"
91
+
| Types.Keywords.MailFlagBit1 -> "$MailFlagBit1"
92
+
| Types.Keywords.MailFlagBit2 -> "$MailFlagBit2"
93
+
94
+
(* Email filter helpers - stub implementations for type checking *)
95
+
module Email_filter = struct
96
+
let create_fulltext_filter text = Filter.condition (`Assoc [("text", `String text)])
97
+
let subject subject = Filter.condition (`Assoc [("subject", `String subject)])
98
+
let from email = Filter.condition (`Assoc [("from", `String email)])
99
+
let after date = Filter.condition (`Assoc [("receivedAt", `Assoc [("after", `Float date)])])
100
+
let before date = Filter.condition (`Assoc [("receivedAt", `Assoc [("before", `Float date)])])
101
+
let has_attachment () = Filter.condition (`Assoc [("hasAttachment", `Bool true)])
102
+
let unread () = Filter.condition (`Assoc [("isUnread", `Bool true)])
103
+
let in_mailbox id = Filter.condition (`Assoc [("inMailbox", `String id)])
104
+
let to_ email = Filter.condition (`Assoc [("to", `String email)])
105
+
let has_keyword kw = Filter.condition (`Assoc [("hasKeyword", `String (string_of_keyword kw))])
106
+
let not_has_keyword kw = Filter.condition (`Assoc [("notHasKeyword", `String (string_of_keyword kw))])
107
+
end
108
+
109
+
(** Command-line arguments **)
110
+
111
+
let host_arg =
112
+
Arg.(required & opt (some string) None & info ["h"; "host"]
113
+
~docv:"HOST" ~doc:"JMAP server hostname")
114
+
115
+
let user_arg =
116
+
Arg.(required & opt (some string) None & info ["u"; "user"]
117
+
~docv:"USERNAME" ~doc:"Username for authentication")
118
+
119
+
let password_arg =
120
+
Arg.(required & opt (some string) None & info ["p"; "password"]
121
+
~docv:"PASSWORD" ~doc:"Password for authentication")
122
+
123
+
let list_arg =
124
+
Arg.(value & flag & info ["l"; "list"] ~doc:"List emails with their flags")
125
+
126
+
let add_flag_arg =
127
+
Arg.(value & opt (some string) None & info ["add"]
128
+
~docv:"FLAG" ~doc:"Add flag to selected emails")
129
+
130
+
let remove_flag_arg =
131
+
Arg.(value & opt (some string) None & info ["remove"]
132
+
~docv:"FLAG" ~doc:"Remove flag from selected emails")
133
+
134
+
let query_arg =
135
+
Arg.(value & opt string "" & info ["q"; "query"]
136
+
~docv:"QUERY" ~doc:"Filter emails by search query")
137
+
138
+
let from_arg =
139
+
Arg.(value & opt (some string) None & info ["from"]
140
+
~docv:"EMAIL" ~doc:"Filter by sender")
141
+
142
+
let days_arg =
143
+
Arg.(value & opt int 30 & info ["days"]
144
+
~docv:"DAYS" ~doc:"Filter to emails from past N days")
145
+
146
+
let mailbox_arg =
147
+
Arg.(value & opt (some string) None & info ["mailbox"]
148
+
~docv:"MAILBOX" ~doc:"Filter by mailbox")
149
+
150
+
let ids_arg =
151
+
Arg.(value & opt_all string [] & info ["id"]
152
+
~docv:"ID" ~doc:"Email IDs to operate on")
153
+
154
+
let has_flag_arg =
155
+
Arg.(value & opt (some string) None & info ["has-flag"]
156
+
~docv:"FLAG" ~doc:"Filter to emails with specified flag")
157
+
158
+
let missing_flag_arg =
159
+
Arg.(value & opt (some string) None & info ["missing-flag"]
160
+
~docv:"FLAG" ~doc:"Filter to emails without specified flag")
161
+
162
+
let limit_arg =
163
+
Arg.(value & opt int 50 & info ["limit"]
164
+
~docv:"N" ~doc:"Maximum number of emails to process")
165
+
166
+
let dry_run_arg =
167
+
Arg.(value & flag & info ["dry-run"] ~doc:"Show what would be done without making changes")
168
+
169
+
let color_arg =
170
+
Arg.(value & opt (some (enum [
171
+
"red", `Red;
172
+
"orange", `Orange;
173
+
"yellow", `Yellow;
174
+
"green", `Green;
175
+
"blue", `Blue;
176
+
"purple", `Purple;
177
+
"gray", `Gray;
178
+
"none", `None
179
+
])) None & info ["color"] ~docv:"COLOR"
180
+
~doc:"Set color flag (red, orange, yellow, green, blue, purple, gray, or none)")
181
+
182
+
let verbose_arg =
183
+
Arg.(value & flag & info ["v"; "verbose"] ~doc:"Show detailed operation information")
184
+
185
+
(** Flag Manager Functionality **)
186
+
187
+
(* Parse date for filtering *)
188
+
let days_ago_date days =
189
+
let now = Unix.time () in
190
+
now -. (float_of_int days *. 86400.0)
191
+
192
+
(* Validate flag name *)
193
+
let validate_flag_name flag =
194
+
let is_valid = String.length flag > 0 && (
195
+
(* System flags start with $ *)
196
+
(String.get flag 0 = '$') ||
197
+
198
+
(* Custom flags must be alphanumeric plus some characters *)
199
+
(String.for_all (function
200
+
| 'a'..'z' | 'A'..'Z' | '0'..'9' | '-' | '_' -> true
201
+
| _ -> false) flag)
202
+
) in
203
+
204
+
if not is_valid then
205
+
Printf.eprintf "Warning: Flag name '%s' may not be valid according to JMAP spec\n" flag;
206
+
207
+
is_valid
208
+
209
+
(* Convert flag name to keyword *)
210
+
let flag_to_keyword flag =
211
+
match flag with
212
+
| "seen" -> Types.Keywords.Seen
213
+
| "draft" -> Types.Keywords.Draft
214
+
| "flagged" -> Types.Keywords.Flagged
215
+
| "answered" -> Types.Keywords.Answered
216
+
| "forwarded" -> Types.Keywords.Forwarded
217
+
| "junk" -> Types.Keywords.Junk
218
+
| "notjunk" -> Types.Keywords.NotJunk
219
+
| "phishing" -> Types.Keywords.Phishing
220
+
| "important" -> Types.Keywords.Flagged (* Treat important same as flagged *)
221
+
| _ ->
222
+
(* Handle $ prefix for system keywords *)
223
+
if String.get flag 0 = '$' then
224
+
match flag with
225
+
| "$seen" -> Types.Keywords.Seen
226
+
| "$draft" -> Types.Keywords.Draft
227
+
| "$flagged" -> Types.Keywords.Flagged
228
+
| "$answered" -> Types.Keywords.Answered
229
+
| "$forwarded" -> Types.Keywords.Forwarded
230
+
| "$junk" -> Types.Keywords.Junk
231
+
| "$notjunk" -> Types.Keywords.NotJunk
232
+
| "$phishing" -> Types.Keywords.Phishing
233
+
| "$notify" -> Types.Keywords.Notify
234
+
| "$muted" -> Types.Keywords.Muted
235
+
| "$followed" -> Types.Keywords.Followed
236
+
| "$memo" -> Types.Keywords.Memo
237
+
| "$hasmemo" -> Types.Keywords.HasMemo
238
+
| "$autosent" -> Types.Keywords.Autosent
239
+
| "$unsubscribed" -> Types.Keywords.Unsubscribed
240
+
| "$canunsubscribe" -> Types.Keywords.CanUnsubscribe
241
+
| "$imported" -> Types.Keywords.Imported
242
+
| "$istrusted" -> Types.Keywords.IsTrusted
243
+
| "$maskedemail" -> Types.Keywords.MaskedEmail
244
+
| "$new" -> Types.Keywords.New
245
+
| "$MailFlagBit0" -> Types.Keywords.MailFlagBit0
246
+
| "$MailFlagBit1" -> Types.Keywords.MailFlagBit1
247
+
| "$MailFlagBit2" -> Types.Keywords.MailFlagBit2
248
+
| _ -> Types.Keywords.Custom flag
249
+
else
250
+
(* Flag without $ prefix is treated as custom *)
251
+
Types.Keywords.Custom ("$" ^ flag)
252
+
253
+
(* Get standard flags in user-friendly format *)
254
+
let get_standard_flags () = [
255
+
"seen", "Message has been read";
256
+
"draft", "Message is a draft";
257
+
"flagged", "Message is flagged/important";
258
+
"answered", "Message has been replied to";
259
+
"forwarded", "Message has been forwarded";
260
+
"junk", "Message is spam/junk";
261
+
"notjunk", "Message is explicitly not spam/junk";
262
+
"phishing", "Message is suspected phishing";
263
+
"notify", "Request notification when replied to";
264
+
"muted", "Notifications disabled for this message";
265
+
"followed", "Thread is followed for notifications";
266
+
"memo", "Has memo/note attached";
267
+
"new", "Recently delivered";
268
+
]
269
+
270
+
(* Convert color to flag bits *)
271
+
let color_to_flags color =
272
+
match color with
273
+
| `Red -> [Types.Keywords.MailFlagBit0]
274
+
| `Orange -> [Types.Keywords.MailFlagBit1]
275
+
| `Yellow -> [Types.Keywords.MailFlagBit2]
276
+
| `Green -> [Types.Keywords.MailFlagBit0; Types.Keywords.MailFlagBit1]
277
+
| `Blue -> [Types.Keywords.MailFlagBit0; Types.Keywords.MailFlagBit2]
278
+
| `Purple -> [Types.Keywords.MailFlagBit1; Types.Keywords.MailFlagBit2]
279
+
| `Gray -> [Types.Keywords.MailFlagBit0; Types.Keywords.MailFlagBit1; Types.Keywords.MailFlagBit2]
280
+
| `None -> []
281
+
282
+
(* Convert flag bits to color *)
283
+
let flags_to_color flags =
284
+
let has_bit0 = List.exists ((=) Types.Keywords.MailFlagBit0) flags in
285
+
let has_bit1 = List.exists ((=) Types.Keywords.MailFlagBit1) flags in
286
+
let has_bit2 = List.exists ((=) Types.Keywords.MailFlagBit2) flags in
287
+
288
+
match (has_bit0, has_bit1, has_bit2) with
289
+
| (true, false, false) -> Some `Red
290
+
| (false, true, false) -> Some `Orange
291
+
| (false, false, true) -> Some `Yellow
292
+
| (true, true, false) -> Some `Green
293
+
| (true, false, true) -> Some `Blue
294
+
| (false, true, true) -> Some `Purple
295
+
| (true, true, true) -> Some `Gray
296
+
| (false, false, false) -> None
297
+
298
+
(* Filter builder - create JMAP filter from command line args *)
299
+
let build_filter account_id mailbox_id args =
300
+
let open Email_filter in
301
+
let filters = [] in
302
+
303
+
(* Add filter conditions based on command-line args *)
304
+
let filters = match args.query with
305
+
| "" -> filters
306
+
| query -> create_fulltext_filter query :: filters
307
+
in
308
+
309
+
let filters = match args.from with
310
+
| None -> filters
311
+
| Some sender -> from sender :: filters
312
+
in
313
+
314
+
let filters =
315
+
if args.days > 0 then
316
+
after (days_ago_date args.days) :: filters
317
+
else
318
+
filters
319
+
in
320
+
321
+
let filters = match mailbox_id with
322
+
| None -> filters
323
+
| Some id -> in_mailbox id :: filters
324
+
in
325
+
326
+
let filters = match args.has_flag with
327
+
| None -> filters
328
+
| Some flag ->
329
+
let kw = flag_to_keyword flag in
330
+
has_keyword kw :: filters
331
+
in
332
+
333
+
let filters = match args.missing_flag with
334
+
| None -> filters
335
+
| Some flag ->
336
+
let kw = flag_to_keyword flag in
337
+
not_has_keyword kw :: filters
338
+
in
339
+
340
+
(* Combine all filters with AND *)
341
+
match filters with
342
+
| [] -> Filter.condition (`Assoc []) (* Empty filter *)
343
+
| [f] -> f
344
+
| filters -> Filter.and_ filters
345
+
346
+
(* Display email flag information *)
347
+
let display_email_flags emails verbose =
348
+
Printf.printf "Emails and their flags:\n\n";
349
+
350
+
emails |> List.iteri (fun i email ->
351
+
let id = Option.value (Types.Email.id email) ~default:"(unknown)" in
352
+
let subject = Option.value (Types.Email.subject email) ~default:"(no subject)" in
353
+
354
+
let from_list = Option.value (Types.Email.from email) ~default:[] in
355
+
let from = match from_list with
356
+
| addr :: _ -> Types.Email_address.email addr
357
+
| [] -> "(unknown)"
358
+
in
359
+
360
+
let date = match Types.Email.received_at email with
361
+
| Some d -> String.sub (ISO8601.string_of_datetime (Unix.gmtime d)) 0 19
362
+
| None -> "(unknown)"
363
+
in
364
+
365
+
(* Get all keywords/flags *)
366
+
let keywords = match Types.Email.keywords email with
367
+
| Some kw -> kw
368
+
| None -> []
369
+
in
370
+
371
+
(* Format keywords for display *)
372
+
let flag_strs = keywords |> List.map (fun kw ->
373
+
match kw with
374
+
| Types.Keywords.Draft -> "$draft"
375
+
| Types.Keywords.Seen -> "$seen"
376
+
| Types.Keywords.Flagged -> "$flagged"
377
+
| Types.Keywords.Answered -> "$answered"
378
+
| Types.Keywords.Forwarded -> "$forwarded"
379
+
| Types.Keywords.Phishing -> "$phishing"
380
+
| Types.Keywords.Junk -> "$junk"
381
+
| Types.Keywords.NotJunk -> "$notjunk"
382
+
| Types.Keywords.Custom c -> c
383
+
| Types.Keywords.Notify -> "$notify"
384
+
| Types.Keywords.Muted -> "$muted"
385
+
| Types.Keywords.Followed -> "$followed"
386
+
| Types.Keywords.Memo -> "$memo"
387
+
| Types.Keywords.HasMemo -> "$hasmemo"
388
+
| Types.Keywords.Autosent -> "$autosent"
389
+
| Types.Keywords.Unsubscribed -> "$unsubscribed"
390
+
| Types.Keywords.CanUnsubscribe -> "$canunsubscribe"
391
+
| Types.Keywords.Imported -> "$imported"
392
+
| Types.Keywords.IsTrusted -> "$istrusted"
393
+
| Types.Keywords.MaskedEmail -> "$maskedemail"
394
+
| Types.Keywords.New -> "$new"
395
+
| Types.Keywords.MailFlagBit0 -> "$MailFlagBit0"
396
+
| Types.Keywords.MailFlagBit1 -> "$MailFlagBit1"
397
+
| Types.Keywords.MailFlagBit2 -> "$MailFlagBit2"
398
+
) in
399
+
400
+
Printf.printf "Email %d: %s\n" (i + 1) subject;
401
+
Printf.printf " ID: %s\n" id;
402
+
403
+
if verbose then begin
404
+
Printf.printf " From: %s\n" from;
405
+
Printf.printf " Date: %s\n" date;
406
+
end;
407
+
408
+
(* Show color if applicable *)
409
+
begin match flags_to_color keywords with
410
+
| Some color ->
411
+
let color_name = match color with
412
+
| `Red -> "Red"
413
+
| `Orange -> "Orange"
414
+
| `Yellow -> "Yellow"
415
+
| `Green -> "Green"
416
+
| `Blue -> "Blue"
417
+
| `Purple -> "Purple"
418
+
| `Gray -> "Gray"
419
+
in
420
+
Printf.printf " Color: %s\n" color_name
421
+
| None -> ()
422
+
end;
423
+
424
+
Printf.printf " Flags: %s\n\n"
425
+
(if flag_strs = [] then "(none)" else String.concat ", " flag_strs)
426
+
);
427
+
428
+
if List.length emails = 0 then
429
+
Printf.printf "No emails found matching criteria.\n"
430
+
431
+
(* Command implementation *)
432
+
let flag_command host user _password list add_flag remove_flag query from days
433
+
mailbox ids has_flag missing_flag limit dry_run color verbose : int =
434
+
(* Pack arguments into a record for easier passing *)
435
+
let _args : flag_manager_args = {
436
+
list; add_flag; remove_flag; query; from; days; mailbox;
437
+
ids; has_flag; missing_flag; limit; dry_run; color; verbose
438
+
} in
439
+
440
+
(* Main workflow would be implemented here using the JMAP library *)
441
+
Printf.printf "JMAP Flag Manager\n";
442
+
Printf.printf "Server: %s\n" host;
443
+
Printf.printf "User: %s\n\n" user;
444
+
445
+
if list then
446
+
Printf.printf "Listing emails with their flags...\n\n"
447
+
else begin
448
+
if add_flag <> None then
449
+
Printf.printf "Adding flag: %s\n" (Option.get add_flag);
450
+
451
+
if remove_flag <> None then
452
+
Printf.printf "Removing flag: %s\n" (Option.get remove_flag);
453
+
454
+
if color <> None then
455
+
let color_name = match Option.get color with
456
+
| `Red -> "Red"
457
+
| `Orange -> "Orange"
458
+
| `Yellow -> "Yellow"
459
+
| `Green -> "Green"
460
+
| `Blue -> "Blue"
461
+
| `Purple -> "Purple"
462
+
| `Gray -> "Gray"
463
+
| `None -> "None"
464
+
in
465
+
Printf.printf "Setting color: %s\n" color_name;
466
+
end;
467
+
468
+
if query <> "" then
469
+
Printf.printf "Filtering by query: %s\n" query;
470
+
471
+
if from <> None then
472
+
Printf.printf "Filtering by sender: %s\n" (Option.get from);
473
+
474
+
if mailbox <> None then
475
+
Printf.printf "Filtering by mailbox: %s\n" (Option.get mailbox);
476
+
477
+
if ids <> [] then
478
+
Printf.printf "Operating on specific email IDs: %s\n"
479
+
(String.concat ", " ids);
480
+
481
+
if has_flag <> None then
482
+
Printf.printf "Filtering to emails with flag: %s\n" (Option.get has_flag);
483
+
484
+
if missing_flag <> None then
485
+
Printf.printf "Filtering to emails without flag: %s\n" (Option.get missing_flag);
486
+
487
+
Printf.printf "Limiting to %d emails\n" limit;
488
+
489
+
if dry_run then
490
+
Printf.printf "DRY RUN MODE - No changes will be made\n";
491
+
492
+
Printf.printf "\n";
493
+
494
+
(* This is where the actual JMAP calls would happen, like:
495
+
496
+
let manage_flags () =
497
+
let* (ctx, session) = Jmap.Unix.connect
498
+
~host ~username:user ~password
499
+
~auth_method:(Jmap.Unix.Basic(user, password)) () in
500
+
501
+
(* Get primary account ID *)
502
+
let account_id = match Jmap.get_primary_account session Jmap_email.capability_mail with
503
+
| Ok id -> id
504
+
| Error _ -> failwith "No mail account found"
505
+
in
506
+
507
+
(* Resolve mailbox name to ID if specified *)
508
+
let* mailbox_id_opt = match args.mailbox with
509
+
| None -> Lwt.return None
510
+
| Some name ->
511
+
(* This would use Mailbox/query and Mailbox/get to resolve the name *)
512
+
...
513
+
in
514
+
515
+
(* Find emails to operate on *)
516
+
let* emails =
517
+
if args.ids <> [] then
518
+
(* Get emails by ID *)
519
+
let* result = Email.get ctx
520
+
~account_id
521
+
~ids:args.ids
522
+
~properties:["id"; "subject"; "from"; "receivedAt"; "keywords"] in
523
+
524
+
match result with
525
+
| Error err ->
526
+
Printf.eprintf "Error: %s\n" (Jmap.Error.error_to_string err);
527
+
Lwt.return []
528
+
| Ok (_, emails) -> Lwt.return emails
529
+
else
530
+
(* Find emails by query *)
531
+
let filter = build_filter account_id mailbox_id_opt args in
532
+
533
+
let* result = Email.query ctx
534
+
~account_id
535
+
~filter
536
+
~sort:[Email_sort.received_newest_first ()]
537
+
~limit:args.limit
538
+
~properties:["id"] in
539
+
540
+
match result with
541
+
| Error err ->
542
+
Printf.eprintf "Error: %s\n" (Jmap.Error.error_to_string err);
543
+
Lwt.return []
544
+
| Ok (ids, _) ->
545
+
(* Get full email objects for the matching IDs *)
546
+
let* result = Email.get ctx
547
+
~account_id
548
+
~ids
549
+
~properties:["id"; "subject"; "from"; "receivedAt"; "keywords"] in
550
+
551
+
match result with
552
+
| Error err ->
553
+
Printf.eprintf "Error: %s\n" (Jmap.Error.error_to_string err);
554
+
Lwt.return []
555
+
| Ok (_, emails) -> Lwt.return emails
556
+
in
557
+
558
+
(* Just list the emails with their flags *)
559
+
if args.list then
560
+
display_email_flags emails args.verbose;
561
+
Lwt.return_unit
562
+
else if List.length emails = 0 then
563
+
Printf.printf "No emails found matching criteria.\n";
564
+
Lwt.return_unit
565
+
else
566
+
(* Perform flag operations *)
567
+
let ids = emails |> List.filter_map Types.Email.id in
568
+
569
+
if args.dry_run then
570
+
display_email_flags emails args.verbose;
571
+
Lwt.return_unit
572
+
else
573
+
(* Create patch object *)
574
+
let make_patch () =
575
+
let add_keywords = ref [] in
576
+
let remove_keywords = ref [] in
577
+
578
+
(* Handle add flag *)
579
+
Option.iter (fun flag ->
580
+
let keyword = flag_to_keyword flag in
581
+
add_keywords := keyword :: !add_keywords
582
+
) args.add_flag;
583
+
584
+
(* Handle remove flag *)
585
+
Option.iter (fun flag ->
586
+
let keyword = flag_to_keyword flag in
587
+
remove_keywords := keyword :: !remove_keywords
588
+
) args.remove_flag;
589
+
590
+
(* Handle color *)
591
+
Option.iter (fun color ->
592
+
(* First remove all color bits *)
593
+
remove_keywords := Types.Keywords.MailFlagBit0 :: !remove_keywords;
594
+
remove_keywords := Types.Keywords.MailFlagBit1 :: !remove_keywords;
595
+
remove_keywords := Types.Keywords.MailFlagBit2 :: !remove_keywords;
596
+
597
+
(* Then add the right combination for the requested color *)
598
+
if color <> `None then begin
599
+
let color_flags = color_to_flags color in
600
+
add_keywords := color_flags @ !add_keywords
601
+
end
602
+
) args.color;
603
+
604
+
Email.make_patch
605
+
~add_keywords:!add_keywords
606
+
~remove_keywords:!remove_keywords
607
+
()
608
+
in
609
+
610
+
let patch = make_patch () in
611
+
612
+
let* result = Email.update ctx
613
+
~account_id
614
+
~ids
615
+
~update_each:(fun _ -> patch) in
616
+
617
+
match result with
618
+
| Error err ->
619
+
Printf.eprintf "Error: %s\n" (Jmap.Error.error_to_string err);
620
+
Lwt.return_unit
621
+
| Ok updated ->
622
+
Printf.printf "Successfully updated %d emails.\n" (List.length updated);
623
+
Lwt.return_unit
624
+
*)
625
+
626
+
if list then begin
627
+
(* Simulate having found a few emails *)
628
+
let count = 3 in
629
+
Printf.printf "Found %d matching emails:\n\n" count;
630
+
Printf.printf "Email 1: Meeting Agenda\n";
631
+
Printf.printf " ID: email123\n";
632
+
if verbose then begin
633
+
Printf.printf " From: alice@example.com\n";
634
+
Printf.printf " Date: 2023-04-15 09:30:00\n";
635
+
end;
636
+
Printf.printf " Flags: $seen, $flagged, $answered\n\n";
637
+
638
+
Printf.printf "Email 2: Project Update\n";
639
+
Printf.printf " ID: email124\n";
640
+
if verbose then begin
641
+
Printf.printf " From: bob@example.com\n";
642
+
Printf.printf " Date: 2023-04-16 14:45:00\n";
643
+
end;
644
+
Printf.printf " Color: Red\n";
645
+
Printf.printf " Flags: $seen, $MailFlagBit0\n\n";
646
+
647
+
Printf.printf "Email 3: Weekly Newsletter\n";
648
+
Printf.printf " ID: email125\n";
649
+
if verbose then begin
650
+
Printf.printf " From: newsletter@example.com\n";
651
+
Printf.printf " Date: 2023-04-17 08:15:00\n";
652
+
end;
653
+
Printf.printf " Flags: $seen, $notjunk\n\n";
654
+
end else if add_flag <> None || remove_flag <> None || color <> None then begin
655
+
Printf.printf "Would modify %d emails:\n" 2;
656
+
if dry_run then
657
+
Printf.printf "(Dry run mode - no changes made)\n\n"
658
+
else
659
+
Printf.printf "Changes applied successfully\n\n";
660
+
end;
661
+
662
+
(* List standard flags if no other actions specified *)
663
+
if not list && add_flag = None && remove_flag = None && color = None then begin
664
+
Printf.printf "Standard flags:\n";
665
+
get_standard_flags() |> List.iter (fun (flag, desc) ->
666
+
Printf.printf " $%-12s %s\n" flag desc
667
+
);
668
+
669
+
Printf.printf "\nColor flags:\n";
670
+
Printf.printf " $MailFlagBit0 Red\n";
671
+
Printf.printf " $MailFlagBit1 Orange\n";
672
+
Printf.printf " $MailFlagBit2 Yellow\n";
673
+
Printf.printf " $MailFlagBit0+1 Green\n";
674
+
Printf.printf " $MailFlagBit0+2 Blue\n";
675
+
Printf.printf " $MailFlagBit1+2 Purple\n";
676
+
Printf.printf " $MailFlagBit0+1+2 Gray\n";
677
+
end;
678
+
679
+
(* Since we're only type checking, we'll exit with success *)
680
+
0
681
+
682
+
(* Command definition *)
683
+
let flag_cmd =
684
+
let doc = "manage email flags using JMAP" in
685
+
let man = [
686
+
`S Manpage.s_description;
687
+
`P "Lists, adds, and removes flags (keywords) from emails using JMAP.";
688
+
`P "Demonstrates JMAP's flag/keyword management capabilities.";
689
+
`S Manpage.s_examples;
690
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --list";
691
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --add flagged --from boss@example.com";
692
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --color red --mailbox Inbox --has-flag seen --missing-flag flagged";
693
+
] in
694
+
695
+
let cmd =
696
+
Cmd.v
697
+
(Cmd.info "jmap-flag-manager" ~version:"1.0" ~doc ~man)
698
+
Term.(const flag_command $ host_arg $ user_arg $ password_arg $
699
+
list_arg $ add_flag_arg $ remove_flag_arg $ query_arg $
700
+
from_arg $ days_arg $ mailbox_arg $ ids_arg $ has_flag_arg $
701
+
missing_flag_arg $ limit_arg $ dry_run_arg $ color_arg $ verbose_arg)
702
+
in
703
+
cmd
704
+
705
+
(* Main entry point *)
706
+
let () = exit (Cmd.eval' flag_cmd)
+620
bin/jmap_identity_monitor.ml
+620
bin/jmap_identity_monitor.ml
···
1
+
(*
2
+
* jmap_identity_monitor.ml - A tool for monitoring email delivery status
3
+
*
4
+
* This binary demonstrates JMAP's identity and submission tracking capabilities,
5
+
* allowing users to monitor email delivery status and manage email identities.
6
+
*)
7
+
8
+
open Cmdliner
9
+
(* Using standard OCaml, no Lwt *)
10
+
11
+
(* JMAP imports *)
12
+
open Jmap
13
+
open Jmap.Types
14
+
open Jmap.Wire
15
+
open Jmap.Methods
16
+
open Jmap_email
17
+
(* For step 2, we're only testing type checking. No implementations required. *)
18
+
19
+
(* Dummy Unix module for type checking *)
20
+
module Unix = struct
21
+
type tm = {
22
+
tm_sec : int;
23
+
tm_min : int;
24
+
tm_hour : int;
25
+
tm_mday : int;
26
+
tm_mon : int;
27
+
tm_year : int;
28
+
tm_wday : int;
29
+
tm_yday : int;
30
+
tm_isdst : bool
31
+
}
32
+
33
+
let time () = 0.0
34
+
let gettimeofday () = 0.0
35
+
let mktime tm = (0.0, tm)
36
+
let gmtime _time = {
37
+
tm_sec = 0; tm_min = 0; tm_hour = 0;
38
+
tm_mday = 1; tm_mon = 0; tm_year = 120;
39
+
tm_wday = 0; tm_yday = 0; tm_isdst = false;
40
+
}
41
+
42
+
(* JMAP connection function - would be in a real implementation *)
43
+
let connect ~host ~username ~password ?auth_method () =
44
+
failwith "Not implemented"
45
+
end
46
+
47
+
(* Dummy ISO8601 module *)
48
+
module ISO8601 = struct
49
+
let string_of_datetime _tm = "2023-01-01T00:00:00Z"
50
+
end
51
+
52
+
(** Email submission and delivery status types *)
53
+
type email_envelope_address = {
54
+
env_addr_email : string;
55
+
env_addr_parameters : (string * string) list;
56
+
}
57
+
58
+
type email_envelope = {
59
+
env_mail_from : email_envelope_address;
60
+
env_rcpt_to : email_envelope_address list;
61
+
}
62
+
63
+
type email_delivery_status = {
64
+
delivery_smtp_reply : string;
65
+
delivery_delivered : [`Queued | `Yes | `No | `Unknown];
66
+
delivery_displayed : [`Yes | `Unknown];
67
+
}
68
+
69
+
type email_submission = {
70
+
email_sub_id : string;
71
+
email_id : string;
72
+
thread_id : string;
73
+
identity_id : string;
74
+
send_at : float;
75
+
undo_status : [`Pending | `Final | `Canceled];
76
+
envelope : email_envelope option;
77
+
delivery_status : (string, email_delivery_status) Hashtbl.t option;
78
+
dsn_blob_ids : string list;
79
+
mdn_blob_ids : string list;
80
+
}
81
+
82
+
(** Dummy Email_address module to replace Jmap_email_types.Email_address *)
83
+
module Email_address = struct
84
+
type t = string
85
+
let email addr = "user@example.com"
86
+
end
87
+
88
+
(** Dummy Identity module *)
89
+
module Identity = struct
90
+
type t = {
91
+
id : string;
92
+
name : string;
93
+
email : string;
94
+
reply_to : Email_address.t list option;
95
+
bcc : Email_address.t list option;
96
+
text_signature : string;
97
+
html_signature : string;
98
+
may_delete : bool;
99
+
}
100
+
101
+
let id identity = identity.id
102
+
let name identity = identity.name
103
+
let email identity = identity.email
104
+
let reply_to identity = identity.reply_to
105
+
let bcc identity = identity.bcc
106
+
let text_signature identity = identity.text_signature
107
+
let html_signature identity = identity.html_signature
108
+
let may_delete identity = identity.may_delete
109
+
end
110
+
111
+
(** Identity monitor args type *)
112
+
type identity_monitor_args = {
113
+
list_identities : bool;
114
+
show_identity : string option;
115
+
create_identity : string option;
116
+
identity_name : string option;
117
+
reply_to : string option;
118
+
signature : string option;
119
+
html_signature : string option;
120
+
list_submissions : bool;
121
+
show_submission : string option;
122
+
track_submission : string option;
123
+
pending_only : bool;
124
+
query : string option;
125
+
days : int;
126
+
limit : int;
127
+
cancel_submission : string option;
128
+
format : [`Summary | `Detailed | `Json | `StatusOnly];
129
+
}
130
+
131
+
(** Command-line arguments **)
132
+
133
+
let host_arg =
134
+
Arg.(required & opt (some string) None & info ["h"; "host"]
135
+
~docv:"HOST" ~doc:"JMAP server hostname")
136
+
137
+
let user_arg =
138
+
Arg.(required & opt (some string) None & info ["u"; "user"]
139
+
~docv:"USERNAME" ~doc:"Username for authentication")
140
+
141
+
let password_arg =
142
+
Arg.(required & opt (some string) None & info ["p"; "password"]
143
+
~docv:"PASSWORD" ~doc:"Password for authentication")
144
+
145
+
(* Commands *)
146
+
147
+
(* Identity-related commands *)
148
+
let list_identities_arg =
149
+
Arg.(value & flag & info ["list-identities"] ~doc:"List all email identities")
150
+
151
+
let show_identity_arg =
152
+
Arg.(value & opt (some string) None & info ["show-identity"]
153
+
~docv:"ID" ~doc:"Show details for a specific identity")
154
+
155
+
let create_identity_arg =
156
+
Arg.(value & opt (some string) None & info ["create-identity"]
157
+
~docv:"EMAIL" ~doc:"Create a new identity with the specified email address")
158
+
159
+
let identity_name_arg =
160
+
Arg.(value & opt (some string) None & info ["name"]
161
+
~docv:"NAME" ~doc:"Display name for the identity (when creating)")
162
+
163
+
let reply_to_arg =
164
+
Arg.(value & opt (some string) None & info ["reply-to"]
165
+
~docv:"EMAIL" ~doc:"Reply-to address for the identity (when creating)")
166
+
167
+
let signature_arg =
168
+
Arg.(value & opt (some string) None & info ["signature"]
169
+
~docv:"SIGNATURE" ~doc:"Text signature for the identity (when creating)")
170
+
171
+
let html_signature_arg =
172
+
Arg.(value & opt (some string) None & info ["html-signature"]
173
+
~docv:"HTML" ~doc:"HTML signature for the identity (when creating)")
174
+
175
+
(* Submission-related commands *)
176
+
let list_submissions_arg =
177
+
Arg.(value & flag & info ["list-submissions"] ~doc:"List recent email submissions")
178
+
179
+
let show_submission_arg =
180
+
Arg.(value & opt (some string) None & info ["show-submission"]
181
+
~docv:"ID" ~doc:"Show details for a specific submission")
182
+
183
+
let track_submission_arg =
184
+
Arg.(value & opt (some string) None & info ["track"]
185
+
~docv:"ID" ~doc:"Track delivery status for a specific submission")
186
+
187
+
let pending_only_arg =
188
+
Arg.(value & flag & info ["pending-only"] ~doc:"Show only pending submissions")
189
+
190
+
let query_arg =
191
+
Arg.(value & opt (some string) None & info ["query"]
192
+
~docv:"QUERY" ~doc:"Search for submissions containing text in associated email")
193
+
194
+
let days_arg =
195
+
Arg.(value & opt int 7 & info ["days"]
196
+
~docv:"DAYS" ~doc:"Limit to submissions from the past N days")
197
+
198
+
let limit_arg =
199
+
Arg.(value & opt int 20 & info ["limit"]
200
+
~docv:"N" ~doc:"Maximum number of results to display")
201
+
202
+
let cancel_submission_arg =
203
+
Arg.(value & opt (some string) None & info ["cancel"]
204
+
~docv:"ID" ~doc:"Cancel a pending email submission")
205
+
206
+
let format_arg =
207
+
Arg.(value & opt (enum [
208
+
"summary", `Summary;
209
+
"detailed", `Detailed;
210
+
"json", `Json;
211
+
"status-only", `StatusOnly;
212
+
]) `Summary & info ["format"] ~docv:"FORMAT" ~doc:"Output format")
213
+
214
+
(** Main functionality **)
215
+
216
+
(* Format an identity for display *)
217
+
let format_identity identity format =
218
+
match format with
219
+
| `Summary ->
220
+
let id = Identity.id identity in
221
+
let name = Identity.name identity in
222
+
let email = Identity.email identity in
223
+
Printf.printf "%s: %s <%s>\n" id name email
224
+
225
+
| `Detailed ->
226
+
let id = Identity.id identity in
227
+
let name = Identity.name identity in
228
+
let email = Identity.email identity in
229
+
230
+
let reply_to = match Identity.reply_to identity with
231
+
| Some addresses -> addresses
232
+
|> List.map (fun addr -> Email_address.email addr)
233
+
|> String.concat ", "
234
+
| None -> "(none)"
235
+
in
236
+
237
+
let bcc = match Identity.bcc identity with
238
+
| Some addresses -> addresses
239
+
|> List.map (fun addr -> Email_address.email addr)
240
+
|> String.concat ", "
241
+
| None -> "(none)"
242
+
in
243
+
244
+
let may_delete = if Identity.may_delete identity then "Yes" else "No" in
245
+
246
+
Printf.printf "Identity: %s\n" id;
247
+
Printf.printf " Name: %s\n" name;
248
+
Printf.printf " Email: %s\n" email;
249
+
Printf.printf " Reply-To: %s\n" reply_to;
250
+
Printf.printf " BCC: %s\n" bcc;
251
+
252
+
if Identity.text_signature identity <> "" then
253
+
Printf.printf " Signature: %s\n" (Identity.text_signature identity);
254
+
255
+
if Identity.html_signature identity <> "" then
256
+
Printf.printf " HTML Sig: (HTML signature available)\n";
257
+
258
+
Printf.printf " Deletable: %s\n" may_delete
259
+
260
+
| `Json ->
261
+
let id = Identity.id identity in
262
+
let name = Identity.name identity in
263
+
let email = Identity.email identity in
264
+
Printf.printf "{\n";
265
+
Printf.printf " \"id\": \"%s\",\n" id;
266
+
Printf.printf " \"name\": \"%s\",\n" name;
267
+
Printf.printf " \"email\": \"%s\"\n" email;
268
+
Printf.printf "}\n"
269
+
270
+
| _ -> () (* Other formats don't apply to identities *)
271
+
272
+
(* Format delivery status *)
273
+
let format_delivery_status rcpt status =
274
+
let status_str = match status.delivery_delivered with
275
+
| `Queued -> "Queued"
276
+
| `Yes -> "Delivered"
277
+
| `No -> "Failed"
278
+
| `Unknown -> "Unknown"
279
+
in
280
+
281
+
let display_str = match status.delivery_displayed with
282
+
| `Yes -> "Displayed"
283
+
| `Unknown -> "Unknown if displayed"
284
+
in
285
+
286
+
Printf.printf " %s: %s, %s\n" rcpt status_str display_str;
287
+
Printf.printf " SMTP Reply: %s\n" status.delivery_smtp_reply
288
+
289
+
(* Format a submission for display *)
290
+
let format_submission submission format =
291
+
match format with
292
+
| `Summary ->
293
+
let id = submission.email_sub_id in
294
+
let email_id = submission.email_id in
295
+
let send_at = String.sub (ISO8601.string_of_datetime (Unix.gmtime submission.send_at)) 0 19 in
296
+
297
+
let status = match submission.undo_status with
298
+
| `Pending -> "Pending"
299
+
| `Final -> "Final"
300
+
| `Canceled -> "Canceled"
301
+
in
302
+
303
+
let delivery_count = match submission.delivery_status with
304
+
| Some statuses -> Hashtbl.length statuses
305
+
| None -> 0
306
+
in
307
+
308
+
Printf.printf "%s: [%s] Sent at %s (Email ID: %s, Recipients: %d)\n"
309
+
id status send_at email_id delivery_count
310
+
311
+
| `Detailed ->
312
+
let id = submission.email_sub_id in
313
+
let email_id = submission.email_id in
314
+
let thread_id = submission.thread_id in
315
+
let identity_id = submission.identity_id in
316
+
let send_at = String.sub (ISO8601.string_of_datetime (Unix.gmtime submission.send_at)) 0 19 in
317
+
318
+
let status = match submission.undo_status with
319
+
| `Pending -> "Pending"
320
+
| `Final -> "Final"
321
+
| `Canceled -> "Canceled"
322
+
in
323
+
324
+
Printf.printf "Submission: %s\n" id;
325
+
Printf.printf " Status: %s\n" status;
326
+
Printf.printf " Sent at: %s\n" send_at;
327
+
Printf.printf " Email ID: %s\n" email_id;
328
+
Printf.printf " Thread ID: %s\n" thread_id;
329
+
Printf.printf " Identity: %s\n" identity_id;
330
+
331
+
(* Display envelope information if available *)
332
+
(match submission.envelope with
333
+
| Some env ->
334
+
Printf.printf " Envelope:\n";
335
+
Printf.printf " From: %s\n" env.env_mail_from.env_addr_email;
336
+
Printf.printf " To: %s\n"
337
+
(env.env_rcpt_to |> List.map (fun addr -> addr.env_addr_email) |> String.concat ", ")
338
+
| None -> ());
339
+
340
+
(* Display delivery status *)
341
+
(match submission.delivery_status with
342
+
| Some statuses ->
343
+
Printf.printf " Delivery Status:\n";
344
+
statuses |> Hashtbl.iter format_delivery_status
345
+
| None -> Printf.printf " Delivery Status: Not available\n");
346
+
347
+
(* DSN and MDN information *)
348
+
if submission.dsn_blob_ids <> [] then
349
+
Printf.printf " DSN Blobs: %d available\n" (List.length submission.dsn_blob_ids);
350
+
351
+
if submission.mdn_blob_ids <> [] then
352
+
Printf.printf " MDN Blobs: %d available\n" (List.length submission.mdn_blob_ids)
353
+
354
+
| `Json ->
355
+
let id = submission.email_sub_id in
356
+
let email_id = submission.email_id in
357
+
let send_at_str = String.sub (ISO8601.string_of_datetime (Unix.gmtime submission.send_at)) 0 19 in
358
+
359
+
let status_str = match submission.undo_status with
360
+
| `Pending -> "pending"
361
+
| `Final -> "final"
362
+
| `Canceled -> "canceled"
363
+
in
364
+
365
+
Printf.printf "{\n";
366
+
Printf.printf " \"id\": \"%s\",\n" id;
367
+
Printf.printf " \"emailId\": \"%s\",\n" email_id;
368
+
Printf.printf " \"sendAt\": \"%s\",\n" send_at_str;
369
+
Printf.printf " \"undoStatus\": \"%s\"\n" status_str;
370
+
Printf.printf "}\n"
371
+
372
+
| `StatusOnly ->
373
+
let id = submission.email_sub_id in
374
+
375
+
let status = match submission.undo_status with
376
+
| `Pending -> "Pending"
377
+
| `Final -> "Final"
378
+
| `Canceled -> "Canceled"
379
+
in
380
+
381
+
Printf.printf "Submission %s: %s\n" id status;
382
+
383
+
(* Display delivery status summary *)
384
+
match submission.delivery_status with
385
+
| Some statuses ->
386
+
let total = Hashtbl.length statuses in
387
+
let delivered = Hashtbl.fold (fun _ status count ->
388
+
if status.delivery_delivered = `Yes then count + 1 else count
389
+
) statuses 0 in
390
+
391
+
let failed = Hashtbl.fold (fun _ status count ->
392
+
if status.delivery_delivered = `No then count + 1 else count
393
+
) statuses 0 in
394
+
395
+
let queued = Hashtbl.fold (fun _ status count ->
396
+
if status.delivery_delivered = `Queued then count + 1 else count
397
+
) statuses 0 in
398
+
399
+
Printf.printf " Total recipients: %d\n" total;
400
+
Printf.printf " Delivered: %d\n" delivered;
401
+
Printf.printf " Failed: %d\n" failed;
402
+
Printf.printf " Queued: %d\n" queued
403
+
| None ->
404
+
Printf.printf " Delivery status not available\n"
405
+
406
+
(* Create an identity with provided details *)
407
+
let create_identity_command email name reply_to signature html_signature =
408
+
(* In a real implementation, this would validate inputs and create the identity *)
409
+
Printf.printf "Creating identity for email: %s\n" email;
410
+
411
+
if name <> None then
412
+
Printf.printf "Name: %s\n" (Option.get name);
413
+
414
+
if reply_to <> None then
415
+
Printf.printf "Reply-To: %s\n" (Option.get reply_to);
416
+
417
+
if signature <> None || html_signature <> None then
418
+
Printf.printf "Signature: Provided\n";
419
+
420
+
Printf.printf "\nIdentity creation would be implemented here using JMAP.Identity.create\n";
421
+
()
422
+
423
+
(* Command implementation for identity monitoring *)
424
+
let identity_command host user password list_identities show_identity
425
+
create_identity identity_name reply_to signature
426
+
html_signature list_submissions show_submission track_submission
427
+
pending_only query days limit cancel_submission format : int =
428
+
(* Pack arguments into a record for easier passing *)
429
+
let args : identity_monitor_args = {
430
+
list_identities; show_identity; create_identity; identity_name;
431
+
reply_to; signature; html_signature; list_submissions;
432
+
show_submission; track_submission; pending_only; query;
433
+
days; limit; cancel_submission; format
434
+
} in
435
+
436
+
(* Main workflow would be implemented here using the JMAP library *)
437
+
Printf.printf "JMAP Identity & Submission Monitor\n";
438
+
Printf.printf "Server: %s\n" host;
439
+
Printf.printf "User: %s\n\n" user;
440
+
441
+
(* This is where the actual JMAP calls would happen, like:
442
+
443
+
let monitor_identities_and_submissions () =
444
+
let* (ctx, session) = Jmap.Unix.connect
445
+
~host ~username:user ~password
446
+
~auth_method:(Jmap.Unix.Basic(user, password)) () in
447
+
448
+
(* Get primary account ID *)
449
+
let account_id = match Jmap.get_primary_account session Jmap_email.capability_mail with
450
+
| Ok id -> id
451
+
| Error _ -> failwith "No mail account found"
452
+
in
453
+
454
+
(* Handle various command options *)
455
+
if args.list_identities then
456
+
(* Get all identities *)
457
+
let* identity_result = Jmap_email.Identity.get ctx
458
+
~account_id
459
+
~ids:None in
460
+
461
+
match identity_result with
462
+
| Error err -> Printf.eprintf "Error: %s\n" (Jmap.Error.error_to_string err); Lwt.return 1
463
+
| Ok (_, identities) ->
464
+
Printf.printf "Found %d identities:\n\n" (List.length identities);
465
+
identities |> List.iter (fun identity ->
466
+
format_identity identity args.format
467
+
);
468
+
Lwt.return 0
469
+
470
+
else if args.show_identity <> None then
471
+
(* Get specific identity *)
472
+
let id = Option.get args.show_identity in
473
+
let* identity_result = Jmap_email.Identity.get ctx
474
+
~account_id
475
+
~ids:[id] in
476
+
477
+
match identity_result with
478
+
| Error err -> Printf.eprintf "Error: %s\n" (Jmap.Error.error_to_string err); Lwt.return 1
479
+
| Ok (_, identities) ->
480
+
match identities with
481
+
| [identity] ->
482
+
format_identity identity args.format;
483
+
Lwt.return 0
484
+
| _ ->
485
+
Printf.eprintf "Identity not found: %s\n" id;
486
+
Lwt.return 1
487
+
488
+
else if args.create_identity <> None then
489
+
(* Create a new identity *)
490
+
let email = Option.get args.create_identity in
491
+
create_identity_command email args.identity_name args.reply_to
492
+
args.signature args.html_signature
493
+
494
+
else if args.list_submissions then
495
+
(* List all submissions, with optional filtering *)
496
+
...
497
+
498
+
else if args.show_submission <> None then
499
+
(* Show specific submission details *)
500
+
...
501
+
502
+
else if args.track_submission <> None then
503
+
(* Track delivery status for a specific submission *)
504
+
...
505
+
506
+
else if args.cancel_submission <> None then
507
+
(* Cancel a pending submission *)
508
+
...
509
+
510
+
else
511
+
(* No specific command given, show help *)
512
+
Printf.printf "Please specify a command. Use --help for options.\n";
513
+
Lwt.return 1
514
+
*)
515
+
516
+
(if list_identities then begin
517
+
(* Simulate listing identities *)
518
+
Printf.printf "Found 3 identities:\n\n";
519
+
Printf.printf "id1: John Doe <john@example.com>\n";
520
+
Printf.printf "id2: John Work <john@work.example.com>\n";
521
+
Printf.printf "id3: Support <support@example.com>\n"
522
+
end
523
+
else if show_identity <> None then begin
524
+
(* Simulate showing a specific identity *)
525
+
Printf.printf "Identity: %s\n" (Option.get show_identity);
526
+
Printf.printf " Name: John Doe\n";
527
+
Printf.printf " Email: john@example.com\n";
528
+
Printf.printf " Reply-To: (none)\n";
529
+
Printf.printf " BCC: (none)\n";
530
+
Printf.printf " Signature: Best regards,\nJohn\n";
531
+
Printf.printf " Deletable: Yes\n"
532
+
end
533
+
534
+
else if create_identity <> None then begin
535
+
(* Create a new identity *)
536
+
create_identity_command (Option.get create_identity) identity_name reply_to
537
+
signature html_signature |> ignore
538
+
end
539
+
else if list_submissions then begin
540
+
(* Simulate listing submissions *)
541
+
Printf.printf "Recent submissions (last %d days):\n\n" days;
542
+
Printf.printf "sub1: [Final] Sent at 2023-01-15 10:30:45 (Email ID: email1, Recipients: 3)\n";
543
+
Printf.printf "sub2: [Final] Sent at 2023-01-14 08:15:22 (Email ID: email2, Recipients: 1)\n";
544
+
Printf.printf "sub3: [Pending] Sent at 2023-01-13 16:45:10 (Email ID: email3, Recipients: 5)\n"
545
+
end
546
+
else if show_submission <> None then begin
547
+
(* Simulate showing a specific submission *)
548
+
Printf.printf "Submission: %s\n" (Option.get show_submission);
549
+
Printf.printf " Status: Final\n";
550
+
Printf.printf " Sent at: 2023-01-15 10:30:45\n";
551
+
Printf.printf " Email ID: email1\n";
552
+
Printf.printf " Thread ID: thread1\n";
553
+
Printf.printf " Identity: id1\n";
554
+
Printf.printf " Envelope:\n";
555
+
Printf.printf " From: john@example.com\n";
556
+
Printf.printf " To: alice@example.com, bob@example.com, carol@example.com\n";
557
+
Printf.printf " Delivery Status:\n";
558
+
Printf.printf " alice@example.com: Delivered, Displayed\n";
559
+
Printf.printf " SMTP Reply: 250 OK\n";
560
+
Printf.printf " bob@example.com: Delivered, Unknown if displayed\n";
561
+
Printf.printf " SMTP Reply: 250 OK\n";
562
+
Printf.printf " carol@example.com: Failed\n";
563
+
Printf.printf " SMTP Reply: 550 Mailbox unavailable\n"
564
+
end
565
+
else if track_submission <> None then begin
566
+
(* Simulate tracking a submission *)
567
+
Printf.printf "Tracking delivery status for submission: %s\n\n" (Option.get track_submission);
568
+
Printf.printf "Submission %s: Final\n" (Option.get track_submission);
569
+
Printf.printf " Total recipients: 3\n";
570
+
Printf.printf " Delivered: 2\n";
571
+
Printf.printf " Failed: 1\n";
572
+
Printf.printf " Queued: 0\n"
573
+
end
574
+
else if cancel_submission <> None then begin
575
+
(* Simulate canceling a submission *)
576
+
Printf.printf "Canceling submission: %s\n" (Option.get cancel_submission);
577
+
Printf.printf "Submission has been canceled successfully.\n"
578
+
end
579
+
else
580
+
(* No specific command given, show help *)
581
+
begin
582
+
Printf.printf "Please specify a command. Use --help for options.\n";
583
+
Printf.printf "Example commands:\n";
584
+
Printf.printf " --list-identities List all email identities\n";
585
+
Printf.printf " --show-identity id1 Show details for identity 'id1'\n";
586
+
Printf.printf " --list-submissions List recent email submissions\n";
587
+
Printf.printf " --track sub1 Track delivery status for submission 'sub1'\n"
588
+
end);
589
+
590
+
(* Since we're only type checking, we'll exit with success *)
591
+
0
592
+
593
+
(* Command definition *)
594
+
let identity_cmd =
595
+
let doc = "monitor email identities and submissions using JMAP" in
596
+
let man = [
597
+
`S Manpage.s_description;
598
+
`P "Provides identity management and email submission tracking functionality.";
599
+
`P "Demonstrates JMAP's identity and email submission monitoring capabilities.";
600
+
`S Manpage.s_examples;
601
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --list-identities";
602
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --create-identity backup@example.com --name \"Backup Account\"";
603
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --list-submissions --days 3";
604
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --track sub12345 --format status-only";
605
+
] in
606
+
607
+
let cmd =
608
+
Cmd.v
609
+
(Cmd.info "jmap-identity-monitor" ~version:"1.0" ~doc ~man)
610
+
Term.(const identity_command $ host_arg $ user_arg $ password_arg $
611
+
list_identities_arg $ show_identity_arg $ create_identity_arg $
612
+
identity_name_arg $ reply_to_arg $ signature_arg $ html_signature_arg $
613
+
list_submissions_arg $ show_submission_arg $ track_submission_arg $
614
+
pending_only_arg $ query_arg $ days_arg $ limit_arg $
615
+
cancel_submission_arg $ format_arg)
616
+
in
617
+
cmd
618
+
619
+
(* Main entry point *)
620
+
let () = exit (Cmd.eval' identity_cmd)
+420
bin/jmap_mailbox_explorer.ml
+420
bin/jmap_mailbox_explorer.ml
···
1
+
(*
2
+
* jmap_mailbox_explorer.ml - A tool for exploring email mailboxes using JMAP
3
+
*
4
+
* This binary demonstrates JMAP's mailbox query and manipulation capabilities,
5
+
* allowing for exploring, creating, and analyzing mailboxes.
6
+
*)
7
+
8
+
open Cmdliner
9
+
(* Using standard OCaml, no Lwt *)
10
+
11
+
(* JMAP imports *)
12
+
open Jmap
13
+
open Jmap.Types
14
+
open Jmap.Wire
15
+
open Jmap.Methods
16
+
open Jmap_email
17
+
(* For step 2, we're only testing type checking. No implementations required. *)
18
+
19
+
(* JMAP mailbox handling *)
20
+
module Jmap_mailbox = struct
21
+
(* Dummy mailbox functions *)
22
+
let id mailbox = "mailbox-id"
23
+
let name mailbox = "mailbox-name"
24
+
let parent_id mailbox = None
25
+
let role mailbox = None
26
+
let total_emails mailbox = 0
27
+
let unread_emails mailbox = 0
28
+
end
29
+
30
+
(* Unix implementation would be used here *)
31
+
module Unix = struct
32
+
let connect ~host ~username ~password ?auth_method () =
33
+
failwith "Not implemented"
34
+
end
35
+
36
+
(** Types for mailbox explorer *)
37
+
type mailbox_stats = {
38
+
time_periods : (string * int) list;
39
+
senders : (string * int) list;
40
+
subjects : (string * int) list;
41
+
}
42
+
43
+
type mailbox_explorer_args = {
44
+
list : bool;
45
+
stats : bool;
46
+
mailbox : string option;
47
+
create : string option;
48
+
parent : string option;
49
+
query_mailbox : string option;
50
+
days : int;
51
+
format : [`Tree | `Flat | `Json];
52
+
}
53
+
54
+
(** Command-line arguments **)
55
+
56
+
let host_arg =
57
+
Arg.(required & opt (some string) None & info ["h"; "host"]
58
+
~docv:"HOST" ~doc:"JMAP server hostname")
59
+
60
+
let user_arg =
61
+
Arg.(required & opt (some string) None & info ["u"; "user"]
62
+
~docv:"USERNAME" ~doc:"Username for authentication")
63
+
64
+
let password_arg =
65
+
Arg.(required & opt (some string) None & info ["p"; "password"]
66
+
~docv:"PASSWORD" ~doc:"Password for authentication")
67
+
68
+
let list_arg =
69
+
Arg.(value & flag & info ["l"; "list"] ~doc:"List all mailboxes")
70
+
71
+
let stats_arg =
72
+
Arg.(value & flag & info ["s"; "stats"] ~doc:"Show mailbox statistics")
73
+
74
+
let mailbox_arg =
75
+
Arg.(value & opt (some string) None & info ["m"; "mailbox"]
76
+
~docv:"MAILBOX" ~doc:"Filter by mailbox name")
77
+
78
+
let create_arg =
79
+
Arg.(value & opt (some string) None & info ["create"]
80
+
~docv:"NAME" ~doc:"Create a new mailbox")
81
+
82
+
let parent_arg =
83
+
Arg.(value & opt (some string) None & info ["parent"]
84
+
~docv:"PARENT" ~doc:"Parent mailbox for creation")
85
+
86
+
let query_mailbox_arg =
87
+
Arg.(value & opt (some string) None & info ["query"]
88
+
~docv:"QUERY" ~doc:"Query emails in the specified mailbox")
89
+
90
+
let days_arg =
91
+
Arg.(value & opt int 7 & info ["days"]
92
+
~docv:"DAYS" ~doc:"Days to analyze for mailbox statistics")
93
+
94
+
let format_arg =
95
+
Arg.(value & opt (enum [
96
+
"tree", `Tree;
97
+
"flat", `Flat;
98
+
"json", `Json;
99
+
]) `Tree & info ["format"] ~docv:"FORMAT" ~doc:"Output format")
100
+
101
+
(** Mailbox Explorer Functionality **)
102
+
103
+
(* Get standard role name for display *)
104
+
let role_name = function
105
+
| `Inbox -> "Inbox"
106
+
| `Archive -> "Archive"
107
+
| `Drafts -> "Drafts"
108
+
| `Sent -> "Sent"
109
+
| `Trash -> "Trash"
110
+
| `Junk -> "Junk"
111
+
| `Important -> "Important"
112
+
| `Flagged -> "Flagged"
113
+
| `Snoozed -> "Snoozed"
114
+
| `Scheduled -> "Scheduled"
115
+
| `Memos -> "Memos"
116
+
| `Other name -> name
117
+
| `None -> "(No role)"
118
+
119
+
(* Display mailboxes in tree format *)
120
+
let display_mailbox_tree mailboxes format stats =
121
+
(* Helper to find children of a parent *)
122
+
let find_children parent_id =
123
+
mailboxes |> List.filter (fun mailbox ->
124
+
match Jmap_mailbox.parent_id mailbox with
125
+
| Some id when id = parent_id -> true
126
+
| _ -> false
127
+
)
128
+
in
129
+
130
+
(* Helper to find mailboxes without a parent (root level) *)
131
+
let find_roots () =
132
+
mailboxes |> List.filter (fun mailbox ->
133
+
Jmap_mailbox.parent_id mailbox = None
134
+
)
135
+
in
136
+
137
+
(* Get mailbox name with role *)
138
+
let mailbox_name_with_role mailbox =
139
+
let name = Jmap_mailbox.name mailbox in
140
+
match Jmap_mailbox.role mailbox with
141
+
| Some role -> Printf.sprintf "%s (%s)" name (role_name role)
142
+
| None -> name
143
+
in
144
+
145
+
(* Helper to get statistics for a mailbox *)
146
+
let get_stats mailbox =
147
+
let id = Jmap_mailbox.id mailbox in
148
+
let total = Jmap_mailbox.total_emails mailbox in
149
+
let unread = Jmap_mailbox.unread_emails mailbox in
150
+
151
+
match Hashtbl.find_opt stats id with
152
+
| Some mailbox_stats ->
153
+
let recent = match List.assoc_opt "Last week" mailbox_stats.time_periods with
154
+
| Some count -> count
155
+
| None -> 0
156
+
in
157
+
(total, unread, recent)
158
+
| None -> (total, unread, 0)
159
+
in
160
+
161
+
(* Helper to print a JSON representation *)
162
+
let print_json_mailbox mailbox indent =
163
+
let id = Jmap_mailbox.id mailbox in
164
+
let name = Jmap_mailbox.name mailbox in
165
+
let role = match Jmap_mailbox.role mailbox with
166
+
| Some role -> Printf.sprintf "\"%s\"" (role_name role)
167
+
| None -> "null"
168
+
in
169
+
let total, unread, recent = get_stats mailbox in
170
+
171
+
let indent_str = String.make indent ' ' in
172
+
Printf.printf "%s{\n" indent_str;
173
+
Printf.printf "%s \"id\": \"%s\",\n" indent_str id;
174
+
Printf.printf "%s \"name\": \"%s\",\n" indent_str name;
175
+
Printf.printf "%s \"role\": %s,\n" indent_str role;
176
+
Printf.printf "%s \"totalEmails\": %d,\n" indent_str total;
177
+
Printf.printf "%s \"unreadEmails\": %d,\n" indent_str unread;
178
+
Printf.printf "%s \"recentEmails\": %d\n" indent_str recent;
179
+
Printf.printf "%s}" indent_str
180
+
in
181
+
182
+
(* Recursive function to print a tree of mailboxes *)
183
+
let rec print_tree_level mailboxes level =
184
+
mailboxes |> List.iteri (fun i mailbox ->
185
+
let id = Jmap_mailbox.id mailbox in
186
+
let name = mailbox_name_with_role mailbox in
187
+
let total, unread, recent = get_stats mailbox in
188
+
189
+
let indent = String.make (level * 2) ' ' in
190
+
let is_last = i = List.length mailboxes - 1 in
191
+
let prefix = if level = 0 then "" else
192
+
if is_last then "โโโ " else "โโโ " in
193
+
194
+
match format with
195
+
| `Tree ->
196
+
Printf.printf "%s%s%s" indent prefix name;
197
+
if stats <> Hashtbl.create 0 then
198
+
Printf.printf " (%d emails, %d unread, %d recent)" total unread recent;
199
+
Printf.printf "\n";
200
+
201
+
(* Print children *)
202
+
let children = find_children id in
203
+
let child_indent = level + 1 in
204
+
print_tree_level children child_indent
205
+
206
+
| `Flat ->
207
+
Printf.printf "%s [%s]\n" name id;
208
+
if stats <> Hashtbl.create 0 then
209
+
Printf.printf " Emails: %d total, %d unread, %d in last week\n"
210
+
total unread recent;
211
+
212
+
(* Print children *)
213
+
let children = find_children id in
214
+
print_tree_level children 0
215
+
216
+
| `Json ->
217
+
print_json_mailbox mailbox (level * 2);
218
+
219
+
(* Handle commas between mailboxes *)
220
+
let children = find_children id in
221
+
if children <> [] || (not is_last) then Printf.printf ",\n" else Printf.printf "\n";
222
+
223
+
(* Print children as a "children" array *)
224
+
if children <> [] then begin
225
+
Printf.printf "%s\"children\": [\n" (String.make ((level * 2) + 2) ' ');
226
+
print_tree_level children (level + 2);
227
+
Printf.printf "%s]\n" (String.make ((level * 2) + 2) ' ');
228
+
229
+
(* Add comma if not the last mailbox *)
230
+
if not is_last then Printf.printf "%s,\n" (String.make (level * 2) ' ');
231
+
end
232
+
)
233
+
in
234
+
235
+
(* Print the mailbox tree *)
236
+
match format with
237
+
| `Tree | `Flat ->
238
+
Printf.printf "Mailboxes:\n";
239
+
print_tree_level (find_roots()) 0
240
+
| `Json ->
241
+
Printf.printf "{\n";
242
+
Printf.printf " \"mailboxes\": [\n";
243
+
print_tree_level (find_roots()) 1;
244
+
Printf.printf " ]\n";
245
+
Printf.printf "}\n"
246
+
247
+
(* Command implementation *)
248
+
let mailbox_command host user password list stats mailbox create parent
249
+
query_mailbox days format : int =
250
+
(* Pack arguments into a record for easier passing *)
251
+
let args : mailbox_explorer_args = {
252
+
list; stats; mailbox; create; parent;
253
+
query_mailbox; days; format
254
+
} in
255
+
256
+
(* Main workflow would be implemented here using the JMAP library *)
257
+
Printf.printf "JMAP Mailbox Explorer\n";
258
+
Printf.printf "Server: %s\n" host;
259
+
Printf.printf "User: %s\n\n" user;
260
+
261
+
(* This is where the actual JMAP calls would happen, like:
262
+
263
+
let explore_mailboxes () =
264
+
let* (ctx, session) = Jmap.Unix.connect
265
+
~host ~username:user ~password
266
+
~auth_method:(Jmap.Unix.Basic(user, password)) () in
267
+
268
+
(* Get primary account ID *)
269
+
let account_id = match Jmap.get_primary_account session Jmap_email.capability_mail with
270
+
| Ok id -> id
271
+
| Error _ -> failwith "No mail account found"
272
+
in
273
+
274
+
(* Create a new mailbox if requested *)
275
+
if args.create <> None then
276
+
let name = Option.get args.create in
277
+
let parent_id_opt = match args.parent with
278
+
| None -> None
279
+
| Some parent_name ->
280
+
(* Resolve parent name to ID - would need to search for it *)
281
+
None (* This would actually find or return an error *)
282
+
in
283
+
284
+
let create_mailbox = Jmap_mailbox.create
285
+
~name
286
+
?parent_id:parent_id_opt
287
+
() in
288
+
289
+
let* result = Jmap_mailbox.set ctx
290
+
~account_id
291
+
~create:(Hashtbl.of_seq (Seq.return ("new", create_mailbox)))
292
+
() in
293
+
294
+
(* Handle mailbox creation result *)
295
+
...
296
+
297
+
(* List mailboxes *)
298
+
if args.list || args.stats then
299
+
(* Query mailboxes *)
300
+
let filter =
301
+
if args.mailbox <> None then
302
+
Jmap_mailbox.filter_name_contains (Option.get args.mailbox)
303
+
else
304
+
Jmap_mailbox.Filter.condition (`Assoc [])
305
+
in
306
+
307
+
let* mailbox_ids = Jmap_mailbox.query ctx
308
+
~account_id
309
+
~filter
310
+
~sort:[Jmap_mailbox.sort_by_name () ]
311
+
() in
312
+
313
+
match mailbox_ids with
314
+
| Error err ->
315
+
Printf.eprintf "Error querying mailboxes: %s\n" (Jmap.Error.error_to_string err);
316
+
Lwt.return_unit
317
+
| Ok (ids, _) ->
318
+
(* Get full mailbox objects *)
319
+
let* mailboxes = Jmap_mailbox.get ctx
320
+
~account_id
321
+
~ids
322
+
~properties:["id"; "name"; "parentId"; "role"; "totalEmails"; "unreadEmails"] in
323
+
324
+
match mailboxes with
325
+
| Error err ->
326
+
Printf.eprintf "Error getting mailboxes: %s\n" (Jmap.Error.error_to_string err);
327
+
Lwt.return_unit
328
+
| Ok (_, mailbox_list) ->
329
+
(* If stats requested, gather email stats for each mailbox *)
330
+
let* stats_opt =
331
+
if args.stats then
332
+
(* For each mailbox, gather stats like weekly counts *)
333
+
...
334
+
else
335
+
Lwt.return (Hashtbl.create 0)
336
+
in
337
+
338
+
(* Display mailboxes in requested format *)
339
+
display_mailbox_tree mailbox_list args.format stats_opt;
340
+
Lwt.return_unit
341
+
342
+
(* Query emails in a specific mailbox *)
343
+
if args.query_mailbox <> None then
344
+
let mailbox_name = Option.get args.query_mailbox in
345
+
346
+
(* Find mailbox ID from name *)
347
+
...
348
+
349
+
(* Query emails in that mailbox *)
350
+
...
351
+
*)
352
+
353
+
if create <> None then
354
+
Printf.printf "Creating mailbox: %s\n" (Option.get create);
355
+
356
+
if list || stats then
357
+
Printf.printf "Listing mailboxes%s:\n"
358
+
(if stats then " with statistics" else "");
359
+
360
+
(* Example output for a tree of mailboxes *)
361
+
(match format with
362
+
| `Tree ->
363
+
Printf.printf "Mailboxes:\n";
364
+
Printf.printf "Inbox (14 emails, 3 unread, 5 recent)\n";
365
+
Printf.printf "โโโ Work (8 emails, 2 unread, 3 recent)\n";
366
+
Printf.printf "โ โโโ Project A (3 emails, 1 unread, 2 recent)\n";
367
+
Printf.printf "โโโ Personal (6 emails, 1 unread, 2 recent)\n"
368
+
| `Flat ->
369
+
Printf.printf "Inbox [mbox1]\n";
370
+
Printf.printf " Emails: 14 total, 3 unread, 5 in last week\n";
371
+
Printf.printf "Work [mbox2]\n";
372
+
Printf.printf " Emails: 8 total, 2 unread, 3 in last week\n";
373
+
Printf.printf "Project A [mbox3]\n";
374
+
Printf.printf " Emails: 3 total, 1 unread, 2 in last week\n";
375
+
Printf.printf "Personal [mbox4]\n";
376
+
Printf.printf " Emails: 6 total, 1 unread, 2 in last week\n"
377
+
| `Json ->
378
+
Printf.printf "{\n";
379
+
Printf.printf " \"mailboxes\": [\n";
380
+
Printf.printf " {\n";
381
+
Printf.printf " \"id\": \"mbox1\",\n";
382
+
Printf.printf " \"name\": \"Inbox\",\n";
383
+
Printf.printf " \"role\": \"Inbox\",\n";
384
+
Printf.printf " \"totalEmails\": 14,\n";
385
+
Printf.printf " \"unreadEmails\": 3,\n";
386
+
Printf.printf " \"recentEmails\": 5\n";
387
+
Printf.printf " }\n";
388
+
Printf.printf " ]\n";
389
+
Printf.printf "}\n");
390
+
391
+
if query_mailbox <> None then
392
+
Printf.printf "\nQuerying emails in mailbox: %s\n" (Option.get query_mailbox);
393
+
394
+
(* Since we're only type checking, we'll exit with success *)
395
+
0
396
+
397
+
(* Command definition *)
398
+
let mailbox_cmd =
399
+
let doc = "explore and manage mailboxes using JMAP" in
400
+
let man = [
401
+
`S Manpage.s_description;
402
+
`P "Lists, creates, and analyzes email mailboxes using JMAP.";
403
+
`P "Demonstrates JMAP's mailbox query and management capabilities.";
404
+
`S Manpage.s_examples;
405
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --list";
406
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --stats --mailbox Inbox";
407
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --create \"Work/Project X\" --parent Work";
408
+
] in
409
+
410
+
let cmd =
411
+
Cmd.v
412
+
(Cmd.info "jmap-mailbox-explorer" ~version:"1.0" ~doc ~man)
413
+
Term.(const mailbox_command $ host_arg $ user_arg $ password_arg $
414
+
list_arg $ stats_arg $ mailbox_arg $ create_arg $
415
+
parent_arg $ query_mailbox_arg $ days_arg $ format_arg)
416
+
in
417
+
cmd
418
+
419
+
(* Main entry point *)
420
+
let () = exit (Cmd.eval' mailbox_cmd)
+238
bin/jmap_push_listener.ml
+238
bin/jmap_push_listener.ml
···
1
+
(*
2
+
* jmap_push_listener.ml - Monitor real-time changes via JMAP push notifications
3
+
*
4
+
* This binary demonstrates JMAP's push notification capabilities for monitoring
5
+
* changes to emails, mailboxes, and other data in real-time.
6
+
*
7
+
* For step 2, we're only testing type checking. No implementations required.
8
+
*)
9
+
10
+
open Cmdliner
11
+
12
+
(** Push notification types to monitor **)
13
+
type monitor_types = {
14
+
emails : bool;
15
+
mailboxes : bool;
16
+
threads : bool;
17
+
identities : bool;
18
+
submissions : bool;
19
+
all : bool;
20
+
}
21
+
22
+
(** Command-line arguments **)
23
+
24
+
let host_arg =
25
+
Arg.(required & opt (some string) None & info ["h"; "host"]
26
+
~docv:"HOST" ~doc:"JMAP server hostname")
27
+
28
+
let user_arg =
29
+
Arg.(required & opt (some string) None & info ["u"; "user"]
30
+
~docv:"USERNAME" ~doc:"Username for authentication")
31
+
32
+
let password_arg =
33
+
Arg.(required & opt (some string) None & info ["p"; "password"]
34
+
~docv:"PASSWORD" ~doc:"Password for authentication")
35
+
36
+
let monitor_emails_arg =
37
+
Arg.(value & flag & info ["emails"]
38
+
~doc:"Monitor email changes")
39
+
40
+
let monitor_mailboxes_arg =
41
+
Arg.(value & flag & info ["mailboxes"]
42
+
~doc:"Monitor mailbox changes")
43
+
44
+
let monitor_threads_arg =
45
+
Arg.(value & flag & info ["threads"]
46
+
~doc:"Monitor thread changes")
47
+
48
+
let monitor_identities_arg =
49
+
Arg.(value & flag & info ["identities"]
50
+
~doc:"Monitor identity changes")
51
+
52
+
let monitor_submissions_arg =
53
+
Arg.(value & flag & info ["submissions"]
54
+
~doc:"Monitor email submission changes")
55
+
56
+
let monitor_all_arg =
57
+
Arg.(value & flag & info ["all"]
58
+
~doc:"Monitor all supported types")
59
+
60
+
let verbose_arg =
61
+
Arg.(value & flag & info ["v"; "verbose"]
62
+
~doc:"Show detailed information about changes")
63
+
64
+
let timeout_arg =
65
+
Arg.(value & opt int 300 & info ["t"; "timeout"]
66
+
~docv:"SECONDS" ~doc:"Timeout for push connections (default: 300)")
67
+
68
+
(** Helper functions **)
69
+
70
+
(* Format timestamp *)
71
+
let format_timestamp () =
72
+
let time = Unix.gettimeofday () in
73
+
let tm = Unix.localtime time in
74
+
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d"
75
+
(tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
76
+
tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
77
+
78
+
(* Print change notification *)
79
+
let print_change data_type change_type details verbose =
80
+
let timestamp = format_timestamp () in
81
+
Printf.printf "[%s] %s %s" timestamp data_type change_type;
82
+
if verbose && details <> "" then
83
+
Printf.printf ": %s" details;
84
+
Printf.printf "\n";
85
+
flush stdout
86
+
87
+
(* Monitor using polling simulation *)
88
+
let monitor_changes _ctx _session _account_id monitor verbose timeout =
89
+
Printf.printf "Starting change monitoring (simulated)...\n\n";
90
+
91
+
(* Types to monitor *)
92
+
let types = ref [] in
93
+
if monitor.emails || monitor.all then types := "Email" :: !types;
94
+
if monitor.mailboxes || monitor.all then types := "Mailbox" :: !types;
95
+
if monitor.threads || monitor.all then types := "Thread" :: !types;
96
+
if monitor.identities || monitor.all then types := "Identity" :: !types;
97
+
if monitor.submissions || monitor.all then types := "EmailSubmission" :: !types;
98
+
99
+
Printf.printf "Monitoring: %s\n\n" (String.concat ", " !types);
100
+
101
+
(* In a real implementation, we would:
102
+
1. Use EventSource or long polling
103
+
2. Track state changes per type
104
+
3. Fetch and display actual changes
105
+
106
+
For this demo, we'll simulate monitoring *)
107
+
108
+
let rec monitor_loop count =
109
+
(* Make a simple echo request to stay connected *)
110
+
let invocation = Jmap.Wire.Invocation.v
111
+
~method_name:"Core/echo"
112
+
~arguments:(`Assoc ["ping", `String "keepalive"])
113
+
~method_call_id:"echo1"
114
+
() in
115
+
116
+
let request = Jmap.Wire.Request.v
117
+
~using:[Jmap.capability_core; Jmap_email.capability_mail]
118
+
~method_calls:[invocation]
119
+
() in
120
+
121
+
match Jmap_unix.request _ctx request with
122
+
| Ok _ ->
123
+
(* Simulate random changes for demonstration *)
124
+
if count mod 3 = 0 && !types <> [] then (
125
+
let changed_type = List.nth !types (Random.int (List.length !types)) in
126
+
let change_details = match changed_type with
127
+
| "Email" -> "2 new, 1 updated"
128
+
| "Mailbox" -> "1 updated (Inbox)"
129
+
| "Thread" -> "3 updated"
130
+
| "Identity" -> "settings changed"
131
+
| "EmailSubmission" -> "1 sent"
132
+
| _ -> "changed"
133
+
in
134
+
print_change changed_type "changed" change_details verbose
135
+
);
136
+
137
+
(* Wait before next check *)
138
+
Unix.sleep 5;
139
+
140
+
if count < timeout / 5 then
141
+
monitor_loop (count + 1)
142
+
else (
143
+
Printf.printf "\nMonitoring timeout reached.\n";
144
+
0
145
+
)
146
+
| Error e ->
147
+
Printf.eprintf "Connection error: %s\n" (Jmap.Error.error_to_string e);
148
+
1
149
+
in
150
+
151
+
monitor_loop 0
152
+
153
+
(* Command implementation *)
154
+
let listen_command host user password emails mailboxes threads identities
155
+
submissions all verbose timeout : int =
156
+
Printf.printf "JMAP Push Listener\n";
157
+
Printf.printf "Server: %s\n" host;
158
+
Printf.printf "User: %s\n\n" user;
159
+
160
+
(* Build monitor options *)
161
+
let monitor = {
162
+
emails;
163
+
mailboxes;
164
+
threads;
165
+
identities;
166
+
submissions;
167
+
all;
168
+
} in
169
+
170
+
(* Check that at least one type is selected *)
171
+
if not (emails || mailboxes || threads || identities || submissions || all) then (
172
+
Printf.eprintf "Error: Must specify at least one type to monitor (or --all)\n";
173
+
exit 1
174
+
);
175
+
176
+
(* Initialize random for simulation *)
177
+
Random.self_init ();
178
+
179
+
(* Connect to server *)
180
+
let ctx = Jmap_unix.create_client () in
181
+
let result = Jmap_unix.quick_connect ~host ~username:user ~password in
182
+
183
+
let (ctx, session) = match result with
184
+
| Ok (ctx, session) -> (ctx, session)
185
+
| Error e ->
186
+
Printf.eprintf "Connection failed: %s\n" (Jmap.Error.error_to_string e);
187
+
exit 1
188
+
in
189
+
190
+
(* Get the primary account ID *)
191
+
let account_id = match Jmap.get_primary_account session Jmap_email.capability_mail with
192
+
| Ok id -> id
193
+
| Error e ->
194
+
Printf.eprintf "No mail account found: %s\n" (Jmap.Error.error_to_string e);
195
+
exit 1
196
+
in
197
+
198
+
(* Check EventSource URL availability *)
199
+
let event_source_url = Jmap.Session.Session.event_source_url session in
200
+
if Uri.to_string event_source_url <> "" then
201
+
Printf.printf "Note: Server supports EventSource at: %s\n\n" (Uri.to_string event_source_url)
202
+
else
203
+
Printf.printf "Note: Server doesn't advertise EventSource support\n\n";
204
+
205
+
(* Monitor for changes *)
206
+
monitor_changes ctx session account_id monitor verbose timeout
207
+
208
+
(* Command definition *)
209
+
let listen_cmd =
210
+
let doc = "monitor real-time changes via JMAP push notifications" in
211
+
let man = [
212
+
`S Manpage.s_description;
213
+
`P "Monitor real-time changes to JMAP data using push notifications.";
214
+
`P "Supports both EventSource and long-polling methods.";
215
+
`P "Shows when emails, mailboxes, threads, and other data change.";
216
+
`S Manpage.s_examples;
217
+
`P "Monitor all changes:";
218
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --all";
219
+
`P "";
220
+
`P "Monitor only emails and mailboxes with details:";
221
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --emails --mailboxes -v";
222
+
`P "";
223
+
`P "Monitor with custom timeout:";
224
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --all -t 600";
225
+
] in
226
+
227
+
let cmd =
228
+
Cmd.v
229
+
(Cmd.info "jmap-push-listener" ~version:"1.0" ~doc ~man)
230
+
Term.(const listen_command $ host_arg $ user_arg $ password_arg $
231
+
monitor_emails_arg $ monitor_mailboxes_arg $ monitor_threads_arg $
232
+
monitor_identities_arg $ monitor_submissions_arg $ monitor_all_arg $
233
+
verbose_arg $ timeout_arg)
234
+
in
235
+
cmd
236
+
237
+
(* Main entry point *)
238
+
let () = exit (Cmd.eval' listen_cmd)
+533
bin/jmap_thread_analyzer.ml
+533
bin/jmap_thread_analyzer.ml
···
1
+
(*
2
+
* jmap_thread_analyzer.ml - A tool for analyzing email threads using JMAP
3
+
*
4
+
* This binary demonstrates the thread-related capabilities of JMAP,
5
+
* allowing visualization and analysis of conversation threads.
6
+
*)
7
+
8
+
open Cmdliner
9
+
(* Using standard OCaml, no Lwt *)
10
+
11
+
(* JMAP imports *)
12
+
open Jmap
13
+
open Jmap.Types
14
+
open Jmap.Wire
15
+
open Jmap.Methods
16
+
open Jmap_email
17
+
(* For step 2, we're only testing type checking. No implementations required. *)
18
+
19
+
(* Dummy Unix module for type checking *)
20
+
module Unix = struct
21
+
type tm = {
22
+
tm_sec : int;
23
+
tm_min : int;
24
+
tm_hour : int;
25
+
tm_mday : int;
26
+
tm_mon : int;
27
+
tm_year : int;
28
+
tm_wday : int;
29
+
tm_yday : int;
30
+
tm_isdst : bool
31
+
}
32
+
33
+
let time () = 0.0
34
+
let gettimeofday () = 0.0
35
+
let mktime tm = (0.0, tm)
36
+
let gmtime _time = {
37
+
tm_sec = 0; tm_min = 0; tm_hour = 0;
38
+
tm_mday = 1; tm_mon = 0; tm_year = 120;
39
+
tm_wday = 0; tm_yday = 0; tm_isdst = false;
40
+
}
41
+
42
+
(* JMAP connection function - would be in a real implementation *)
43
+
let connect ~host ~username ~password ?auth_method () =
44
+
failwith "Not implemented"
45
+
end
46
+
47
+
(* Dummy ISO8601 module *)
48
+
module ISO8601 = struct
49
+
let string_of_datetime _tm = "2023-01-01T00:00:00Z"
50
+
end
51
+
52
+
(** Thread analyzer arguments *)
53
+
type thread_analyzer_args = {
54
+
thread_id : string option;
55
+
search : string option;
56
+
limit : int;
57
+
days : int;
58
+
subject : string option;
59
+
participants : string list;
60
+
format : [`Summary | `Detailed | `Timeline | `Graph];
61
+
include_body : bool;
62
+
}
63
+
64
+
(* Email filter helpers - stub implementations for type checking *)
65
+
module Email_filter = struct
66
+
let create_fulltext_filter text = Filter.condition (`Assoc [("text", `String text)])
67
+
let subject subj = Filter.condition (`Assoc [("subject", `String subj)])
68
+
let from email = Filter.condition (`Assoc [("from", `String email)])
69
+
let after date = Filter.condition (`Assoc [("receivedAt", `Assoc [("after", `Float date)])])
70
+
let before date = Filter.condition (`Assoc [("receivedAt", `Assoc [("before", `Float date)])])
71
+
let has_attachment () = Filter.condition (`Assoc [("hasAttachment", `Bool true)])
72
+
let unread () = Filter.condition (`Assoc [("isUnread", `Bool true)])
73
+
let in_mailbox id = Filter.condition (`Assoc [("inMailbox", `String id)])
74
+
let to_ email = Filter.condition (`Assoc [("to", `String email)])
75
+
end
76
+
77
+
(* Thread module stub *)
78
+
module Thread = struct
79
+
type t = {
80
+
id : string;
81
+
email_ids : string list;
82
+
}
83
+
84
+
let id thread = thread.id
85
+
let email_ids thread = thread.email_ids
86
+
end
87
+
88
+
(** Command-line arguments **)
89
+
90
+
let host_arg =
91
+
Arg.(required & opt (some string) None & info ["h"; "host"]
92
+
~docv:"HOST" ~doc:"JMAP server hostname")
93
+
94
+
let user_arg =
95
+
Arg.(required & opt (some string) None & info ["u"; "user"]
96
+
~docv:"USERNAME" ~doc:"Username for authentication")
97
+
98
+
let password_arg =
99
+
Arg.(required & opt (some string) None & info ["p"; "password"]
100
+
~docv:"PASSWORD" ~doc:"Password for authentication")
101
+
102
+
let thread_id_arg =
103
+
Arg.(value & opt (some string) None & info ["t"; "thread"]
104
+
~docv:"THREAD_ID" ~doc:"Analyze specific thread by ID")
105
+
106
+
let search_arg =
107
+
Arg.(value & opt (some string) None & info ["search"]
108
+
~docv:"QUERY" ~doc:"Search for threads containing text")
109
+
110
+
let limit_arg =
111
+
Arg.(value & opt int 10 & info ["limit"]
112
+
~docv:"N" ~doc:"Maximum number of threads to display")
113
+
114
+
let days_arg =
115
+
Arg.(value & opt int 30 & info ["days"]
116
+
~docv:"DAYS" ~doc:"Limit to threads from the past N days")
117
+
118
+
let subject_arg =
119
+
Arg.(value & opt (some string) None & info ["subject"]
120
+
~docv:"SUBJECT" ~doc:"Search threads by subject")
121
+
122
+
let participant_arg =
123
+
Arg.(value & opt_all string [] & info ["participant"]
124
+
~docv:"EMAIL" ~doc:"Filter by participant email")
125
+
126
+
let format_arg =
127
+
Arg.(value & opt (enum [
128
+
"summary", `Summary;
129
+
"detailed", `Detailed;
130
+
"timeline", `Timeline;
131
+
"graph", `Graph;
132
+
]) `Summary & info ["format"] ~docv:"FORMAT" ~doc:"Output format")
133
+
134
+
let include_body_arg =
135
+
Arg.(value & flag & info ["include-body"] ~doc:"Include message bodies in output")
136
+
137
+
(** Thread Analysis Functionality **)
138
+
139
+
(* Calculate days ago from a date *)
140
+
let days_ago date =
141
+
let now = Unix.gettimeofday() in
142
+
int_of_float ((now -. date) /. 86400.0)
143
+
144
+
(* Parse out email addresses from a participant string - simple version *)
145
+
let extract_email participant =
146
+
if String.contains participant '@' then participant
147
+
else participant ^ "@example.com" (* Default domain if none provided *)
148
+
149
+
(* Create filter for thread queries *)
150
+
let create_thread_filter args =
151
+
let open Email_filter in
152
+
let filters = [] in
153
+
154
+
(* Add search text condition *)
155
+
let filters = match args.search with
156
+
| None -> filters
157
+
| Some text -> create_fulltext_filter text :: filters
158
+
in
159
+
160
+
(* Add subject condition *)
161
+
let filters = match args.subject with
162
+
| None -> filters
163
+
| Some subj -> Email_filter.subject subj :: filters
164
+
in
165
+
166
+
(* Add date range based on days *)
167
+
let filters =
168
+
if args.days > 0 then
169
+
let now = Unix.gettimeofday() in
170
+
let past = now -. (float_of_int args.days *. 86400.0) in
171
+
after past :: filters
172
+
else
173
+
filters
174
+
in
175
+
176
+
(* Add participant filters *)
177
+
let filters =
178
+
List.fold_left (fun acc participant ->
179
+
let email = extract_email participant in
180
+
(* This would need more complex logic to check both from and to fields *)
181
+
from email :: acc
182
+
) filters args.participants
183
+
in
184
+
185
+
(* Combine all filters with AND *)
186
+
match filters with
187
+
| [] -> Filter.condition (`Assoc []) (* Empty filter *)
188
+
| [f] -> f
189
+
| filters -> Filter.and_ filters
190
+
191
+
(* Display thread in requested format *)
192
+
let display_thread thread emails format include_body snippet_map =
193
+
let thread_id = Thread.id thread in
194
+
let email_count = List.length (Thread.email_ids thread) in
195
+
196
+
(* Sort emails by date for proper display order *)
197
+
let sorted_emails = List.sort (fun e1 e2 ->
198
+
let date1 = Option.value (Types.Email.received_at e1) ~default:0.0 in
199
+
let date2 = Option.value (Types.Email.received_at e2) ~default:0.0 in
200
+
compare date1 date2
201
+
) emails in
202
+
203
+
(* Get a snippet for an email if available *)
204
+
let get_snippet email_id =
205
+
match Hashtbl.find_opt snippet_map email_id with
206
+
| Some snippet -> snippet
207
+
| None -> "(No preview available)"
208
+
in
209
+
210
+
match format with
211
+
| `Summary ->
212
+
Printf.printf "Thread: %s (%d messages)\n\n" thread_id email_count;
213
+
214
+
(* Print first email subject as thread subject *)
215
+
(match sorted_emails with
216
+
| first :: _ ->
217
+
let subject = Option.value (Types.Email.subject first) ~default:"(No subject)" in
218
+
Printf.printf "Subject: %s\n\n" subject
219
+
| [] -> Printf.printf "No emails available\n\n");
220
+
221
+
(* List participants *)
222
+
let participants = sorted_emails |> List.fold_left (fun acc email ->
223
+
let from_list = Option.value (Types.Email.from email) ~default:[] in
224
+
from_list |> List.fold_left (fun acc addr ->
225
+
let email = Types.Email_address.email addr in
226
+
if not (List.mem email acc) then email :: acc else acc
227
+
) acc
228
+
) [] in
229
+
230
+
Printf.printf "Participants: %s\n\n" (String.concat ", " participants);
231
+
232
+
(* Show timespan *)
233
+
(match sorted_emails with
234
+
| first :: _ :: _ :: _ -> (* At least a few messages *)
235
+
let first_date = Option.value (Types.Email.received_at first) ~default:0.0 in
236
+
let last_date = Option.value (Types.Email.received_at (List.hd (List.rev sorted_emails))) ~default:0.0 in
237
+
let datetime_str = ISO8601.string_of_datetime (Unix.gmtime first_date) in
238
+
let first_str = String.sub datetime_str 0 (min 19 (String.length datetime_str)) in
239
+
let datetime_str = ISO8601.string_of_datetime (Unix.gmtime last_date) in
240
+
let last_str = String.sub datetime_str 0 (min 19 (String.length datetime_str)) in
241
+
let duration_days = int_of_float ((last_date -. first_date) /. 86400.0) in
242
+
Printf.printf "Timespan: %s to %s (%d days)\n\n" first_str last_str duration_days
243
+
| _ -> ());
244
+
245
+
(* Show message count by participant *)
246
+
let message_counts = sorted_emails |> List.fold_left (fun acc email ->
247
+
let from_list = Option.value (Types.Email.from email) ~default:[] in
248
+
match from_list with
249
+
| addr :: _ ->
250
+
let email = Types.Email_address.email addr in
251
+
let count = try Hashtbl.find acc email with Not_found -> 0 in
252
+
Hashtbl.replace acc email (count + 1);
253
+
acc
254
+
| [] -> acc
255
+
) (Hashtbl.create 10) in
256
+
257
+
Printf.printf "Messages per participant:\n";
258
+
Hashtbl.iter (fun email count ->
259
+
Printf.printf " %s: %d messages\n" email count
260
+
) message_counts;
261
+
Printf.printf "\n"
262
+
263
+
| `Detailed ->
264
+
Printf.printf "Thread: %s (%d messages)\n\n" thread_id email_count;
265
+
266
+
(* Print detailed information for each email *)
267
+
sorted_emails |> List.iteri (fun i email ->
268
+
let id = Option.value (Types.Email.id email) ~default:"(unknown)" in
269
+
let subject = Option.value (Types.Email.subject email) ~default:"(No subject)" in
270
+
271
+
let from_list = Option.value (Types.Email.from email) ~default:[] in
272
+
let from = match from_list with
273
+
| addr :: _ -> Types.Email_address.email addr
274
+
| [] -> "(unknown)"
275
+
in
276
+
277
+
let date = match Types.Email.received_at email with
278
+
| Some d ->
279
+
let datetime_str = ISO8601.string_of_datetime (Unix.gmtime d) in
280
+
String.sub datetime_str 0 (min 19 (String.length datetime_str))
281
+
| None -> "(unknown)"
282
+
in
283
+
284
+
let days = match Types.Email.received_at email with
285
+
| Some d -> Printf.sprintf " (%d days ago)" (days_ago d)
286
+
| None -> ""
287
+
in
288
+
289
+
Printf.printf "Email %d of %d:\n" (i+1) email_count;
290
+
Printf.printf " ID: %s\n" id;
291
+
Printf.printf " Subject: %s\n" subject;
292
+
Printf.printf " From: %s\n" from;
293
+
Printf.printf " Date: %s%s\n" date days;
294
+
295
+
let keywords = match Types.Email.keywords email with
296
+
| Some kw -> Types.Keywords.custom_keywords kw |> String.concat ", "
297
+
| None -> "(none)"
298
+
in
299
+
if keywords <> "(none)" then
300
+
Printf.printf " Flags: %s\n" keywords;
301
+
302
+
(* Show preview from snippet if available *)
303
+
Printf.printf " Snippet: %s\n" (get_snippet id);
304
+
305
+
(* Show message body if requested *)
306
+
if include_body then
307
+
match Types.Email.text_body email with
308
+
| Some parts when parts <> [] ->
309
+
let first_part = List.hd parts in
310
+
Printf.printf " Body: %s\n" "(body content would be here in real implementation)";
311
+
| _ -> ();
312
+
313
+
Printf.printf "\n"
314
+
)
315
+
316
+
| `Timeline ->
317
+
Printf.printf "Timeline for Thread: %s\n\n" thread_id;
318
+
319
+
(* Get the first email's subject as thread subject *)
320
+
(match sorted_emails with
321
+
| first :: _ ->
322
+
let subject = Option.value (Types.Email.subject first) ~default:"(No subject)" in
323
+
Printf.printf "Subject: %s\n\n" subject
324
+
| [] -> Printf.printf "No emails available\n\n");
325
+
326
+
(* Create a timeline visualization *)
327
+
if sorted_emails = [] then
328
+
Printf.printf "No emails to display\n"
329
+
else
330
+
let first_email = List.hd sorted_emails in
331
+
let last_email = List.hd (List.rev sorted_emails) in
332
+
333
+
let first_date = Option.value (Types.Email.received_at first_email) ~default:0.0 in
334
+
let last_date = Option.value (Types.Email.received_at last_email) ~default:0.0 in
335
+
336
+
let total_duration = max 1.0 (last_date -. first_date) in
337
+
let timeline_width = 50 in
338
+
339
+
let datetime_str = ISO8601.string_of_datetime (Unix.gmtime first_date) in
340
+
let start_str = String.sub datetime_str 0 (min 19 (String.length datetime_str)) in
341
+
Printf.printf "Start date: %s\n" start_str;
342
+
343
+
let datetime_str = ISO8601.string_of_datetime (Unix.gmtime last_date) in
344
+
let end_str = String.sub datetime_str 0 (min 19 (String.length datetime_str)) in
345
+
Printf.printf "End date: %s\n\n" end_str;
346
+
347
+
Printf.printf "Timeline: [%s]\n" (String.make timeline_width '-');
348
+
349
+
sorted_emails |> List.iteri (fun i email ->
350
+
let date = Option.value (Types.Email.received_at email) ~default:0.0 in
351
+
let position = int_of_float (float_of_int timeline_width *. (date -. first_date) /. total_duration) in
352
+
353
+
let from_list = Option.value (Types.Email.from email) ~default:[] in
354
+
let from = match from_list with
355
+
| addr :: _ -> Types.Email_address.email addr
356
+
| [] -> "(unknown)"
357
+
in
358
+
359
+
let datetime_str = ISO8601.string_of_datetime (Unix.gmtime date) in
360
+
let date_str = String.sub datetime_str 0 (min 19 (String.length datetime_str)) in
361
+
362
+
let marker = String.make timeline_width ' ' |> String.mapi (fun j c ->
363
+
if j = position then '*' else if j < position then ' ' else c
364
+
) in
365
+
366
+
Printf.printf "%s [%s] %s: %s\n" date_str marker from (get_snippet (Option.value (Types.Email.id email) ~default:""))
367
+
);
368
+
369
+
Printf.printf "\n"
370
+
371
+
| `Graph ->
372
+
Printf.printf "Thread Graph for: %s\n\n" thread_id;
373
+
374
+
(* In a real implementation, this would build a proper thread graph based on
375
+
In-Reply-To and References headers. For this demo, we'll just show a simple tree. *)
376
+
377
+
(* Get the first email's subject as thread subject *)
378
+
(match sorted_emails with
379
+
| first :: _ ->
380
+
let subject = Option.value (Types.Email.subject first) ~default:"(No subject)" in
381
+
Printf.printf "Subject: %s\n\n" subject
382
+
| [] -> Printf.printf "No emails available\n\n");
383
+
384
+
(* Create a simple thread tree visualization *)
385
+
if sorted_emails = [] then
386
+
Printf.printf "No emails to display\n"
387
+
else
388
+
let indent level = String.make (level * 2) ' ' in
389
+
390
+
(* Very simplified threading model - in a real implementation,
391
+
this would use In-Reply-To and References headers *)
392
+
sorted_emails |> List.iteri (fun i email ->
393
+
let level = min i 4 in (* Simplified nesting - would be based on real reply chain *)
394
+
395
+
let id = Option.value (Types.Email.id email) ~default:"(unknown)" in
396
+
397
+
let from_list = Option.value (Types.Email.from email) ~default:[] in
398
+
let from = match from_list with
399
+
| addr :: _ -> Types.Email_address.email addr
400
+
| [] -> "(unknown)"
401
+
in
402
+
403
+
let date = match Types.Email.received_at email with
404
+
| Some d ->
405
+
let datetime_str = ISO8601.string_of_datetime (Unix.gmtime d) in
406
+
String.sub datetime_str 0 (min 19 (String.length datetime_str))
407
+
| None -> "(unknown)"
408
+
in
409
+
410
+
Printf.printf "%s%s [%s] %s\n"
411
+
(indent level)
412
+
(if level = 0 then "+" else if level = 1 then "|-" else "|--")
413
+
date from;
414
+
415
+
Printf.printf "%s%s\n" (indent (level + 4)) (get_snippet id);
416
+
);
417
+
418
+
Printf.printf "\n"
419
+
420
+
(* Command implementation *)
421
+
let thread_command host user password thread_id search limit days subject
422
+
participant format include_body : int =
423
+
(* Pack arguments into a record for easier passing *)
424
+
let args : thread_analyzer_args = {
425
+
thread_id; search; limit; days; subject;
426
+
participants = participant; format; include_body
427
+
} in
428
+
429
+
(* Main workflow would be implemented here using the JMAP library *)
430
+
Printf.printf "JMAP Thread Analyzer\n";
431
+
Printf.printf "Server: %s\n" host;
432
+
Printf.printf "User: %s\n\n" user;
433
+
434
+
(* This is where the actual JMAP calls would happen, like:
435
+
436
+
let analyze_threads () =
437
+
let* (ctx, session) = Jmap.Unix.connect
438
+
~host ~username:user ~password
439
+
~auth_method:(Jmap.Unix.Basic(user, password)) () in
440
+
441
+
(* Get primary account ID *)
442
+
let account_id = match Jmap.get_primary_account session Jmap_email.capability_mail with
443
+
| Ok id -> id
444
+
| Error _ -> failwith "No mail account found"
445
+
in
446
+
447
+
match args.thread_id with
448
+
| Some id ->
449
+
(* Analyze a specific thread by ID *)
450
+
let* thread_result = Thread.get ctx
451
+
~account_id
452
+
~ids:[id] in
453
+
454
+
(* Handle thread fetch result *)
455
+
...
456
+
457
+
| None ->
458
+
(* Search for threads based on criteria *)
459
+
let filter = create_thread_filter args in
460
+
461
+
(* Email/query to find emails matching criteria *)
462
+
let* query_result = Email.query ctx
463
+
~account_id
464
+
~filter
465
+
~sort:[Email_sort.received_newest_first ()]
466
+
~collapse_threads:true
467
+
~limit:args.limit in
468
+
469
+
(* Process query results to get thread IDs *)
470
+
...
471
+
*)
472
+
473
+
(match thread_id with
474
+
| Some id ->
475
+
Printf.printf "Analyzing thread: %s\n\n" id;
476
+
477
+
(* Simulate a thread with some emails *)
478
+
let emails = 5 in
479
+
Printf.printf "Thread contains %d emails\n" emails;
480
+
481
+
(* In a real implementation, we would display the actual thread data here *)
482
+
Printf.printf "Example output format would show thread details here\n"
483
+
484
+
| None ->
485
+
if search <> None then
486
+
Printf.printf "Searching for threads containing: %s\n" (Option.get search)
487
+
else if subject <> None then
488
+
Printf.printf "Searching for threads with subject: %s\n" (Option.get subject)
489
+
else
490
+
Printf.printf "No specific thread or search criteria provided\n");
491
+
492
+
if participant <> [] then
493
+
Printf.printf "Filtering to threads involving: %s\n"
494
+
(String.concat ", " participant);
495
+
496
+
Printf.printf "Looking at threads from the past %d days\n" days;
497
+
Printf.printf "Showing up to %d threads\n\n" limit;
498
+
499
+
(* Simulate finding some threads *)
500
+
let thread_count = min limit 3 in
501
+
Printf.printf "Found %d matching threads\n\n" thread_count;
502
+
503
+
(* In a real implementation, we would display the actual threads here *)
504
+
for i = 1 to thread_count do
505
+
Printf.printf "Thread %d would be displayed here\n\n" i
506
+
done;
507
+
508
+
(* Since we're only type checking, we'll exit with success *)
509
+
0
510
+
511
+
(* Command definition *)
512
+
let thread_cmd =
513
+
let doc = "analyze email threads using JMAP" in
514
+
let man = [
515
+
`S Manpage.s_description;
516
+
`P "Analyzes email threads with detailed visualization options.";
517
+
`P "Demonstrates how to work with JMAP's thread capabilities.";
518
+
`S Manpage.s_examples;
519
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 -t thread123";
520
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --search \"project update\" --format timeline";
521
+
] in
522
+
523
+
let cmd =
524
+
Cmd.v
525
+
(Cmd.info "jmap-thread-analyzer" ~version:"1.0" ~doc ~man)
526
+
Term.(const thread_command $ host_arg $ user_arg $ password_arg $
527
+
thread_id_arg $ search_arg $ limit_arg $ days_arg $
528
+
subject_arg $ participant_arg $ format_arg $ include_body_arg)
529
+
in
530
+
cmd
531
+
532
+
(* Main entry point *)
533
+
let () = exit (Cmd.eval' thread_cmd)
+406
bin/jmap_vacation_manager.ml
+406
bin/jmap_vacation_manager.ml
···
1
+
(*
2
+
* jmap_vacation_manager.ml - Manage vacation/out-of-office auto-responses
3
+
*
4
+
* This binary demonstrates JMAP's vacation response capabilities for setting
5
+
* up and managing automatic email responses.
6
+
*
7
+
* For step 2, we're only testing type checking. No implementations required.
8
+
*)
9
+
10
+
open Cmdliner
11
+
12
+
(** Vacation response actions **)
13
+
type vacation_action =
14
+
| Show
15
+
| Enable of vacation_config
16
+
| Disable
17
+
| Update of vacation_config
18
+
19
+
and vacation_config = {
20
+
subject : string option;
21
+
text_body : string;
22
+
html_body : string option;
23
+
from_date : float option;
24
+
to_date : float option;
25
+
exclude_addresses : string list;
26
+
}
27
+
28
+
(** Command-line arguments **)
29
+
30
+
let host_arg =
31
+
Arg.(required & opt (some string) None & info ["h"; "host"]
32
+
~docv:"HOST" ~doc:"JMAP server hostname")
33
+
34
+
let user_arg =
35
+
Arg.(required & opt (some string) None & info ["u"; "user"]
36
+
~docv:"USERNAME" ~doc:"Username for authentication")
37
+
38
+
let password_arg =
39
+
Arg.(required & opt (some string) None & info ["p"; "password"]
40
+
~docv:"PASSWORD" ~doc:"Password for authentication")
41
+
42
+
let enable_arg =
43
+
Arg.(value & flag & info ["e"; "enable"]
44
+
~doc:"Enable vacation response")
45
+
46
+
let disable_arg =
47
+
Arg.(value & flag & info ["d"; "disable"]
48
+
~doc:"Disable vacation response")
49
+
50
+
let show_arg =
51
+
Arg.(value & flag & info ["s"; "show"]
52
+
~doc:"Show current vacation settings")
53
+
54
+
let subject_arg =
55
+
Arg.(value & opt (some string) None & info ["subject"]
56
+
~docv:"SUBJECT" ~doc:"Vacation email subject line")
57
+
58
+
let message_arg =
59
+
Arg.(value & opt (some string) None & info ["m"; "message"]
60
+
~docv:"TEXT" ~doc:"Vacation message text")
61
+
62
+
let message_file_arg =
63
+
Arg.(value & opt (some string) None & info ["message-file"]
64
+
~docv:"FILE" ~doc:"Read vacation message from file")
65
+
66
+
let html_message_arg =
67
+
Arg.(value & opt (some string) None & info ["html-message"]
68
+
~docv:"HTML" ~doc:"HTML vacation message")
69
+
70
+
let from_date_arg =
71
+
Arg.(value & opt (some string) None & info ["from-date"]
72
+
~docv:"DATE" ~doc:"Start date for vacation (YYYY-MM-DD)")
73
+
74
+
let to_date_arg =
75
+
Arg.(value & opt (some string) None & info ["to-date"]
76
+
~docv:"DATE" ~doc:"End date for vacation (YYYY-MM-DD)")
77
+
78
+
let exclude_arg =
79
+
Arg.(value & opt_all string [] & info ["exclude"]
80
+
~docv:"EMAIL" ~doc:"Email address to exclude from auto-response")
81
+
82
+
(** Helper functions **)
83
+
84
+
(* Parse date string to Unix timestamp *)
85
+
let parse_date date_str =
86
+
try
87
+
let (year, month, day) = Scanf.sscanf date_str "%d-%d-%d" (fun y m d -> (y, m, d)) in
88
+
let tm = Unix.{ tm_sec = 0; tm_min = 0; tm_hour = 0;
89
+
tm_mday = day; tm_mon = month - 1; tm_year = year - 1900;
90
+
tm_wday = 0; tm_yday = 0; tm_isdst = false } in
91
+
Some (Unix.mktime tm |> fst)
92
+
with _ ->
93
+
Printf.eprintf "Invalid date format: %s (use YYYY-MM-DD)\n" date_str;
94
+
None
95
+
96
+
(* Format Unix timestamp as date string *)
97
+
let format_date timestamp =
98
+
let tm = Unix.localtime timestamp in
99
+
Printf.sprintf "%04d-%02d-%02d"
100
+
(tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
101
+
102
+
(* Read file contents *)
103
+
let read_file filename =
104
+
let ic = open_in filename in
105
+
let len = in_channel_length ic in
106
+
let content = really_input_string ic len in
107
+
close_in ic;
108
+
content
109
+
110
+
(* Display vacation response settings *)
111
+
let show_vacation_response vacation =
112
+
Printf.printf "\nVacation Response Settings:\n";
113
+
Printf.printf "==========================\n\n";
114
+
115
+
Printf.printf "Status: %s\n"
116
+
(if Jmap_email.Vacation.Vacation_response.is_enabled vacation then "ENABLED" else "DISABLED");
117
+
118
+
(match Jmap_email.Vacation.Vacation_response.subject vacation with
119
+
| Some subj -> Printf.printf "Subject: %s\n" subj
120
+
| None -> Printf.printf "Subject: (default)\n");
121
+
122
+
(match Jmap_email.Vacation.Vacation_response.text_body vacation with
123
+
| Some body ->
124
+
Printf.printf "\nMessage:\n";
125
+
Printf.printf "--------\n";
126
+
Printf.printf "%s\n" body;
127
+
Printf.printf "--------\n"
128
+
| None -> Printf.printf "\nMessage: (none set)\n");
129
+
130
+
(match Jmap_email.Vacation.Vacation_response.from_date vacation with
131
+
| Some date -> Printf.printf "\nActive from: %s\n" (format_date date)
132
+
| None -> ());
133
+
134
+
(match Jmap_email.Vacation.Vacation_response.to_date vacation with
135
+
| Some date -> Printf.printf "Active until: %s\n" (format_date date)
136
+
| None -> ());
137
+
138
+
let excluded = match Jmap_email.Vacation.Vacation_response.id vacation with
139
+
| _ -> [] (* exclude_addresses not available in interface *) in
140
+
if excluded <> [] then (
141
+
Printf.printf "\nExcluded addresses:\n";
142
+
List.iter (Printf.printf " - %s\n") excluded
143
+
)
144
+
145
+
(* Get current vacation response *)
146
+
let get_vacation_response ctx session account_id =
147
+
let get_args = Jmap.Methods.Get_args.v
148
+
~account_id
149
+
~properties:["isEnabled"; "subject"; "textBody"; "htmlBody";
150
+
"fromDate"; "toDate"; "excludeAddresses"]
151
+
() in
152
+
153
+
let invocation = Jmap.Wire.Invocation.v
154
+
~method_name:"VacationResponse/get"
155
+
~arguments:(`Assoc []) (* Would serialize get_args *)
156
+
~method_call_id:"get1"
157
+
() in
158
+
159
+
let request = Jmap.Wire.Request.v
160
+
~using:[Jmap.capability_core; Jmap_email.capability_mail; Jmap_email.capability_vacationresponse]
161
+
~method_calls:[invocation]
162
+
() in
163
+
164
+
match Jmap_unix.request ctx request with
165
+
| Ok _ ->
166
+
(* Would extract from response - for now create a sample *)
167
+
Ok (Jmap_email.Vacation.Vacation_response.v
168
+
~id:"vacation1"
169
+
~is_enabled:false
170
+
~subject:"Out of Office"
171
+
~text_body:"I am currently out of the office and will respond when I return."
172
+
())
173
+
| Error e -> Error e
174
+
175
+
(* Update vacation response *)
176
+
let update_vacation_response ctx session account_id vacation_id updates =
177
+
let update_map = Hashtbl.create 1 in
178
+
Hashtbl.add update_map vacation_id updates;
179
+
180
+
let set_args = Jmap.Methods.Set_args.v
181
+
~account_id
182
+
~update:update_map
183
+
() in
184
+
185
+
let invocation = Jmap.Wire.Invocation.v
186
+
~method_name:"VacationResponse/set"
187
+
~arguments:(`Assoc []) (* Would serialize set_args *)
188
+
~method_call_id:"set1"
189
+
() in
190
+
191
+
let request = Jmap.Wire.Request.v
192
+
~using:[Jmap.capability_core; Jmap_email.capability_mail; Jmap_email.capability_vacationresponse]
193
+
~method_calls:[invocation]
194
+
() in
195
+
196
+
match Jmap_unix.request ctx request with
197
+
| Ok _ -> Ok ()
198
+
| Error e -> Error e
199
+
200
+
(* Process vacation action *)
201
+
let process_vacation_action ctx session account_id action =
202
+
match action with
203
+
| Show ->
204
+
(match get_vacation_response ctx session account_id with
205
+
| Ok vacation ->
206
+
show_vacation_response vacation;
207
+
0
208
+
| Error e ->
209
+
Printf.eprintf "Failed to get vacation response: %s\n" (Jmap.Error.error_to_string e);
210
+
1)
211
+
212
+
| Enable config ->
213
+
Printf.printf "Enabling vacation response...\n";
214
+
215
+
(* Build the vacation response object *)
216
+
let vacation = Jmap_email.Vacation.Vacation_response.v
217
+
~id:"singleton"
218
+
~is_enabled:true
219
+
?subject:config.subject
220
+
~text_body:config.text_body
221
+
?html_body:config.html_body
222
+
?from_date:config.from_date
223
+
?to_date:config.to_date
224
+
() in
225
+
226
+
(match update_vacation_response ctx session account_id "singleton" vacation with
227
+
| Ok () ->
228
+
Printf.printf "\nVacation response enabled successfully!\n";
229
+
230
+
(* Show what was set *)
231
+
show_vacation_response vacation;
232
+
0
233
+
| Error e ->
234
+
Printf.eprintf "Failed to enable vacation response: %s\n" (Jmap.Error.error_to_string e);
235
+
1)
236
+
237
+
| Disable ->
238
+
Printf.printf "Disabling vacation response...\n";
239
+
240
+
let updates = Jmap_email.Vacation.Vacation_response.v
241
+
~id:"singleton"
242
+
~is_enabled:false
243
+
() in
244
+
245
+
(match update_vacation_response ctx session account_id "singleton" updates with
246
+
| Ok () ->
247
+
Printf.printf "Vacation response disabled successfully!\n";
248
+
0
249
+
| Error e ->
250
+
Printf.eprintf "Failed to disable vacation response: %s\n" (Jmap.Error.error_to_string e);
251
+
1)
252
+
253
+
| Update config ->
254
+
Printf.printf "Updating vacation response...\n";
255
+
256
+
(* Only update specified fields *)
257
+
let vacation = Jmap_email.Vacation.Vacation_response.v
258
+
~id:"singleton"
259
+
?subject:config.subject
260
+
~text_body:config.text_body
261
+
?html_body:config.html_body
262
+
?from_date:config.from_date
263
+
?to_date:config.to_date
264
+
() in
265
+
266
+
(match update_vacation_response ctx session account_id "singleton" vacation with
267
+
| Ok () ->
268
+
Printf.printf "Vacation response updated successfully!\n";
269
+
270
+
(* Show current settings *)
271
+
(match get_vacation_response ctx session account_id with
272
+
| Ok current -> show_vacation_response current
273
+
| Error _ -> ());
274
+
0
275
+
| Error e ->
276
+
Printf.eprintf "Failed to update vacation response: %s\n" (Jmap.Error.error_to_string e);
277
+
1)
278
+
279
+
(* Command implementation *)
280
+
let vacation_command host user password enable disable show subject message
281
+
message_file html_message from_date to_date exclude : int =
282
+
Printf.printf "JMAP Vacation Manager\n";
283
+
Printf.printf "Server: %s\n" host;
284
+
Printf.printf "User: %s\n\n" user;
285
+
286
+
(* Determine action *)
287
+
let action_count = (if enable then 1 else 0) +
288
+
(if disable then 1 else 0) +
289
+
(if show then 1 else 0) in
290
+
291
+
if action_count = 0 then (
292
+
Printf.eprintf "Error: Must specify an action: --enable, --disable, or --show\n";
293
+
exit 1
294
+
);
295
+
296
+
if action_count > 1 then (
297
+
Printf.eprintf "Error: Can only specify one action at a time\n";
298
+
exit 1
299
+
);
300
+
301
+
(* Build vacation config if enabling or updating *)
302
+
let config = if enable || (not disable && not show) then
303
+
(* Read message content *)
304
+
let text_body = match message, message_file with
305
+
| Some text, _ -> text
306
+
| None, Some file -> read_file file
307
+
| None, None ->
308
+
if enable then (
309
+
Printf.eprintf "Error: Must provide vacation message (--message or --message-file)\n";
310
+
exit 1
311
+
) else ""
312
+
in
313
+
314
+
(* Parse dates *)
315
+
let from_date = match from_date with
316
+
| Some date_str -> parse_date date_str
317
+
| None -> None
318
+
in
319
+
320
+
let to_date = match to_date with
321
+
| Some date_str -> parse_date date_str
322
+
| None -> None
323
+
in
324
+
325
+
Some {
326
+
subject;
327
+
text_body;
328
+
html_body = html_message;
329
+
from_date;
330
+
to_date;
331
+
exclude_addresses = exclude;
332
+
}
333
+
else
334
+
None
335
+
in
336
+
337
+
(* Determine action *)
338
+
let action =
339
+
if show then Show
340
+
else if disable then Disable
341
+
else if enable then Enable (Option.get config)
342
+
else Update (Option.get config)
343
+
in
344
+
345
+
(* Connect to server *)
346
+
let ctx = Jmap_unix.create_client () in
347
+
let result = Jmap_unix.quick_connect ~host ~username:user ~password in
348
+
349
+
let (ctx, session) = match result with
350
+
| Ok (ctx, session) -> (ctx, session)
351
+
| Error e ->
352
+
Printf.eprintf "Connection failed: %s\n" (Jmap.Error.error_to_string e);
353
+
exit 1
354
+
in
355
+
356
+
(* Check vacation capability *)
357
+
(* Note: has_capability not available in interface, assuming server supports it *)
358
+
359
+
(* Get the primary account ID *)
360
+
let account_id = match Jmap.get_primary_account session Jmap_email.capability_mail with
361
+
| Ok id -> id
362
+
| Error e ->
363
+
Printf.eprintf "No mail account found: %s\n" (Jmap.Error.error_to_string e);
364
+
exit 1
365
+
in
366
+
367
+
(* Process the action *)
368
+
process_vacation_action ctx session account_id action
369
+
370
+
(* Command definition *)
371
+
let vacation_cmd =
372
+
let doc = "manage vacation/out-of-office auto-responses" in
373
+
let man = [
374
+
`S Manpage.s_description;
375
+
`P "Manage vacation responses (out-of-office auto-replies) via JMAP.";
376
+
`P "Configure automatic email responses for when you're away.";
377
+
`S Manpage.s_examples;
378
+
`P "Show current vacation settings:";
379
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --show";
380
+
`P "";
381
+
`P "Enable vacation response:";
382
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --enable \\";
383
+
`P " --subject \"Out of Office\" \\";
384
+
`P " --message \"I am currently out of the office and will return on Monday.\"";
385
+
`P "";
386
+
`P "Enable with date range:";
387
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --enable \\";
388
+
`P " --message-file vacation.txt \\";
389
+
`P " --from-date 2024-07-01 --to-date 2024-07-15";
390
+
`P "";
391
+
`P "Disable vacation response:";
392
+
`P " $(mname) -h jmap.example.com -u user@example.com -p secret123 --disable";
393
+
] in
394
+
395
+
let cmd =
396
+
Cmd.v
397
+
(Cmd.info "jmap-vacation-manager" ~version:"1.0" ~doc ~man)
398
+
Term.(const vacation_command $ host_arg $ user_arg $ password_arg $
399
+
enable_arg $ disable_arg $ show_arg $ subject_arg $ message_arg $
400
+
message_file_arg $ html_message_arg $ from_date_arg $ to_date_arg $
401
+
exclude_arg)
402
+
in
403
+
cmd
404
+
405
+
(* Main entry point *)
406
+
let () = exit (Cmd.eval' vacation_cmd)
-662
bin/jmapq.ml
-662
bin/jmapq.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAPQ - Specialist JMAP workflow commands *)
7
-
8
-
open Cmdliner
9
-
10
-
(** {1 Helpers} *)
11
-
12
-
let ptime_to_string t =
13
-
let (y, m, d), ((hh, mm, ss), _tz) = Ptime.to_date_time t in
14
-
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" y m d hh mm ss
15
-
16
-
let truncate_string max_len s =
17
-
if String.length s <= max_len then s
18
-
else String.sub s 0 (max_len - 3) ^ "..."
19
-
20
-
(** {1 Zulip Types and Codec} *)
21
-
22
-
(** Parsed information from a Zulip notification email subject.
23
-
Subject format: "#Channel > topic [Server Name]" *)
24
-
module Zulip_message = struct
25
-
type t = {
26
-
id : string;
27
-
date : Ptime.t;
28
-
thread_id : string;
29
-
channel : string;
30
-
topic : string;
31
-
server : string;
32
-
is_read : bool;
33
-
labels : string list;
34
-
}
35
-
36
-
(** Parse a Zulip subject line of the form "#Channel > topic [Server Name]" *)
37
-
let parse_subject subject =
38
-
(* Pattern: #<channel> > <topic> [<server>] *)
39
-
let channel_re = Re.Pcre.regexp {|^#(.+?)\s*>\s*(.+?)\s*\[(.+?)\]$|} in
40
-
match Re.exec_opt channel_re subject with
41
-
| Some groups ->
42
-
let channel = Re.Group.get groups 1 in
43
-
let topic = Re.Group.get groups 2 in
44
-
let server = Re.Group.get groups 3 in
45
-
Some (channel, topic, server)
46
-
| None -> None
47
-
48
-
(** Check if an email has the $seen keyword *)
49
-
let is_seen keywords =
50
-
List.exists (fun (k, v) -> k = "$seen" && v) keywords
51
-
52
-
(** Extract label strings from keywords, excluding standard JMAP keywords *)
53
-
let extract_labels keywords =
54
-
keywords
55
-
|> List.filter_map (fun (k, v) ->
56
-
if v && not (String.length k > 0 && k.[0] = '$') then
57
-
Some k
58
-
else if v && k = "$flagged" then
59
-
Some "flagged"
60
-
else
61
-
None)
62
-
63
-
(** Create a Zulip_message from a JMAP Email *)
64
-
let of_email (email : Jmap.Proto.Email.t) : t option =
65
-
let id = match email.id with
66
-
| Some id -> Jmap.Proto.Id.to_string id
67
-
| None -> ""
68
-
in
69
-
let date = match email.received_at with
70
-
| Some t -> t
71
-
| None -> Ptime.epoch
72
-
in
73
-
let thread_id = match email.thread_id with
74
-
| Some id -> Jmap.Proto.Id.to_string id
75
-
| None -> ""
76
-
in
77
-
let subject = Option.value ~default:"" email.subject in
78
-
match parse_subject subject with
79
-
| None -> None
80
-
| Some (channel, topic, server) ->
81
-
let keywords = Option.value ~default:[] email.keywords in
82
-
let is_read = is_seen keywords in
83
-
let labels = extract_labels keywords in
84
-
Some { id; date; thread_id; channel; topic; server; is_read; labels }
85
-
86
-
(** Jsont codec for Ptime.t - reuse the library's UTC date codec *)
87
-
let ptime_jsont : Ptime.t Jsont.t = Jmap.Proto.Date.Utc.jsont
88
-
89
-
(** Jsont codec for a single Zulip message *)
90
-
let jsont : t Jsont.t =
91
-
let kind = "ZulipMessage" in
92
-
let make id date thread_id channel topic server is_read labels =
93
-
{ id; date; thread_id; channel; topic; server; is_read; labels }
94
-
in
95
-
Jsont.Object.map ~kind make
96
-
|> Jsont.Object.mem "id" Jsont.string ~enc:(fun t -> t.id)
97
-
|> Jsont.Object.mem "date" ptime_jsont ~enc:(fun t -> t.date)
98
-
|> Jsont.Object.mem "thread_id" Jsont.string ~enc:(fun t -> t.thread_id)
99
-
|> Jsont.Object.mem "channel" Jsont.string ~enc:(fun t -> t.channel)
100
-
|> Jsont.Object.mem "topic" Jsont.string ~enc:(fun t -> t.topic)
101
-
|> Jsont.Object.mem "server" Jsont.string ~enc:(fun t -> t.server)
102
-
|> Jsont.Object.mem "is_read" Jsont.bool ~enc:(fun t -> t.is_read)
103
-
|> Jsont.Object.mem "labels" (Jsont.list Jsont.string) ~enc:(fun t -> t.labels)
104
-
|> Jsont.Object.finish
105
-
106
-
(** Jsont codec for a list of Zulip messages *)
107
-
let list_jsont : t list Jsont.t = Jsont.list jsont
108
-
end
109
-
110
-
(** {1 Zulip List Command} *)
111
-
112
-
let zulip_list_cmd =
113
-
let json_term =
114
-
let doc = "Output as JSON" in
115
-
Arg.(value & flag & info ["json"] ~doc)
116
-
in
117
-
let limit_term =
118
-
let doc = "Maximum number of messages to fetch (default: all)" in
119
-
Arg.(value & opt (some int) None & info ["limit"; "n"] ~docv:"N" ~doc)
120
-
in
121
-
let run cfg json_output limit =
122
-
Eio_main.run @@ fun env ->
123
-
Eio.Switch.run @@ fun sw ->
124
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
125
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
126
-
127
-
Jmap_eio.Cli.debug cfg "Searching for Zulip notification emails";
128
-
129
-
(* Build filter for emails from noreply@zulip.com *)
130
-
let cond : Jmap.Proto.Email.Filter_condition.t = {
131
-
in_mailbox = None; in_mailbox_other_than = None;
132
-
before = None; after = None;
133
-
min_size = None; max_size = None;
134
-
all_in_thread_have_keyword = None;
135
-
some_in_thread_have_keyword = None;
136
-
none_in_thread_have_keyword = None;
137
-
has_keyword = None; not_keyword = None;
138
-
has_attachment = None;
139
-
text = None;
140
-
from = Some "noreply@zulip.com";
141
-
to_ = None;
142
-
cc = None; bcc = None; subject = None;
143
-
body = None; header = None;
144
-
} in
145
-
let filter = Jmap.Proto.Filter.Condition cond in
146
-
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
147
-
148
-
(* Query for all Zulip emails *)
149
-
let query_limit = match limit with
150
-
| Some n -> Int64.of_int n
151
-
| None -> Int64.of_int 10000 (* Large default to get "all" *)
152
-
in
153
-
let query_inv = Jmap_eio.Client.Build.email_query
154
-
~call_id:"q1"
155
-
~account_id
156
-
~filter
157
-
~sort
158
-
~limit:query_limit
159
-
()
160
-
in
161
-
162
-
let req = Jmap_eio.Client.Build.(
163
-
make_request
164
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
165
-
[query_inv]
166
-
) in
167
-
168
-
match Jmap_eio.Client.request client req with
169
-
| Error e ->
170
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
171
-
exit 1
172
-
| Ok response ->
173
-
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
174
-
| Error e ->
175
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
176
-
exit 1
177
-
| Ok query_result ->
178
-
let email_ids = query_result.ids in
179
-
Jmap_eio.Cli.debug cfg "Found %d Zulip email IDs" (List.length email_ids);
180
-
181
-
if List.length email_ids = 0 then (
182
-
if json_output then
183
-
Fmt.pr "[]@."
184
-
else
185
-
Fmt.pr "No Zulip notification emails found.@."
186
-
) else (
187
-
(* Fetch email details *)
188
-
let get_inv = Jmap_eio.Client.Build.email_get
189
-
~call_id:"g1"
190
-
~account_id
191
-
~ids:email_ids
192
-
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
193
-
"size"; "receivedAt"; "subject"; "from"]
194
-
()
195
-
in
196
-
let req2 = Jmap_eio.Client.Build.(
197
-
make_request
198
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
199
-
[get_inv]
200
-
) in
201
-
202
-
match Jmap_eio.Client.request client req2 with
203
-
| Error e ->
204
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
205
-
exit 1
206
-
| Ok response2 ->
207
-
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
208
-
| Error e ->
209
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
210
-
exit 1
211
-
| Ok get_result ->
212
-
(* Parse Zulip subjects and filter successful parses *)
213
-
let zulip_messages =
214
-
get_result.list
215
-
|> List.filter_map Zulip_message.of_email
216
-
in
217
-
218
-
Jmap_eio.Cli.debug cfg "Parsed %d Zulip messages from %d emails"
219
-
(List.length zulip_messages)
220
-
(List.length get_result.list);
221
-
222
-
if json_output then (
223
-
(* Output as JSON *)
224
-
match Jsont_bytesrw.encode_string' ~format:Jsont.Indent Zulip_message.list_jsont zulip_messages with
225
-
| Ok json_str -> Fmt.pr "%s@." json_str
226
-
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e)
227
-
) else (
228
-
(* Human-readable output *)
229
-
Fmt.pr "@[<v>%a (%d messages)@,@,"
230
-
Fmt.(styled `Bold string) "Zulip Notifications"
231
-
(List.length zulip_messages);
232
-
233
-
(* Group by server, then by channel *)
234
-
let by_server = Hashtbl.create 8 in
235
-
List.iter (fun (msg : Zulip_message.t) ->
236
-
let existing = try Hashtbl.find by_server msg.server with Not_found -> [] in
237
-
Hashtbl.replace by_server msg.server (msg :: existing)
238
-
) zulip_messages;
239
-
240
-
Hashtbl.iter (fun server msgs ->
241
-
Fmt.pr "%a [%s]@,"
242
-
Fmt.(styled `Bold string) "Server:"
243
-
server;
244
-
245
-
(* Group by channel within server *)
246
-
let by_channel = Hashtbl.create 8 in
247
-
List.iter (fun (msg : Zulip_message.t) ->
248
-
let existing = try Hashtbl.find by_channel msg.channel with Not_found -> [] in
249
-
Hashtbl.replace by_channel msg.channel (msg :: existing)
250
-
) msgs;
251
-
252
-
Hashtbl.iter (fun channel channel_msgs ->
253
-
Fmt.pr " %a #%s (%d)@,"
254
-
Fmt.(styled `Cyan string) "Channel:"
255
-
channel
256
-
(List.length channel_msgs);
257
-
258
-
(* Sort by date descending *)
259
-
let sorted = List.sort (fun a b ->
260
-
Ptime.compare b.Zulip_message.date a.Zulip_message.date
261
-
) channel_msgs in
262
-
263
-
List.iter (fun (msg : Zulip_message.t) ->
264
-
let read_marker = if msg.is_read then " " else "*" in
265
-
let labels_str = match msg.labels with
266
-
| [] -> ""
267
-
| ls -> " [" ^ String.concat ", " ls ^ "]"
268
-
in
269
-
Fmt.pr " %s %s %a %s%s@,"
270
-
read_marker
271
-
(ptime_to_string msg.date)
272
-
Fmt.(styled `Yellow string) (truncate_string 40 msg.topic)
273
-
(truncate_string 12 msg.id)
274
-
labels_str
275
-
) sorted;
276
-
Fmt.pr "@,"
277
-
) by_channel
278
-
) by_server;
279
-
280
-
Fmt.pr "@]@."
281
-
)
282
-
)
283
-
in
284
-
let doc = "List Zulip notification emails with parsed channel/topic info" in
285
-
let man = [
286
-
`S Manpage.s_description;
287
-
`P "Lists all emails from noreply@zulip.com and parses the subject line to extract \
288
-
the Zulip channel, topic, and server name.";
289
-
`P "Subject format expected: \"#Channel > topic [Server Name]\"";
290
-
`S Manpage.s_examples;
291
-
`P "List all Zulip notifications:";
292
-
`Pre " jmapq zulip-list";
293
-
`P "Output as JSON:";
294
-
`Pre " jmapq zulip-list --json";
295
-
`P "Limit to 50 most recent:";
296
-
`Pre " jmapq zulip-list -n 50";
297
-
] in
298
-
let info = Cmd.info "zulip-list" ~doc ~man in
299
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ json_term $ limit_term)
300
-
301
-
(** {1 Zulip Timeout Command} *)
302
-
303
-
(** The keyword used to mark Zulip notifications as processed *)
304
-
let zulip_processed_keyword = "zulip-processed"
305
-
306
-
let zulip_timeout_cmd =
307
-
let email_ids_term =
308
-
let doc = "Email IDs to mark as processed" in
309
-
Arg.(non_empty & pos_all string [] & info [] ~docv:"EMAIL_ID" ~doc)
310
-
in
311
-
let verbose_term =
312
-
let doc = "Show the raw JMAP server response" in
313
-
Arg.(value & flag & info ["v"; "verbose"] ~doc)
314
-
in
315
-
let run cfg verbose email_id_strs =
316
-
Eio_main.run @@ fun env ->
317
-
Eio.Switch.run @@ fun sw ->
318
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
319
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
320
-
let email_ids = List.map Jmap.Proto.Id.of_string_exn email_id_strs in
321
-
322
-
Jmap_eio.Cli.debug cfg "Marking %d email(s) with '%s' keyword"
323
-
(List.length email_ids) zulip_processed_keyword;
324
-
325
-
(* Build patch to add the zulip-processed keyword and mark as read *)
326
-
let patch =
327
-
let open Jmap_eio.Chain in
328
-
json_obj [
329
-
("keywords/" ^ zulip_processed_keyword, json_bool true);
330
-
("keywords/$seen", json_bool true);
331
-
]
332
-
in
333
-
334
-
(* Build updates list: each email ID gets the same patch *)
335
-
let updates = List.map (fun id -> (id, patch)) email_ids in
336
-
337
-
let open Jmap_eio.Chain in
338
-
let request, set_h = build
339
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
340
-
begin
341
-
email_set ~account_id
342
-
~update:updates
343
-
()
344
-
end in
345
-
346
-
match Jmap_eio.Client.request client request with
347
-
| Error e ->
348
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
349
-
exit 1
350
-
| Ok response ->
351
-
(* Print raw response if verbose *)
352
-
if verbose then begin
353
-
Fmt.pr "@[<v>%a:@," Fmt.(styled `Bold string) "Server Response";
354
-
(match Jsont_bytesrw.encode_string' ~format:Jsont.Indent
355
-
Jmap.Proto.Response.jsont response with
356
-
| Ok json_str -> Fmt.pr "%s@,@]@." json_str
357
-
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e))
358
-
end;
359
-
(* Check for JMAP method-level errors first *)
360
-
let call_id = Jmap_eio.Chain.call_id set_h in
361
-
(match Jmap.Proto.Response.find_response call_id response with
362
-
| None ->
363
-
Fmt.epr "Error: No response found for call_id %s@." call_id;
364
-
exit 1
365
-
| Some inv when Jmap.Proto.Response.is_error inv ->
366
-
(match Jmap.Proto.Response.get_error inv with
367
-
| Some err ->
368
-
Fmt.epr "JMAP Error: %s%s@."
369
-
(Jmap.Proto.Error.method_error_type_to_string err.type_)
370
-
(match err.description with Some d -> " - " ^ d | None -> "");
371
-
exit 1
372
-
| None ->
373
-
Fmt.epr "JMAP Error: Unknown error@.";
374
-
exit 1)
375
-
| Some _ ->
376
-
match parse set_h response with
377
-
| Error e ->
378
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
379
-
exit 1
380
-
| Ok result ->
381
-
(* Report successes *)
382
-
let updated_ids =
383
-
result.updated
384
-
|> Option.value ~default:[]
385
-
|> List.map (fun (id, _) -> Jmap.Proto.Id.to_string id)
386
-
in
387
-
if List.length updated_ids > 0 then begin
388
-
Fmt.pr "@[<v>%a %d email(s) as read with '%s':@,"
389
-
Fmt.(styled `Green string) "Marked"
390
-
(List.length updated_ids)
391
-
zulip_processed_keyword;
392
-
List.iter (fun id -> Fmt.pr " %s@," id) updated_ids;
393
-
Fmt.pr "@]@."
394
-
end;
395
-
396
-
(* Report failures *)
397
-
let not_updated = Option.value ~default:[] result.not_updated in
398
-
if not_updated <> [] then begin
399
-
Fmt.epr "@[<v>%a to mark %d email(s):@,"
400
-
Fmt.(styled `Red string) "Failed"
401
-
(List.length not_updated);
402
-
List.iter (fun (id, err) ->
403
-
let open Jmap.Proto.Error in
404
-
let err_type = set_error_type_to_string err.type_ in
405
-
let err_desc = Option.value ~default:"" err.description in
406
-
Fmt.epr " %s: %s%s@,"
407
-
(Jmap.Proto.Id.to_string id)
408
-
err_type
409
-
(if err_desc = "" then "" else " - " ^ err_desc)
410
-
) not_updated;
411
-
Fmt.epr "@]@.";
412
-
exit 1
413
-
end)
414
-
in
415
-
let doc = "Mark Zulip notification emails as processed" in
416
-
let man = [
417
-
`S Manpage.s_description;
418
-
`P (Printf.sprintf "Adds the '%s' keyword to the specified email(s). \
419
-
This keyword can be used to filter processed Zulip notifications \
420
-
or set up server-side rules to auto-archive them."
421
-
zulip_processed_keyword);
422
-
`S Manpage.s_examples;
423
-
`P "Mark a single email as processed:";
424
-
`Pre " jmapq zulip-timeout StrrDTS_WEa3";
425
-
`P "Mark multiple emails as processed:";
426
-
`Pre " jmapq zulip-timeout StrrDTS_WEa3 StrsGZ7P8Dpc StrsGuCSXJ3Z";
427
-
] in
428
-
let info = Cmd.info "zulip-timeout" ~doc ~man in
429
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ verbose_term $ email_ids_term)
430
-
431
-
(** {1 Zulip View Command} *)
432
-
433
-
let zulip_view_cmd =
434
-
let json_term =
435
-
let doc = "Output as JSON" in
436
-
Arg.(value & flag & info ["json"] ~doc)
437
-
in
438
-
let limit_term =
439
-
let doc = "Maximum number of messages to fetch (default: all)" in
440
-
Arg.(value & opt (some int) None & info ["limit"; "n"] ~docv:"N" ~doc)
441
-
in
442
-
let verbose_term =
443
-
let doc = "Show the raw JMAP request and response" in
444
-
Arg.(value & flag & info ["v"; "verbose"] ~doc)
445
-
in
446
-
let run cfg json_output limit verbose =
447
-
Eio_main.run @@ fun env ->
448
-
Eio.Switch.run @@ fun sw ->
449
-
let client = Jmap_eio.Cli.create_client ~sw env cfg in
450
-
let account_id = Jmap_eio.Cli.get_account_id cfg client in
451
-
452
-
Jmap_eio.Cli.debug cfg "Searching for Zulip emails marked as processed";
453
-
454
-
(* Build filter for emails from noreply@zulip.com with zulip-processed keyword *)
455
-
let cond : Jmap.Proto.Email.Filter_condition.t = {
456
-
in_mailbox = None; in_mailbox_other_than = None;
457
-
before = None; after = None;
458
-
min_size = None; max_size = None;
459
-
all_in_thread_have_keyword = None;
460
-
some_in_thread_have_keyword = None;
461
-
none_in_thread_have_keyword = None;
462
-
has_keyword = Some zulip_processed_keyword;
463
-
not_keyword = None;
464
-
has_attachment = None;
465
-
text = None;
466
-
from = Some "noreply@zulip.com";
467
-
to_ = None;
468
-
cc = None; bcc = None; subject = None;
469
-
body = None; header = None;
470
-
} in
471
-
let filter = Jmap.Proto.Filter.Condition cond in
472
-
let sort = [Jmap.Proto.Filter.comparator ~is_ascending:false "receivedAt"] in
473
-
474
-
(* Query for processed Zulip emails *)
475
-
let query_limit = match limit with
476
-
| Some n -> Int64.of_int n
477
-
| None -> Int64.of_int 10000
478
-
in
479
-
let query_inv = Jmap_eio.Client.Build.email_query
480
-
~call_id:"q1"
481
-
~account_id
482
-
~filter
483
-
~sort
484
-
~limit:query_limit
485
-
()
486
-
in
487
-
488
-
let req = Jmap_eio.Client.Build.(
489
-
make_request
490
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
491
-
[query_inv]
492
-
) in
493
-
494
-
(* Print request if verbose *)
495
-
if verbose then begin
496
-
Fmt.pr "@[<v>%a:@," Fmt.(styled `Bold string) "Request";
497
-
(match Jsont_bytesrw.encode_string' ~format:Jsont.Indent
498
-
Jmap.Proto.Request.jsont req with
499
-
| Ok json_str -> Fmt.pr "%s@,@]@." json_str
500
-
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e))
501
-
end;
502
-
503
-
match Jmap_eio.Client.request client req with
504
-
| Error e ->
505
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
506
-
exit 1
507
-
| Ok response ->
508
-
(* Print response if verbose *)
509
-
if verbose then begin
510
-
Fmt.pr "@[<v>%a:@," Fmt.(styled `Bold string) "Response";
511
-
(match Jsont_bytesrw.encode_string' ~format:Jsont.Indent
512
-
Jmap.Proto.Response.jsont response with
513
-
| Ok json_str -> Fmt.pr "%s@,@]@." json_str
514
-
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e))
515
-
end;
516
-
match Jmap_eio.Client.Parse.parse_email_query ~call_id:"q1" response with
517
-
| Error e ->
518
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
519
-
exit 1
520
-
| Ok query_result ->
521
-
let email_ids = query_result.ids in
522
-
Jmap_eio.Cli.debug cfg "Found %d processed Zulip email IDs" (List.length email_ids);
523
-
524
-
if List.length email_ids = 0 then (
525
-
if json_output then
526
-
Fmt.pr "[]@."
527
-
else
528
-
Fmt.pr "No Zulip emails marked as processed.@."
529
-
) else (
530
-
(* Fetch email details *)
531
-
let get_inv = Jmap_eio.Client.Build.email_get
532
-
~call_id:"g1"
533
-
~account_id
534
-
~ids:email_ids
535
-
~properties:["id"; "blobId"; "threadId"; "mailboxIds"; "keywords";
536
-
"size"; "receivedAt"; "subject"; "from"]
537
-
()
538
-
in
539
-
let req2 = Jmap_eio.Client.Build.(
540
-
make_request
541
-
~capabilities:[Jmap.Proto.Capability.core; Jmap.Proto.Capability.mail]
542
-
[get_inv]
543
-
) in
544
-
545
-
match Jmap_eio.Client.request client req2 with
546
-
| Error e ->
547
-
Fmt.epr "Error: %s@." (Jmap_eio.Client.error_to_string e);
548
-
exit 1
549
-
| Ok response2 ->
550
-
match Jmap_eio.Client.Parse.parse_email_get ~call_id:"g1" response2 with
551
-
| Error e ->
552
-
Fmt.epr "Parse error: %s@." (Jsont.Error.to_string e);
553
-
exit 1
554
-
| Ok get_result ->
555
-
(* Parse Zulip subjects and filter successful parses *)
556
-
let zulip_messages =
557
-
get_result.list
558
-
|> List.filter_map Zulip_message.of_email
559
-
in
560
-
561
-
Jmap_eio.Cli.debug cfg "Parsed %d Zulip messages from %d emails"
562
-
(List.length zulip_messages)
563
-
(List.length get_result.list);
564
-
565
-
if json_output then (
566
-
(* Output as JSON *)
567
-
match Jsont_bytesrw.encode_string' ~format:Jsont.Indent Zulip_message.list_jsont zulip_messages with
568
-
| Ok json_str -> Fmt.pr "%s@." json_str
569
-
| Error e -> Fmt.epr "JSON encoding error: %s@." (Jsont.Error.to_string e)
570
-
) else (
571
-
(* Human-readable output *)
572
-
Fmt.pr "@[<v>%a (%d messages)@,@,"
573
-
Fmt.(styled `Bold string) "Processed Zulip Notifications"
574
-
(List.length zulip_messages);
575
-
576
-
(* Group by server, then by channel *)
577
-
let by_server = Hashtbl.create 8 in
578
-
List.iter (fun (msg : Zulip_message.t) ->
579
-
let existing = try Hashtbl.find by_server msg.server with Not_found -> [] in
580
-
Hashtbl.replace by_server msg.server (msg :: existing)
581
-
) zulip_messages;
582
-
583
-
Hashtbl.iter (fun server msgs ->
584
-
Fmt.pr "%a [%s]@,"
585
-
Fmt.(styled `Bold string) "Server:"
586
-
server;
587
-
588
-
(* Group by channel within server *)
589
-
let by_channel = Hashtbl.create 8 in
590
-
List.iter (fun (msg : Zulip_message.t) ->
591
-
let existing = try Hashtbl.find by_channel msg.channel with Not_found -> [] in
592
-
Hashtbl.replace by_channel msg.channel (msg :: existing)
593
-
) msgs;
594
-
595
-
Hashtbl.iter (fun channel channel_msgs ->
596
-
Fmt.pr " %a #%s (%d)@,"
597
-
Fmt.(styled `Cyan string) "Channel:"
598
-
channel
599
-
(List.length channel_msgs);
600
-
601
-
(* Sort by date descending *)
602
-
let sorted = List.sort (fun a b ->
603
-
Ptime.compare b.Zulip_message.date a.Zulip_message.date
604
-
) channel_msgs in
605
-
606
-
List.iter (fun (msg : Zulip_message.t) ->
607
-
let read_marker = if msg.is_read then " " else "*" in
608
-
let labels_str = match msg.labels with
609
-
| [] -> ""
610
-
| ls -> " [" ^ String.concat ", " ls ^ "]"
611
-
in
612
-
Fmt.pr " %s %s %a %s%s@,"
613
-
read_marker
614
-
(ptime_to_string msg.date)
615
-
Fmt.(styled `Yellow string) (truncate_string 40 msg.topic)
616
-
(truncate_string 12 msg.id)
617
-
labels_str
618
-
) sorted;
619
-
Fmt.pr "@,"
620
-
) by_channel
621
-
) by_server;
622
-
623
-
Fmt.pr "@]@."
624
-
)
625
-
)
626
-
in
627
-
let doc = "List Zulip emails that have been marked as processed" in
628
-
let man = [
629
-
`S Manpage.s_description;
630
-
`P (Printf.sprintf "Lists all Zulip notification emails that have the '%s' keyword."
631
-
zulip_processed_keyword);
632
-
`S Manpage.s_examples;
633
-
`P "List all processed Zulip notifications:";
634
-
`Pre " jmapq zulip-view";
635
-
`P "Output as JSON:";
636
-
`Pre " jmapq zulip-view --json";
637
-
`P "Limit to 50 most recent:";
638
-
`Pre " jmapq zulip-view -n 50";
639
-
] in
640
-
let info = Cmd.info "zulip-view" ~doc ~man in
641
-
Cmd.v info Term.(const run $ Jmap_eio.Cli.config_term $ json_term $ limit_term $ verbose_term)
642
-
643
-
(** {1 Main Command Group} *)
644
-
645
-
let main_cmd =
646
-
let doc = "JMAPQ - Specialist JMAP workflow commands" in
647
-
let man = [
648
-
`S Manpage.s_description;
649
-
`P "A collection of specialist workflow commands for JMAP email processing.";
650
-
`S Manpage.s_environment;
651
-
`P Jmap_eio.Cli.env_docs;
652
-
] in
653
-
let info = Cmd.info "jmapq" ~version:"0.1.0" ~doc ~man in
654
-
Cmd.group info [
655
-
zulip_list_cmd;
656
-
zulip_timeout_cmd;
657
-
zulip_view_cmd;
658
-
]
659
-
660
-
let () =
661
-
Fmt_tty.setup_std_outputs ();
662
-
exit (Cmd.eval main_cmd)
-164
bin/tutorial_examples.ml
-164
bin/tutorial_examples.ml
···
1
-
(* Examples from the tutorial *)
2
-
3
-
open Lwt.Syntax
4
-
open Jmap
5
-
open Jmap.Mail
6
-
7
-
(* Example: Authentication *)
8
-
let auth_example () =
9
-
(* Using a Fastmail API token *)
10
-
let token = Sys.getenv_opt "JMAP_API_TOKEN" in
11
-
match token with
12
-
| None ->
13
-
Printf.eprintf "Error: JMAP_API_TOKEN environment variable not set\n";
14
-
Lwt.return_none
15
-
| Some token ->
16
-
let+ result = Jmap.Proto.login_with_token
17
-
~uri:"https://api.fastmail.com/jmap/session"
18
-
~api_token:token
19
-
in
20
-
21
-
(* Handle the result *)
22
-
match result with
23
-
| Ok conn ->
24
-
(* Get the primary account ID *)
25
-
let account_id =
26
-
let mail_capability = Jmap.Proto.Capability.to_string Jmap.Proto.Capability.Mail in
27
-
match List.assoc_opt mail_capability conn.session.primary_accounts with
28
-
| Some id -> id
29
-
| None ->
30
-
match conn.session.accounts with
31
-
| (id, _) :: _ -> id
32
-
| [] -> failwith "No accounts found"
33
-
in
34
-
Printf.printf "Authenticated successfully with account ID: %s\n" account_id;
35
-
Some (conn, account_id)
36
-
| Error e ->
37
-
Printf.eprintf "Authentication error: %s\n"
38
-
(match e with
39
-
| Api.Connection_error msg -> "Connection error: " ^ msg
40
-
| Api.HTTP_error (code, body) -> Printf.sprintf "HTTP error %d: %s" code body
41
-
| Api.Parse_error msg -> "Parse error: " ^ msg
42
-
| Api.Authentication_error -> "Authentication error");
43
-
None
44
-
45
-
(* Example: Working with Mailboxes *)
46
-
let mailbox_example (conn, account_id) =
47
-
(* Get all mailboxes *)
48
-
let+ mailboxes_result = Jmap.Proto.get_mailboxes conn ~account_id in
49
-
50
-
match mailboxes_result with
51
-
| Ok mailboxes ->
52
-
Printf.printf "Found %d mailboxes\n" (List.length mailboxes);
53
-
54
-
(* Find inbox - for simplicity, just use the first mailbox *)
55
-
let inbox = match mailboxes with
56
-
| first :: _ -> Some first
57
-
| [] -> None
58
-
in
59
-
60
-
(match inbox with
61
-
| Some m ->
62
-
Printf.printf "Inbox ID: %s, Name: %s\n"
63
-
m.Types.id
64
-
m.Types.name;
65
-
Some (conn, account_id, m.Types.id)
66
-
| None ->
67
-
Printf.printf "No inbox found\n";
68
-
None)
69
-
| Error e ->
70
-
Printf.eprintf "Error getting mailboxes: %s\n"
71
-
(match e with
72
-
| Api.Connection_error msg -> "Connection error: " ^ msg
73
-
| Api.HTTP_error (code, body) -> Printf.sprintf "HTTP error %d: %s" code body
74
-
| Api.Parse_error msg -> "Parse error: " ^ msg
75
-
| Api.Authentication_error -> "Authentication error");
76
-
None
77
-
78
-
(* Example: Working with Emails *)
79
-
let email_example (conn, account_id, mailbox_id) =
80
-
(* Get emails from mailbox *)
81
-
let+ emails_result = Jmap.Proto.get_messages_in_mailbox
82
-
conn
83
-
~account_id
84
-
~mailbox_id
85
-
~limit:5
86
-
()
87
-
in
88
-
89
-
match emails_result with
90
-
| Ok emails -> begin
91
-
Printf.printf "Found %d emails\n" (List.length emails);
92
-
93
-
(* Display emails *)
94
-
List.iter (fun (email:Jmap.Proto.Types.email) ->
95
-
(* Using explicit module path for Types to avoid ambiguity *)
96
-
let module Mail = Jmap.Proto.Types in
97
-
98
-
(* Get sender info *)
99
-
let from = match email.Mail.from with
100
-
| None -> "Unknown"
101
-
| Some addrs ->
102
-
match addrs with
103
-
| [] -> "Unknown"
104
-
| addr :: _ ->
105
-
match addr.Mail.name with
106
-
| None -> addr.Mail.email
107
-
| Some name ->
108
-
Printf.sprintf "%s <%s>" name addr.Mail.email
109
-
in
110
-
111
-
(* Check for unread status *)
112
-
let is_unread =
113
-
List.exists (fun (kw, active) ->
114
-
match kw with
115
-
| Mail.Unread -> active
116
-
| Mail.Custom s when s = "$unread" -> active
117
-
| _ -> false
118
-
) email.Mail.keywords
119
-
in
120
-
121
-
(* Display email info *)
122
-
Printf.printf "[%s] %s - %s\n"
123
-
(if is_unread then "UNREAD" else "READ")
124
-
from
125
-
(Option.value ~default:"(No Subject)" email.Mail.subject)
126
-
) emails;
127
-
128
-
match emails with
129
-
| [] -> None
130
-
| hd::_ -> Some (conn, account_id, hd.Jmap.Proto.Types.id)
131
-
end
132
-
| Error e ->
133
-
Printf.eprintf "Error getting emails: %s\n"
134
-
(match e with
135
-
| Api.Connection_error msg -> "Connection error: " ^ msg
136
-
| Api.HTTP_error (code, body) -> Printf.sprintf "HTTP error %d: %s" code body
137
-
| Api.Parse_error msg -> "Parse error: " ^ msg
138
-
| Api.Authentication_error -> "Authentication error");
139
-
None
140
-
141
-
(* Run examples with Lwt *)
142
-
let () =
143
-
(* Set up logging *)
144
-
Jmap.init_logging ~level:2 ~enable_logs:true ~redact_sensitive:true ();
145
-
146
-
(* Run the examples in sequence *)
147
-
let result = Lwt_main.run (
148
-
let* auth_result = auth_example () in
149
-
match auth_result with
150
-
| None -> Lwt.return 1
151
-
| Some conn_account ->
152
-
let* mailbox_result = mailbox_example conn_account in
153
-
match mailbox_result with
154
-
| None -> Lwt.return 1
155
-
| Some conn_account_mailbox ->
156
-
let* email_result = email_example conn_account_mailbox in
157
-
match email_result with
158
-
| None -> Lwt.return 1
159
-
| Some _ ->
160
-
Printf.printf "All examples completed successfully\n";
161
-
Lwt.return 0
162
-
) in
163
-
164
-
exit result
-7
doc/dune
-7
doc/dune
-13
doc/index.mld
-13
doc/index.mld
···
1
-
{0 jmap}
2
-
3
-
{!modules: Jmap Jmap_top}
4
-
5
-
{1 Tutorial}
6
-
7
-
See the {!page-tutorial} for a comprehensive guide to using JMAP with OCaml,
8
-
including how types map to JSON and practical examples.
9
-
10
-
{1 Browser Support}
11
-
12
-
For browser-based applications, see the [jmap-brr] package which provides
13
-
a JMAP client using the Brr library and js_of_ocaml.
-494
doc/tutorial.mld
-494
doc/tutorial.mld
···
1
-
{0 JMAP Tutorial}
2
-
3
-
This tutorial introduces JMAP (JSON Meta Application Protocol) and
4
-
demonstrates the [jmap] OCaml library through interactive examples. JMAP
5
-
is defined in {{:https://www.rfc-editor.org/rfc/rfc8620}RFC 8620} (core)
6
-
and {{:https://www.rfc-editor.org/rfc/rfc8621}RFC 8621} (mail).
7
-
8
-
{1 What is JMAP?}
9
-
10
-
JMAP is a modern, efficient protocol for synchronizing mail and other
11
-
data. It's designed as a better alternative to IMAP, addressing many of
12
-
IMAP's limitations:
13
-
14
-
{ul
15
-
{- {b Stateless over HTTP}: Unlike IMAP's persistent TCP connections, JMAP
16
-
uses standard HTTP POST requests with JSON payloads.}
17
-
{- {b Efficient batching}: Multiple operations can be combined into a single
18
-
request, reducing round-trips.}
19
-
{- {b Result references}: The output of one method call can be used as input
20
-
to another in the same request.}
21
-
{- {b Push support}: Built-in mechanisms for real-time notifications.}
22
-
{- {b Binary data handling}: Separate upload/download endpoints for large
23
-
attachments.}}
24
-
25
-
The core protocol (RFC 8620) defines the general structure, while RFC 8621
26
-
extends it specifically for email, mailboxes, threads, and related objects.
27
-
28
-
{1 Setup}
29
-
30
-
First, let's set up our environment. In the toplevel, load the library
31
-
with [#require "jmap.top";;] which will automatically install pretty
32
-
printers.
33
-
34
-
{@ocaml[
35
-
# Jmap_top.install ();;
36
-
- : unit = ()
37
-
# open Jmap;;
38
-
]}
39
-
40
-
For parsing and encoding JSON, we'll use some helper functions:
41
-
42
-
{@ocaml[
43
-
# let parse_json s =
44
-
match Jsont_bytesrw.decode_string Jsont.json s with
45
-
| Ok json -> json
46
-
| Error e -> failwith e;;
47
-
val parse_json : string -> Jsont.json = <fun>
48
-
# let json_to_string json =
49
-
match Jsont_bytesrw.encode_string ~format:Jsont.Indent Jsont.json json with
50
-
| Ok s -> s
51
-
| Error e -> failwith e;;
52
-
val json_to_string : Jsont.json -> string = <fun>
53
-
]}
54
-
55
-
{1 JMAP Identifiers}
56
-
57
-
From {{:https://www.rfc-editor.org/rfc/rfc8620#section-1.2}RFC 8620 Section 1.2}:
58
-
59
-
{i An "Id" is a String of at least 1 and a maximum of 255 octets in size,
60
-
and it MUST only contain characters from the "URL and Filename Safe"
61
-
base64 alphabet.}
62
-
63
-
The {!Jmap.Id} module provides type-safe identifiers:
64
-
65
-
{@ocaml[
66
-
# let id = Id.of_string_exn "abc123";;
67
-
val id : Id.t = abc123
68
-
# Id.to_string id;;
69
-
- : string = "abc123"
70
-
]}
71
-
72
-
Invalid identifiers are rejected:
73
-
74
-
{@ocaml[
75
-
# Id.of_string "";;
76
-
- : (Id.t, string) result = Error "Id cannot be empty"
77
-
# Id.of_string (String.make 256 'x');;
78
-
- : (Id.t, string) result = Error "Id cannot exceed 255 characters"
79
-
]}
80
-
81
-
{1 Keywords}
82
-
83
-
Email keywords are string flags that indicate message state. RFC 8621
84
-
defines standard keywords, and the library represents them as polymorphic
85
-
variants for type safety.
86
-
87
-
{2 Standard Keywords}
88
-
89
-
From {{:https://www.rfc-editor.org/rfc/rfc8621#section-4.1.1}RFC 8621
90
-
Section 4.1.1}:
91
-
92
-
{@ocaml[
93
-
# Keyword.of_string "$seen";;
94
-
- : Keyword.t = $seen
95
-
# Keyword.of_string "$flagged";;
96
-
- : Keyword.t = $flagged
97
-
# Keyword.of_string "$draft";;
98
-
- : Keyword.t = $draft
99
-
# Keyword.of_string "$answered";;
100
-
- : Keyword.t = $answered
101
-
]}
102
-
103
-
The standard keywords are:
104
-
105
-
{ul
106
-
{- [`Seen] - The email has been read}
107
-
{- [`Flagged] - The email has been flagged for attention}
108
-
{- [`Draft] - The email is a draft being composed}
109
-
{- [`Answered] - The email has been replied to}
110
-
{- [`Forwarded] - The email has been forwarded}
111
-
{- [`Phishing] - The email is likely phishing}
112
-
{- [`Junk] - The email is spam}
113
-
{- [`NotJunk] - The email is definitely not spam}}
114
-
115
-
{2 Extended Keywords}
116
-
117
-
The library also supports draft-ietf-mailmaint extended keywords:
118
-
119
-
{@ocaml[
120
-
# Keyword.of_string "$notify";;
121
-
- : Keyword.t = $notify
122
-
# Keyword.of_string "$muted";;
123
-
- : Keyword.t = $muted
124
-
# Keyword.of_string "$hasattachment";;
125
-
- : Keyword.t = $hasattachment
126
-
]}
127
-
128
-
{2 Custom Keywords}
129
-
130
-
Unknown keywords are preserved as [`Custom]:
131
-
132
-
{@ocaml[
133
-
# Keyword.of_string "$my_custom_flag";;
134
-
- : Keyword.t = $my_custom_flag
135
-
]}
136
-
137
-
{2 Converting Back to Strings}
138
-
139
-
{@ocaml[
140
-
# Keyword.to_string `Seen;;
141
-
- : string = "$seen"
142
-
# Keyword.to_string `Flagged;;
143
-
- : string = "$flagged"
144
-
# Keyword.to_string (`Custom "$important");;
145
-
- : string = "$important"
146
-
]}
147
-
148
-
{1 Mailbox Roles}
149
-
150
-
Mailboxes can have special roles that indicate their purpose. From
151
-
{{:https://www.rfc-editor.org/rfc/rfc8621#section-2}RFC 8621 Section 2}:
152
-
153
-
{@ocaml[
154
-
# Role.of_string "inbox";;
155
-
- : Role.t = inbox
156
-
# Role.of_string "sent";;
157
-
- : Role.t = sent
158
-
# Role.of_string "drafts";;
159
-
- : Role.t = drafts
160
-
# Role.of_string "trash";;
161
-
- : Role.t = trash
162
-
# Role.of_string "junk";;
163
-
- : Role.t = junk
164
-
# Role.of_string "archive";;
165
-
- : Role.t = archive
166
-
]}
167
-
168
-
Custom roles are also supported:
169
-
170
-
{@ocaml[
171
-
# Role.of_string "receipts";;
172
-
- : Role.t = receipts
173
-
]}
174
-
175
-
{1 Capabilities}
176
-
177
-
JMAP uses capability URIs to indicate supported features. From
178
-
{{:https://www.rfc-editor.org/rfc/rfc8620#section-2}RFC 8620 Section 2}:
179
-
180
-
{@ocaml[
181
-
# Capability.core_uri;;
182
-
- : string = "urn:ietf:params:jmap:core"
183
-
# Capability.mail_uri;;
184
-
- : string = "urn:ietf:params:jmap:mail"
185
-
# Capability.submission_uri;;
186
-
- : string = "urn:ietf:params:jmap:submission"
187
-
]}
188
-
189
-
{@ocaml[
190
-
# Capability.of_string Capability.core_uri;;
191
-
- : Capability.t = urn:ietf:params:jmap:core
192
-
# Capability.of_string Capability.mail_uri;;
193
-
- : Capability.t = urn:ietf:params:jmap:mail
194
-
# Capability.of_string "urn:example:custom";;
195
-
- : Capability.t = urn:example:custom
196
-
]}
197
-
198
-
{1 Understanding JMAP JSON Structure}
199
-
200
-
One of the key benefits of JMAP over IMAP is its use of JSON. Let's see
201
-
how OCaml types map to the wire format.
202
-
203
-
{2 Requests}
204
-
205
-
A JMAP request contains:
206
-
- [using]: List of capability URIs required
207
-
- [methodCalls]: Array of method invocations
208
-
209
-
Each method invocation is a triple: [methodName], [arguments], [callId].
210
-
211
-
Here's how a simple request is structured:
212
-
213
-
{x@ocaml[
214
-
# let req = Jmap.Proto.Request.create
215
-
~using:[Capability.core_uri; Capability.mail_uri]
216
-
~method_calls:[
217
-
Jmap.Proto.Invocation.create
218
-
~name:"Mailbox/get"
219
-
~arguments:(parse_json {|{"accountId": "abc123"}|})
220
-
~call_id:"c0"
221
-
]
222
-
();;
223
-
Line 7, characters 18-22:
224
-
Error: The function applied to this argument has type
225
-
method_call_id:string -> Proto.Invocation.t
226
-
This argument cannot be applied with label ~call_id
227
-
# Jmap_top.encode Jmap.Proto.Request.jsont req |> json_to_string |> print_endline;;
228
-
Line 1, characters 42-45:
229
-
Error: Unbound value req
230
-
Hint: Did you mean ref?
231
-
]x}
232
-
233
-
{2 Email Filter Conditions}
234
-
235
-
Filters demonstrate how complex query conditions map to JSON. From
236
-
{{:https://www.rfc-editor.org/rfc/rfc8621#section-4.4.1}RFC 8621
237
-
Section 4.4.1}:
238
-
239
-
{x@ocaml[
240
-
# let filter_condition : Jmap.Proto.Email.Filter_condition.t = {
241
-
in_mailbox = Some (Id.of_string_exn "inbox123");
242
-
in_mailbox_other_than = None;
243
-
before = None;
244
-
after = None;
245
-
min_size = None;
246
-
max_size = None;
247
-
all_in_thread_have_keyword = None;
248
-
some_in_thread_have_keyword = None;
249
-
none_in_thread_have_keyword = None;
250
-
has_keyword = Some "$flagged";
251
-
not_keyword = None;
252
-
has_attachment = Some true;
253
-
text = None;
254
-
from = Some "alice@";
255
-
to_ = None;
256
-
cc = None;
257
-
bcc = None;
258
-
subject = Some "urgent";
259
-
body = None;
260
-
header = None;
261
-
};;
262
-
Line 2, characters 23-52:
263
-
Error: This expression has type Id.t but an expression was expected of type
264
-
Proto.Id.t
265
-
# Jmap_top.encode Jmap.Proto.Email.Filter_condition.jsont filter_condition
266
-
|> json_to_string |> print_endline;;
267
-
Line 1, characters 57-73:
268
-
Error: Unbound value filter_condition
269
-
]x}
270
-
271
-
Notice how:
272
-
- OCaml record fields use [snake_case], but JSON uses [camelCase]
273
-
- [None] values are omitted from JSON (not sent as [null])
274
-
- The filter only includes non-empty conditions
275
-
276
-
{2 Filter Operators}
277
-
278
-
Filters can be combined with AND, OR, and NOT operators:
279
-
280
-
{x@ocaml[
281
-
# let combined_filter = Jmap.Proto.Filter.Operator {
282
-
operator = `And;
283
-
conditions = [
284
-
Condition filter_condition;
285
-
Condition { filter_condition with has_keyword = Some "$seen" }
286
-
]
287
-
};;
288
-
Line 4, characters 17-33:
289
-
Error: Unbound value filter_condition
290
-
]x}
291
-
292
-
{1 Method Chaining}
293
-
294
-
One of JMAP's most powerful features is result references - using the
295
-
output of one method as input to another. The {!Jmap.Chain} module
296
-
provides a monadic interface for building such requests.
297
-
298
-
From {{:https://www.rfc-editor.org/rfc/rfc8620#section-3.7}RFC 8620
299
-
Section 3.7}:
300
-
301
-
{i A method argument may use the result of a previous method invocation
302
-
in the same request.}
303
-
304
-
{2 Basic Example}
305
-
306
-
Query for emails, then fetch their details:
307
-
308
-
{[
309
-
open Jmap.Chain
310
-
311
-
let request, handle = build ~capabilities:[core; mail] begin
312
-
let* query = email_query ~account_id
313
-
~filter:(Condition { in_mailbox = Some inbox_id; (* ... *) })
314
-
~limit:50L ()
315
-
in
316
-
let* emails = email_get ~account_id
317
-
~ids:(from_query query) (* Reference query results! *)
318
-
~properties:["subject"; "from"; "receivedAt"]
319
-
()
320
-
in
321
-
return emails
322
-
end
323
-
][
324
-
{err@mdx-error[
325
-
Line 3, characters 46-50:
326
-
Error: Unbound value core
327
-
]err}]}
328
-
329
-
The key insight is [from_query query] - this creates a reference to the
330
-
[ids] array from the query response. The server processes both calls in
331
-
sequence, substituting the reference with actual IDs.
332
-
333
-
{2 Creation and Submission}
334
-
335
-
Create a draft and send it in one request:
336
-
337
-
{[
338
-
let* set_h, draft_cid = email_set ~account_id
339
-
~create:[("draft1", draft_email_json)]
340
-
()
341
-
in
342
-
let* _ = email_submission_set ~account_id
343
-
~create:[("sub1", submission_json
344
-
~email_id:(created_id_of_string "draft1") (* Reference creation! *)
345
-
~identity_id)]
346
-
()
347
-
in
348
-
return set_h
349
-
][
350
-
{err@mdx-error[
351
-
Line 1, characters 1-5:
352
-
Error: Unbound value ( let* )
353
-
]err}]}
354
-
355
-
{2 The RFC 8620 Example}
356
-
357
-
The RFC provides a complex example: fetch from/date/subject for all
358
-
emails in the first 10 threads in the inbox:
359
-
360
-
{[
361
-
let* q = email_query ~account_id
362
-
~filter:(Condition { in_mailbox = Some inbox_id; (* ... *) })
363
-
~sort:[comparator ~is_ascending:false "receivedAt"]
364
-
~collapse_threads:true ~limit:10L ()
365
-
in
366
-
let* e1 = email_get ~account_id
367
-
~ids:(from_query q)
368
-
~properties:["threadId"]
369
-
()
370
-
in
371
-
let* threads = thread_get ~account_id
372
-
~ids:(from_get_field e1 "threadId") (* Get threadIds from emails *)
373
-
()
374
-
in
375
-
let* e2 = email_get ~account_id
376
-
~ids:(from_get_field threads "emailIds") (* Get all emailIds in threads *)
377
-
~properties:["from"; "receivedAt"; "subject"]
378
-
()
379
-
in
380
-
return e2
381
-
][
382
-
{err@mdx-error[
383
-
Line 1, characters 1-5:
384
-
Error: Unbound value ( let* )
385
-
]err}]}
386
-
387
-
This entire flow executes in a {e single HTTP request}!
388
-
389
-
{1 Error Handling}
390
-
391
-
JMAP has a structured error system with three levels:
392
-
393
-
{2 Request-Level Errors}
394
-
395
-
These are returned with HTTP error status codes and RFC 7807 Problem
396
-
Details. From {{:https://www.rfc-editor.org/rfc/rfc8620#section-3.6.1}RFC
397
-
8620 Section 3.6.1}:
398
-
399
-
{@ocaml[
400
-
# Error.to_string (`Request {
401
-
Error.type_ = "urn:ietf:params:jmap:error:unknownCapability";
402
-
status = Some 400;
403
-
title = Some "Unknown Capability";
404
-
detail = Some "The server does not support 'urn:example:unsupported'";
405
-
limit = None;
406
-
});;
407
-
- : string =
408
-
"Request error: urn:ietf:params:jmap:error:unknownCapability (status 400): The server does not support 'urn:example:unsupported'"
409
-
]}
410
-
411
-
{2 Method-Level Errors}
412
-
413
-
Individual method calls can fail while others succeed:
414
-
415
-
{@ocaml[
416
-
# Error.to_string (`Method {
417
-
Error.type_ = "invalidArguments";
418
-
description = Some "The 'filter' argument is malformed";
419
-
});;
420
-
- : string =
421
-
"Method error: invalidArguments: The 'filter' argument is malformed"
422
-
]}
423
-
424
-
{2 SetError}
425
-
426
-
Object-level errors in /set responses:
427
-
428
-
{@ocaml[
429
-
# Error.to_string (`Set ("draft1", {
430
-
Error.type_ = "invalidProperties";
431
-
description = Some "Unknown property: foobar";
432
-
properties = Some ["foobar"];
433
-
}));;
434
-
- : string =
435
-
"Set error for draft1: invalidProperties: Unknown property: foobar"
436
-
]}
437
-
438
-
{1 Using with FastMail}
439
-
440
-
FastMail is a popular JMAP provider. Here's how to connect:
441
-
442
-
{[
443
-
(* Get a token from https://app.fastmail.com/settings/tokens *)
444
-
let token = "your-api-token"
445
-
446
-
(* The session URL for FastMail *)
447
-
let session_url = "https://api.fastmail.com/jmap/session"
448
-
449
-
(* For browser applications using jmap-brr: *)
450
-
let main () =
451
-
let open Fut.Syntax in
452
-
let* conn = Jmap_brr.get_session
453
-
~url:(Jstr.v session_url)
454
-
~token:(Jstr.v token)
455
-
in
456
-
match conn with
457
-
| Error e -> Brr.Console.(error [str "Error:"; e]); Fut.return ()
458
-
| Ok conn ->
459
-
let session = Jmap_brr.session conn in
460
-
Brr.Console.(log [str "Connected as:";
461
-
str (Jmap.Session.username session)]);
462
-
Fut.return ()
463
-
][
464
-
{err@mdx-error[
465
-
Line 9, characters 14-17:
466
-
Error: Unbound module Fut
467
-
Hint: Did you mean Fun?
468
-
]err}]}
469
-
470
-
{1 Summary}
471
-
472
-
JMAP (RFC 8620/8621) provides a modern, efficient protocol for email:
473
-
474
-
{ol
475
-
{- {b Sessions}: Discover capabilities and account information via GET request}
476
-
{- {b Batching}: Combine multiple method calls in one request}
477
-
{- {b References}: Use results from one method as input to another}
478
-
{- {b Type Safety}: The [jmap] library uses polymorphic variants for keywords and roles}
479
-
{- {b JSON Mapping}: OCaml types map cleanly to JMAP JSON structure}
480
-
{- {b Browser Support}: The [jmap-brr] package enables browser-based clients}}
481
-
482
-
The [jmap] library provides:
483
-
{ul
484
-
{- {!Jmap} - High-level interface with abstract types}
485
-
{- {!Jmap.Proto} - Low-level protocol types matching the RFCs}
486
-
{- {!Jmap.Chain} - Monadic interface for request chaining}
487
-
{- [Jmap_brr] - Browser support via Brr/js_of_ocaml (separate package)}}
488
-
489
-
{2 Key RFC References}
490
-
491
-
{ul
492
-
{- {{:https://www.rfc-editor.org/rfc/rfc8620}RFC 8620}: JMAP Core}
493
-
{- {{:https://www.rfc-editor.org/rfc/rfc8621}RFC 8621}: JMAP for Mail}
494
-
{- {{:https://www.rfc-editor.org/rfc/rfc7807}RFC 7807}: Problem Details for HTTP APIs}}
+1
-34
dune-project
+1
-34
dune-project
···
1
-
(lang dune 3.20)
2
-
3
-
(using mdx 0.4)
4
-
5
-
(name jmap)
6
-
7
-
(generate_opam_files true)
8
-
9
-
(license ISC)
10
-
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)")
20
-
21
-
(package
22
-
(name jmap)
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.")
26
-
(depends
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))
1
+
(lang dune 3.17)
-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
+15
jmap/dune
+15
jmap/dune
···
1
+
(library
2
+
(name jmap)
3
+
(public_name jmap)
4
+
(libraries yojson uri)
5
+
(modules_without_implementation jmap jmap_binary jmap_error jmap_methods
6
+
jmap_push jmap_session jmap_types jmap_wire)
7
+
(modules
8
+
jmap
9
+
jmap_types
10
+
jmap_error
11
+
jmap_wire
12
+
jmap_session
13
+
jmap_methods
14
+
jmap_binary
15
+
jmap_push))
+136
jmap/jmap.mli
+136
jmap/jmap.mli
···
1
+
(** JMAP Core Protocol Library Interface (RFC 8620)
2
+
3
+
This library provides OCaml types and function signatures for interacting
4
+
with a JMAP server according to the core protocol specification in RFC 8620.
5
+
6
+
Modules:
7
+
- {!Jmap.Types}: Basic data types (Id, Date, etc.).
8
+
- {!Jmap.Error}: Error types (ProblemDetails, MethodError, SetError).
9
+
- {!Jmap.Wire}: Request and Response structures.
10
+
- {!Jmap.Session}: Session object and discovery.
11
+
- {!Jmap.Methods}: Standard method patterns (/get, /set, etc.) and Core/echo.
12
+
- {!Jmap.Binary}: Binary data upload/download types.
13
+
- {!Jmap.Push}: Push notification types (StateChange, PushSubscription).
14
+
15
+
For email-specific extensions (RFC 8621), see the Jmap_email library.
16
+
For Unix-specific implementation, see the Jmap_unix library.
17
+
18
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html> RFC 8620: Core JMAP
19
+
*)
20
+
21
+
(** {1 Core JMAP Types and Modules} *)
22
+
23
+
module Types = Jmap_types
24
+
module Error = Jmap_error
25
+
module Wire = Jmap_wire
26
+
module Session = Jmap_session
27
+
module Methods = Jmap_methods
28
+
module Binary = Jmap_binary
29
+
module Push = Jmap_push
30
+
31
+
(** {1 Example Usage}
32
+
33
+
The following example demonstrates using the Core JMAP library with the Unix implementation
34
+
to make a simple echo request.
35
+
36
+
{[
37
+
(* OCaml 5.1 required for Lwt let operators *)
38
+
open Lwt.Syntax
39
+
open Jmap
40
+
open Jmap.Types
41
+
open Jmap.Wire
42
+
open Jmap.Methods
43
+
open Jmap.Unix
44
+
45
+
let simple_echo_request ctx session =
46
+
(* Prepare an echo invocation *)
47
+
let echo_args = Yojson.Safe.to_basic (`Assoc [
48
+
("hello", `String "world");
49
+
("array", `List [`Int 1; `Int 2; `Int 3]);
50
+
]) in
51
+
52
+
let echo_invocation = Invocation.v
53
+
~method_name:"Core/echo"
54
+
~arguments:echo_args
55
+
~method_call_id:"echo1"
56
+
()
57
+
in
58
+
59
+
(* Prepare the JMAP request *)
60
+
let request = Request.v
61
+
~using:[capability_core]
62
+
~method_calls:[echo_invocation]
63
+
()
64
+
in
65
+
66
+
(* Send the request *)
67
+
let* response = Jmap.Unix.request ctx request in
68
+
69
+
(* Process the response *)
70
+
match Wire.find_method_response response "echo1" with
71
+
| Some (method_name, args, _) when method_name = "Core/echo" ->
72
+
(* Echo response should contain the same arguments we sent *)
73
+
let hello_value = match Yojson.Safe.Util.member "hello" args with
74
+
| `String s -> s
75
+
| _ -> "not found"
76
+
in
77
+
Printf.printf "Echo response received: hello=%s\n" hello_value;
78
+
Lwt.return_unit
79
+
| _ ->
80
+
Printf.eprintf "Echo response not found or unexpected format\n";
81
+
Lwt.return_unit
82
+
83
+
let main () =
84
+
(* Authentication details are placeholder *)
85
+
let credentials = "my_auth_token" in
86
+
let* (ctx, session) = Jmap.Unix.connect ~host:"jmap.example.com" ~credentials in
87
+
let* () = simple_echo_request ctx session in
88
+
Jmap.Unix.close ctx
89
+
90
+
(* Lwt_main.run (main ()) *)
91
+
]}
92
+
*)
93
+
94
+
(** Capability URI for JMAP Core.
95
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-2> RFC 8620, Section 2 *)
96
+
val capability_core : string
97
+
98
+
(** {1 Convenience Functions} *)
99
+
100
+
(** Check if a session supports a given capability.
101
+
@param session The session object.
102
+
@param capability The capability URI to check.
103
+
@return True if supported, false otherwise.
104
+
*)
105
+
val supports_capability : Jmap_session.Session.t -> string -> bool
106
+
107
+
(** Get the primary account ID for a given capability.
108
+
@param session The session object.
109
+
@param capability The capability URI.
110
+
@return The account ID or an error if not found.
111
+
*)
112
+
val get_primary_account : Jmap_session.Session.t -> string -> (Jmap_types.id, Error.error) result
113
+
114
+
(** Get the download URL for a blob.
115
+
@param session The session object.
116
+
@param account_id The account ID.
117
+
@param blob_id The blob ID.
118
+
@param ?name Optional filename for the download.
119
+
@param ?content_type Optional content type for the download.
120
+
@return The download URL.
121
+
*)
122
+
val get_download_url :
123
+
Jmap_session.Session.t ->
124
+
account_id:Jmap_types.id ->
125
+
blob_id:Jmap_types.id ->
126
+
?name:string ->
127
+
?content_type:string ->
128
+
unit ->
129
+
Uri.t
130
+
131
+
(** Get the upload URL for a blob.
132
+
@param session The session object.
133
+
@param account_id The account ID.
134
+
@return The upload URL.
135
+
*)
136
+
val get_upload_url : Jmap_session.Session.t -> account_id:Jmap_types.id -> Uri.t
+60
jmap/jmap_binary.mli
+60
jmap/jmap_binary.mli
···
1
+
(** JMAP Binary Data Handling.
2
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-6> RFC 8620, Section 6 *)
3
+
4
+
open Jmap_types
5
+
open Jmap_error
6
+
7
+
(** Response from uploading binary data.
8
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-6.1> RFC 8620, Section 6.1 *)
9
+
module Upload_response : sig
10
+
type t
11
+
12
+
val account_id : t -> id
13
+
val blob_id : t -> id
14
+
val type_ : t -> string
15
+
val size : t -> uint
16
+
17
+
val v :
18
+
account_id:id ->
19
+
blob_id:id ->
20
+
type_:string ->
21
+
size:uint ->
22
+
unit ->
23
+
t
24
+
end
25
+
26
+
(** Arguments for Blob/copy.
27
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-6.3> RFC 8620, Section 6.3 *)
28
+
module Blob_copy_args : sig
29
+
type t
30
+
31
+
val from_account_id : t -> id
32
+
val account_id : t -> id
33
+
val blob_ids : t -> id list
34
+
35
+
val v :
36
+
from_account_id:id ->
37
+
account_id:id ->
38
+
blob_ids:id list ->
39
+
unit ->
40
+
t
41
+
end
42
+
43
+
(** Response for Blob/copy.
44
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-6.3> RFC 8620, Section 6.3 *)
45
+
module Blob_copy_response : sig
46
+
type t
47
+
48
+
val from_account_id : t -> id
49
+
val account_id : t -> id
50
+
val copied : t -> id id_map option
51
+
val not_copied : t -> Set_error.t id_map option
52
+
53
+
val v :
54
+
from_account_id:id ->
55
+
account_id:id ->
56
+
?copied:id id_map ->
57
+
?not_copied:Set_error.t id_map ->
58
+
unit ->
59
+
t
60
+
end
+189
jmap/jmap_error.mli
+189
jmap/jmap_error.mli
···
1
+
(** JMAP Error Types.
2
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.6> RFC 8620, Section 3.6 *)
3
+
4
+
open Jmap_types
5
+
6
+
(** Standard Method-level error types.
7
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.6.2> RFC 8620, Section 3.6.2 *)
8
+
type method_error_type = [
9
+
| `ServerUnavailable
10
+
| `ServerFail
11
+
| `ServerPartialFail
12
+
| `UnknownMethod
13
+
| `InvalidArguments
14
+
| `InvalidResultReference
15
+
| `Forbidden
16
+
| `AccountNotFound
17
+
| `AccountNotSupportedByMethod
18
+
| `AccountReadOnly
19
+
| `RequestTooLarge
20
+
| `CannotCalculateChanges
21
+
| `StateMismatch
22
+
| `AnchorNotFound
23
+
| `UnsupportedSort
24
+
| `UnsupportedFilter
25
+
| `TooManyChanges
26
+
| `FromAccountNotFound
27
+
| `FromAccountNotSupportedByMethod
28
+
| `Other_method_error of string
29
+
]
30
+
31
+
(** Standard SetError types.
32
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.3> RFC 8620, Section 5.3 *)
33
+
type set_error_type = [
34
+
| `Forbidden
35
+
| `OverQuota
36
+
| `TooLarge
37
+
| `RateLimit
38
+
| `NotFound
39
+
| `InvalidPatch
40
+
| `WillDestroy
41
+
| `InvalidProperties
42
+
| `Singleton
43
+
| `AlreadyExists (* From /copy *)
44
+
| `MailboxHasChild (* RFC 8621 *)
45
+
| `MailboxHasEmail (* RFC 8621 *)
46
+
| `BlobNotFound (* RFC 8621 *)
47
+
| `TooManyKeywords (* RFC 8621 *)
48
+
| `TooManyMailboxes (* RFC 8621 *)
49
+
| `InvalidEmail (* RFC 8621 *)
50
+
| `TooManyRecipients (* RFC 8621 *)
51
+
| `NoRecipients (* RFC 8621 *)
52
+
| `InvalidRecipients (* RFC 8621 *)
53
+
| `ForbiddenMailFrom (* RFC 8621 *)
54
+
| `ForbiddenFrom (* RFC 8621 *)
55
+
| `ForbiddenToSend (* RFC 8621 *)
56
+
| `CannotUnsend (* RFC 8621 *)
57
+
| `Other_set_error of string (* For future or custom errors *)
58
+
]
59
+
60
+
(** Primary error type that can represent all JMAP errors *)
61
+
type error =
62
+
| Transport of string (** Network/HTTP-level error *)
63
+
| Parse of string (** JSON parsing error *)
64
+
| Protocol of string (** JMAP protocol error *)
65
+
| Problem of string (** Problem Details object error *)
66
+
| Method of method_error_type * string option (** Method error with optional description *)
67
+
| SetItem of id * set_error_type * string option (** Error for a specific item in a /set operation *)
68
+
| Auth of string (** Authentication error *)
69
+
| ServerError of string (** Server reported an error *)
70
+
71
+
(** Standard Result type for JMAP operations *)
72
+
type 'a result = ('a, error) Result.t
73
+
74
+
(** Problem details object for HTTP-level errors.
75
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.6.1> RFC 8620, Section 3.6.1
76
+
@see <https://www.rfc-editor.org/rfc/rfc7807.html> RFC 7807 *)
77
+
module Problem_details : sig
78
+
type t
79
+
80
+
val problem_type : t -> string
81
+
val status : t -> int option
82
+
val detail : t -> string option
83
+
val limit : t -> string option
84
+
val other_fields : t -> Yojson.Safe.t string_map
85
+
86
+
val v :
87
+
?status:int ->
88
+
?detail:string ->
89
+
?limit:string ->
90
+
?other_fields:Yojson.Safe.t string_map ->
91
+
string ->
92
+
t
93
+
end
94
+
95
+
(** Description for method errors. May contain additional details.
96
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.6.2> RFC 8620, Section 3.6.2 *)
97
+
module Method_error_description : sig
98
+
type t
99
+
100
+
val description : t -> string option
101
+
102
+
val v : ?description:string -> unit -> t
103
+
end
104
+
105
+
(** Represents a method-level error response invocation part.
106
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.6.2> RFC 8620, Section 3.6.2 *)
107
+
module Method_error : sig
108
+
type t
109
+
110
+
val type_ : t -> method_error_type
111
+
val description : t -> Method_error_description.t option
112
+
113
+
val v :
114
+
?description:Method_error_description.t ->
115
+
method_error_type ->
116
+
t
117
+
end
118
+
119
+
(** SetError object.
120
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.3> RFC 8620, Section 5.3 *)
121
+
module Set_error : sig
122
+
type t
123
+
124
+
val type_ : t -> set_error_type
125
+
val description : t -> string option
126
+
val properties : t -> string list option
127
+
val existing_id : t -> id option
128
+
val max_recipients : t -> uint option
129
+
val invalid_recipients : t -> string list option
130
+
val max_size : t -> uint option
131
+
val not_found_blob_ids : t -> id list option
132
+
133
+
val v :
134
+
?description:string ->
135
+
?properties:string list ->
136
+
?existing_id:id ->
137
+
?max_recipients:uint ->
138
+
?invalid_recipients:string list ->
139
+
?max_size:uint ->
140
+
?not_found_blob_ids:id list ->
141
+
set_error_type ->
142
+
t
143
+
end
144
+
145
+
(** {2 Error Handling Functions} *)
146
+
147
+
(** Create a transport error *)
148
+
val transport_error : string -> error
149
+
150
+
(** Create a parse error *)
151
+
val parse_error : string -> error
152
+
153
+
(** Create a protocol error *)
154
+
val protocol_error : string -> error
155
+
156
+
(** Create a problem details error *)
157
+
val problem_error : Problem_details.t -> error
158
+
159
+
(** Create a method error *)
160
+
val method_error : ?description:string -> method_error_type -> error
161
+
162
+
(** Create a SetItem error *)
163
+
val set_item_error : id -> ?description:string -> set_error_type -> error
164
+
165
+
(** Create an auth error *)
166
+
val auth_error : string -> error
167
+
168
+
(** Create a server error *)
169
+
val server_error : string -> error
170
+
171
+
(** Convert a Method_error.t to error *)
172
+
val of_method_error : Method_error.t -> error
173
+
174
+
(** Convert a Set_error.t to error for a specific ID *)
175
+
val of_set_error : id -> Set_error.t -> error
176
+
177
+
(** Get a human-readable description of an error *)
178
+
val error_to_string : error -> string
179
+
180
+
(** {2 Result Handling} *)
181
+
182
+
(** Map an error with additional context *)
183
+
val map_error : 'a result -> (error -> error) -> 'a result
184
+
185
+
(** Add context to an error *)
186
+
val with_context : 'a result -> string -> 'a result
187
+
188
+
(** Convert an option to a result with an error for None *)
189
+
val of_option : 'a option -> error -> 'a result
+417
jmap/jmap_methods.mli
+417
jmap/jmap_methods.mli
···
1
+
(** Standard JMAP Methods and Core/echo.
2
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-4> RFC 8620, Section 4
3
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5> RFC 8620, Section 5 *)
4
+
5
+
open Jmap_types
6
+
open Jmap_error
7
+
8
+
(** Generic representation of a record type. Actual types defined elsewhere. *)
9
+
type generic_record
10
+
11
+
(** Arguments for /get methods.
12
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.1> RFC 8620, Section 5.1 *)
13
+
module Get_args : sig
14
+
type 'record t
15
+
16
+
val account_id : 'record t -> id
17
+
val ids : 'record t -> id list option
18
+
val properties : 'record t -> string list option
19
+
20
+
val v :
21
+
account_id:id ->
22
+
?ids:id list ->
23
+
?properties:string list ->
24
+
unit ->
25
+
'record t
26
+
end
27
+
28
+
(** Response for /get methods.
29
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.1> RFC 8620, Section 5.1 *)
30
+
module Get_response : sig
31
+
type 'record t
32
+
33
+
val account_id : 'record t -> id
34
+
val state : 'record t -> string
35
+
val list : 'record t -> 'record list
36
+
val not_found : 'record t -> id list
37
+
38
+
val v :
39
+
account_id:id ->
40
+
state:string ->
41
+
list:'record list ->
42
+
not_found:id list ->
43
+
unit ->
44
+
'record t
45
+
end
46
+
47
+
(** Arguments for /changes methods.
48
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.2> RFC 8620, Section 5.2 *)
49
+
module Changes_args : sig
50
+
type t
51
+
52
+
val account_id : t -> id
53
+
val since_state : t -> string
54
+
val max_changes : t -> uint option
55
+
56
+
val v :
57
+
account_id:id ->
58
+
since_state:string ->
59
+
?max_changes:uint ->
60
+
unit ->
61
+
t
62
+
end
63
+
64
+
(** Response for /changes methods.
65
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.2> RFC 8620, Section 5.2 *)
66
+
module Changes_response : sig
67
+
type t
68
+
69
+
val account_id : t -> id
70
+
val old_state : t -> string
71
+
val new_state : t -> string
72
+
val has_more_changes : t -> bool
73
+
val created : t -> id list
74
+
val updated : t -> id list
75
+
val destroyed : t -> id list
76
+
val updated_properties : t -> string list option
77
+
78
+
val v :
79
+
account_id:id ->
80
+
old_state:string ->
81
+
new_state:string ->
82
+
has_more_changes:bool ->
83
+
created:id list ->
84
+
updated:id list ->
85
+
destroyed:id list ->
86
+
?updated_properties:string list ->
87
+
unit ->
88
+
t
89
+
end
90
+
91
+
(** Patch object for /set update.
92
+
A list of (JSON Pointer path, value) pairs.
93
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.3> RFC 8620, Section 5.3 *)
94
+
type patch_object = (json_pointer * Yojson.Safe.t) list
95
+
96
+
(** Arguments for /set methods.
97
+
['create_record] is the record type without server-set/immutable fields.
98
+
['update_record] is the patch object type (usually [patch_object]).
99
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.3> RFC 8620, Section 5.3 *)
100
+
module Set_args : sig
101
+
type ('create_record, 'update_record) t
102
+
103
+
val account_id : ('a, 'b) t -> id
104
+
val if_in_state : ('a, 'b) t -> string option
105
+
val create : ('a, 'b) t -> 'a id_map option
106
+
val update : ('a, 'b) t -> 'b id_map option
107
+
val destroy : ('a, 'b) t -> id list option
108
+
val on_success_destroy_original : ('a, 'b) t -> bool option
109
+
val destroy_from_if_in_state : ('a, 'b) t -> string option
110
+
val on_destroy_remove_emails : ('a, 'b) t -> bool option
111
+
112
+
val v :
113
+
account_id:id ->
114
+
?if_in_state:string ->
115
+
?create:'a id_map ->
116
+
?update:'b id_map ->
117
+
?destroy:id list ->
118
+
?on_success_destroy_original:bool ->
119
+
?destroy_from_if_in_state:string ->
120
+
?on_destroy_remove_emails:bool ->
121
+
unit ->
122
+
('a, 'b) t
123
+
end
124
+
125
+
(** Response for /set methods.
126
+
['created_record_info] is the server-set info for created records.
127
+
['updated_record_info] is the server-set/computed info for updated records.
128
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.3> RFC 8620, Section 5.3 *)
129
+
module Set_response : sig
130
+
type ('created_record_info, 'updated_record_info) t
131
+
132
+
val account_id : ('a, 'b) t -> id
133
+
val old_state : ('a, 'b) t -> string option
134
+
val new_state : ('a, 'b) t -> string
135
+
val created : ('a, 'b) t -> 'a id_map option
136
+
val updated : ('a, 'b) t -> 'b option id_map option
137
+
val destroyed : ('a, 'b) t -> id list option
138
+
val not_created : ('a, 'b) t -> Set_error.t id_map option
139
+
val not_updated : ('a, 'b) t -> Set_error.t id_map option
140
+
val not_destroyed : ('a, 'b) t -> Set_error.t id_map option
141
+
142
+
val v :
143
+
account_id:id ->
144
+
?old_state:string ->
145
+
new_state:string ->
146
+
?created:'a id_map ->
147
+
?updated:'b option id_map ->
148
+
?destroyed:id list ->
149
+
?not_created:Set_error.t id_map ->
150
+
?not_updated:Set_error.t id_map ->
151
+
?not_destroyed:Set_error.t id_map ->
152
+
unit ->
153
+
('a, 'b) t
154
+
end
155
+
156
+
(** Arguments for /copy methods.
157
+
['copy_record_override] contains the record id and override properties.
158
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.4> RFC 8620, Section 5.4 *)
159
+
module Copy_args : sig
160
+
type 'copy_record_override t
161
+
162
+
val from_account_id : 'a t -> id
163
+
val if_from_in_state : 'a t -> string option
164
+
val account_id : 'a t -> id
165
+
val if_in_state : 'a t -> string option
166
+
val create : 'a t -> 'a id_map
167
+
val on_success_destroy_original : 'a t -> bool
168
+
val destroy_from_if_in_state : 'a t -> string option
169
+
170
+
val v :
171
+
from_account_id:id ->
172
+
?if_from_in_state:string ->
173
+
account_id:id ->
174
+
?if_in_state:string ->
175
+
create:'a id_map ->
176
+
?on_success_destroy_original:bool ->
177
+
?destroy_from_if_in_state:string ->
178
+
unit ->
179
+
'a t
180
+
end
181
+
182
+
(** Response for /copy methods.
183
+
['created_record_info] is the server-set info for the created copy.
184
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.4> RFC 8620, Section 5.4 *)
185
+
module Copy_response : sig
186
+
type 'created_record_info t
187
+
188
+
val from_account_id : 'a t -> id
189
+
val account_id : 'a t -> id
190
+
val old_state : 'a t -> string option
191
+
val new_state : 'a t -> string
192
+
val created : 'a t -> 'a id_map option
193
+
val not_created : 'a t -> Set_error.t id_map option
194
+
195
+
val v :
196
+
from_account_id:id ->
197
+
account_id:id ->
198
+
?old_state:string ->
199
+
new_state:string ->
200
+
?created:'a id_map ->
201
+
?not_created:Set_error.t id_map ->
202
+
unit ->
203
+
'a t
204
+
end
205
+
206
+
(** Module for generic filter representation.
207
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.5> RFC 8620, Section 5.5 *)
208
+
module Filter : sig
209
+
type t
210
+
211
+
(** Create a filter from a raw JSON condition *)
212
+
val condition : Yojson.Safe.t -> t
213
+
214
+
(** Create a filter with a logical operator (AND, OR, NOT) *)
215
+
val operator : [ `AND | `OR | `NOT ] -> t list -> t
216
+
217
+
(** Combine filters with AND *)
218
+
val and_ : t list -> t
219
+
220
+
(** Combine filters with OR *)
221
+
val or_ : t list -> t
222
+
223
+
(** Negate a filter with NOT *)
224
+
val not_ : t -> t
225
+
226
+
(** Convert a filter to JSON *)
227
+
val to_json : t -> Yojson.Safe.t
228
+
229
+
(** Predefined filter helpers *)
230
+
231
+
(** Create a filter for a text property containing a string *)
232
+
val text_contains : string -> string -> t
233
+
234
+
(** Create a filter for a property being equal to a value *)
235
+
val property_equals : string -> Yojson.Safe.t -> t
236
+
237
+
(** Create a filter for a property being not equal to a value *)
238
+
val property_not_equals : string -> Yojson.Safe.t -> t
239
+
240
+
(** Create a filter for a property being greater than a value *)
241
+
val property_gt : string -> Yojson.Safe.t -> t
242
+
243
+
(** Create a filter for a property being greater than or equal to a value *)
244
+
val property_ge : string -> Yojson.Safe.t -> t
245
+
246
+
(** Create a filter for a property being less than a value *)
247
+
val property_lt : string -> Yojson.Safe.t -> t
248
+
249
+
(** Create a filter for a property being less than or equal to a value *)
250
+
val property_le : string -> Yojson.Safe.t -> t
251
+
252
+
(** Create a filter for a property value being in a list *)
253
+
val property_in : string -> Yojson.Safe.t list -> t
254
+
255
+
(** Create a filter for a property value not being in a list *)
256
+
val property_not_in : string -> Yojson.Safe.t list -> t
257
+
258
+
(** Create a filter for a property being present (not null) *)
259
+
val property_exists : string -> t
260
+
261
+
(** Create a filter for a string property starting with a prefix *)
262
+
val string_starts_with : string -> string -> t
263
+
264
+
(** Create a filter for a string property ending with a suffix *)
265
+
val string_ends_with : string -> string -> t
266
+
end
267
+
268
+
269
+
270
+
(** Comparator for sorting.
271
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.5> RFC 8620, Section 5.5 *)
272
+
module Comparator : sig
273
+
type t
274
+
275
+
val property : t -> string
276
+
val is_ascending : t -> bool option
277
+
val collation : t -> string option
278
+
val keyword : t -> string option
279
+
val other_fields : t -> Yojson.Safe.t string_map
280
+
281
+
val v :
282
+
property:string ->
283
+
?is_ascending:bool ->
284
+
?collation:string ->
285
+
?keyword:string ->
286
+
?other_fields:Yojson.Safe.t string_map ->
287
+
unit ->
288
+
t
289
+
end
290
+
291
+
(** Arguments for /query methods.
292
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.5> RFC 8620, Section 5.5 *)
293
+
module Query_args : sig
294
+
type t
295
+
296
+
val account_id : t -> id
297
+
val filter : t -> Filter.t option
298
+
val sort : t -> Comparator.t list option
299
+
val position : t -> jint option
300
+
val anchor : t -> id option
301
+
val anchor_offset : t -> jint option
302
+
val limit : t -> uint option
303
+
val calculate_total : t -> bool option
304
+
val collapse_threads : t -> bool option
305
+
val sort_as_tree : t -> bool option
306
+
val filter_as_tree : t -> bool option
307
+
308
+
val v :
309
+
account_id:id ->
310
+
?filter:Filter.t ->
311
+
?sort:Comparator.t list ->
312
+
?position:jint ->
313
+
?anchor:id ->
314
+
?anchor_offset:jint ->
315
+
?limit:uint ->
316
+
?calculate_total:bool ->
317
+
?collapse_threads:bool ->
318
+
?sort_as_tree:bool ->
319
+
?filter_as_tree:bool ->
320
+
unit ->
321
+
t
322
+
end
323
+
324
+
(** Response for /query methods.
325
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.5> RFC 8620, Section 5.5 *)
326
+
module Query_response : sig
327
+
type t
328
+
329
+
val account_id : t -> id
330
+
val query_state : t -> string
331
+
val can_calculate_changes : t -> bool
332
+
val position : t -> uint
333
+
val ids : t -> id list
334
+
val total : t -> uint option
335
+
val limit : t -> uint option
336
+
337
+
val v :
338
+
account_id:id ->
339
+
query_state:string ->
340
+
can_calculate_changes:bool ->
341
+
position:uint ->
342
+
ids:id list ->
343
+
?total:uint ->
344
+
?limit:uint ->
345
+
unit ->
346
+
t
347
+
end
348
+
349
+
(** Item indicating an added record in /queryChanges.
350
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.6> RFC 8620, Section 5.6 *)
351
+
module Added_item : sig
352
+
type t
353
+
354
+
val id : t -> id
355
+
val index : t -> uint
356
+
357
+
val v :
358
+
id:id ->
359
+
index:uint ->
360
+
unit ->
361
+
t
362
+
end
363
+
364
+
(** Arguments for /queryChanges methods.
365
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.6> RFC 8620, Section 5.6 *)
366
+
module Query_changes_args : sig
367
+
type t
368
+
369
+
val account_id : t -> id
370
+
val filter : t -> Filter.t option
371
+
val sort : t -> Comparator.t list option
372
+
val since_query_state : t -> string
373
+
val max_changes : t -> uint option
374
+
val up_to_id : t -> id option
375
+
val calculate_total : t -> bool option
376
+
val collapse_threads : t -> bool option
377
+
378
+
val v :
379
+
account_id:id ->
380
+
?filter:Filter.t ->
381
+
?sort:Comparator.t list ->
382
+
since_query_state:string ->
383
+
?max_changes:uint ->
384
+
?up_to_id:id ->
385
+
?calculate_total:bool ->
386
+
?collapse_threads:bool ->
387
+
unit ->
388
+
t
389
+
end
390
+
391
+
(** Response for /queryChanges methods.
392
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-5.6> RFC 8620, Section 5.6 *)
393
+
module Query_changes_response : sig
394
+
type t
395
+
396
+
val account_id : t -> id
397
+
val old_query_state : t -> string
398
+
val new_query_state : t -> string
399
+
val total : t -> uint option
400
+
val removed : t -> id list
401
+
val added : t -> Added_item.t list
402
+
403
+
val v :
404
+
account_id:id ->
405
+
old_query_state:string ->
406
+
new_query_state:string ->
407
+
?total:uint ->
408
+
removed:id list ->
409
+
added:Added_item.t list ->
410
+
unit ->
411
+
t
412
+
end
413
+
414
+
(** Core/echo method: Arguments are mirrored in the response.
415
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-4> RFC 8620, Section 4 *)
416
+
type core_echo_args = Yojson.Safe.t
417
+
type core_echo_response = Yojson.Safe.t
+230
jmap/jmap_push.mli
+230
jmap/jmap_push.mli
···
1
+
(** JMAP Push Notifications.
2
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7> RFC 8620, Section 7 *)
3
+
4
+
open Jmap_types
5
+
open Jmap_methods
6
+
open Jmap_error
7
+
8
+
(** TypeState object map (TypeName -> StateString).
9
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.1> RFC 8620, Section 7.1 *)
10
+
type type_state = string string_map
11
+
12
+
(** StateChange object.
13
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.1> RFC 8620, Section 7.1 *)
14
+
module State_change : sig
15
+
type t
16
+
17
+
val changed : t -> type_state id_map
18
+
19
+
val v :
20
+
changed:type_state id_map ->
21
+
unit ->
22
+
t
23
+
end
24
+
25
+
(** PushSubscription encryption keys.
26
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.2> RFC 8620, Section 7.2 *)
27
+
module Push_encryption_keys : sig
28
+
type t
29
+
30
+
(** P-256 ECDH public key (URL-safe base64) *)
31
+
val p256dh : t -> string
32
+
33
+
(** Authentication secret (URL-safe base64) *)
34
+
val auth : t -> string
35
+
36
+
val v :
37
+
p256dh:string ->
38
+
auth:string ->
39
+
unit ->
40
+
t
41
+
end
42
+
43
+
(** PushSubscription object.
44
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.2> RFC 8620, Section 7.2 *)
45
+
module Push_subscription : sig
46
+
type t
47
+
48
+
(** Id of the subscription (server-set, immutable) *)
49
+
val id : t -> id
50
+
51
+
(** Device client id (immutable) *)
52
+
val device_client_id : t -> string
53
+
54
+
(** Notification URL (immutable) *)
55
+
val url : t -> Uri.t
56
+
57
+
(** Encryption keys (immutable) *)
58
+
val keys : t -> Push_encryption_keys.t option
59
+
val verification_code : t -> string option
60
+
val expires : t -> utc_date option
61
+
val types : t -> string list option
62
+
63
+
val v :
64
+
id:id ->
65
+
device_client_id:string ->
66
+
url:Uri.t ->
67
+
?keys:Push_encryption_keys.t ->
68
+
?verification_code:string ->
69
+
?expires:utc_date ->
70
+
?types:string list ->
71
+
unit ->
72
+
t
73
+
end
74
+
75
+
(** PushSubscription object for creation (omits server-set fields).
76
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.2> RFC 8620, Section 7.2 *)
77
+
module Push_subscription_create : sig
78
+
type t
79
+
80
+
val device_client_id : t -> string
81
+
val url : t -> Uri.t
82
+
val keys : t -> Push_encryption_keys.t option
83
+
val expires : t -> utc_date option
84
+
val types : t -> string list option
85
+
86
+
val v :
87
+
device_client_id:string ->
88
+
url:Uri.t ->
89
+
?keys:Push_encryption_keys.t ->
90
+
?expires:utc_date ->
91
+
?types:string list ->
92
+
unit ->
93
+
t
94
+
end
95
+
96
+
(** PushSubscription object for update patch.
97
+
Only verification_code and expires can be updated.
98
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.2> RFC 8620, Section 7.2
99
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.2.2> RFC 8620, Section 7.2.2 *)
100
+
type push_subscription_update = patch_object
101
+
102
+
(** Arguments for PushSubscription/get.
103
+
Extends standard /get args.
104
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.2.1> RFC 8620, Section 7.2.1 *)
105
+
module Push_subscription_get_args : sig
106
+
type t
107
+
108
+
val ids : t -> id list option
109
+
val properties : t -> string list option
110
+
111
+
val v :
112
+
?ids:id list ->
113
+
?properties:string list ->
114
+
unit ->
115
+
t
116
+
end
117
+
118
+
(** Response for PushSubscription/get.
119
+
Extends standard /get response.
120
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.2.1> RFC 8620, Section 7.2.1 *)
121
+
module Push_subscription_get_response : sig
122
+
type t
123
+
124
+
val list : t -> Push_subscription.t list
125
+
val not_found : t -> id list
126
+
127
+
val v :
128
+
list:Push_subscription.t list ->
129
+
not_found:id list ->
130
+
unit ->
131
+
t
132
+
end
133
+
134
+
(** Arguments for PushSubscription/set.
135
+
Extends standard /set args.
136
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.2.2> RFC 8620, Section 7.2.2 *)
137
+
module Push_subscription_set_args : sig
138
+
type t
139
+
140
+
val create : t -> Push_subscription_create.t id_map option
141
+
val update : t -> push_subscription_update id_map option
142
+
val destroy : t -> id list option
143
+
144
+
val v :
145
+
?create:Push_subscription_create.t id_map ->
146
+
?update:push_subscription_update id_map ->
147
+
?destroy:id list ->
148
+
unit ->
149
+
t
150
+
end
151
+
152
+
(** Server-set information for created PushSubscription.
153
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.2.2> RFC 8620, Section 7.2.2 *)
154
+
module Push_subscription_created_info : sig
155
+
type t
156
+
157
+
val id : t -> id
158
+
val expires : t -> utc_date option
159
+
160
+
val v :
161
+
id:id ->
162
+
?expires:utc_date ->
163
+
unit ->
164
+
t
165
+
end
166
+
167
+
(** Server-set information for updated PushSubscription.
168
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.2.2> RFC 8620, Section 7.2.2 *)
169
+
module Push_subscription_updated_info : sig
170
+
type t
171
+
172
+
val expires : t -> utc_date option
173
+
174
+
val v :
175
+
?expires:utc_date ->
176
+
unit ->
177
+
t
178
+
end
179
+
180
+
(** Response for PushSubscription/set.
181
+
Extends standard /set response.
182
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.2.2> RFC 8620, Section 7.2.2 *)
183
+
module Push_subscription_set_response : sig
184
+
type t
185
+
186
+
val created : t -> Push_subscription_created_info.t id_map option
187
+
val updated : t -> Push_subscription_updated_info.t option id_map option
188
+
val destroyed : t -> id list option
189
+
val not_created : t -> Set_error.t id_map option
190
+
val not_updated : t -> Set_error.t id_map option
191
+
val not_destroyed : t -> Set_error.t id_map option
192
+
193
+
val v :
194
+
?created:Push_subscription_created_info.t id_map ->
195
+
?updated:Push_subscription_updated_info.t option id_map ->
196
+
?destroyed:id list ->
197
+
?not_created:Set_error.t id_map ->
198
+
?not_updated:Set_error.t id_map ->
199
+
?not_destroyed:Set_error.t id_map ->
200
+
unit ->
201
+
t
202
+
end
203
+
204
+
(** PushVerification object.
205
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.2.2> RFC 8620, Section 7.2.2 *)
206
+
module Push_verification : sig
207
+
type t
208
+
209
+
val push_subscription_id : t -> id
210
+
val verification_code : t -> string
211
+
212
+
val v :
213
+
push_subscription_id:id ->
214
+
verification_code:string ->
215
+
unit ->
216
+
t
217
+
end
218
+
219
+
(** Data for EventSource ping event.
220
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.3> RFC 8620, Section 7.3 *)
221
+
module Event_source_ping_data : sig
222
+
type t
223
+
224
+
val interval : t -> uint
225
+
226
+
val v :
227
+
interval:uint ->
228
+
unit ->
229
+
t
230
+
end
+98
jmap/jmap_session.mli
+98
jmap/jmap_session.mli
···
1
+
(** JMAP Session Resource.
2
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-2> RFC 8620, Section 2 *)
3
+
4
+
open Jmap_types
5
+
6
+
(** Account capability information.
7
+
The value is capability-specific.
8
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-2> RFC 8620, Section 2 *)
9
+
type account_capability_value = Yojson.Safe.t
10
+
11
+
(** Server capability information.
12
+
The value is capability-specific.
13
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-2> RFC 8620, Section 2 *)
14
+
type server_capability_value = Yojson.Safe.t
15
+
16
+
(** Core capability information.
17
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-2> RFC 8620, Section 2 *)
18
+
module Core_capability : sig
19
+
type t
20
+
21
+
val max_size_upload : t -> uint
22
+
val max_concurrent_upload : t -> uint
23
+
val max_size_request : t -> uint
24
+
val max_concurrent_requests : t -> uint
25
+
val max_calls_in_request : t -> uint
26
+
val max_objects_in_get : t -> uint
27
+
val max_objects_in_set : t -> uint
28
+
val collation_algorithms : t -> string list
29
+
30
+
val v :
31
+
max_size_upload:uint ->
32
+
max_concurrent_upload:uint ->
33
+
max_size_request:uint ->
34
+
max_concurrent_requests:uint ->
35
+
max_calls_in_request:uint ->
36
+
max_objects_in_get:uint ->
37
+
max_objects_in_set:uint ->
38
+
collation_algorithms:string list ->
39
+
unit ->
40
+
t
41
+
end
42
+
43
+
(** An Account object.
44
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-2> RFC 8620, Section 2 *)
45
+
module Account : sig
46
+
type t
47
+
48
+
val name : t -> string
49
+
val is_personal : t -> bool
50
+
val is_read_only : t -> bool
51
+
val account_capabilities : t -> account_capability_value string_map
52
+
53
+
val v :
54
+
name:string ->
55
+
?is_personal:bool ->
56
+
?is_read_only:bool ->
57
+
?account_capabilities:account_capability_value string_map ->
58
+
unit ->
59
+
t
60
+
end
61
+
62
+
(** The Session object.
63
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-2> RFC 8620, Section 2 *)
64
+
module Session : sig
65
+
type t
66
+
67
+
val capabilities : t -> server_capability_value string_map
68
+
val accounts : t -> Account.t id_map
69
+
val primary_accounts : t -> id string_map
70
+
val username : t -> string
71
+
val api_url : t -> Uri.t
72
+
val download_url : t -> Uri.t
73
+
val upload_url : t -> Uri.t
74
+
val event_source_url : t -> Uri.t
75
+
val state : t -> string
76
+
77
+
val v :
78
+
capabilities:server_capability_value string_map ->
79
+
accounts:Account.t id_map ->
80
+
primary_accounts:id string_map ->
81
+
username:string ->
82
+
api_url:Uri.t ->
83
+
download_url:Uri.t ->
84
+
upload_url:Uri.t ->
85
+
event_source_url:Uri.t ->
86
+
state:string ->
87
+
unit ->
88
+
t
89
+
end
90
+
91
+
(** Function to perform service autodiscovery.
92
+
Returns the session URL if found.
93
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-2.2> RFC 8620, Section 2.2 *)
94
+
val discover : domain:string -> Uri.t option
95
+
96
+
(** Function to fetch the session object from a given URL.
97
+
Requires authentication handling (details TBD/outside this signature). *)
98
+
val get_session : url:Uri.t -> Session.t
+38
jmap/jmap_types.mli
+38
jmap/jmap_types.mli
···
1
+
(** Basic JMAP types as defined in RFC 8620. *)
2
+
3
+
(** The Id data type.
4
+
A string of 1 to 255 octets, using URL-safe base64 characters.
5
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-1.2> RFC 8620, Section 1.2 *)
6
+
type id = string
7
+
8
+
(** The Int data type.
9
+
An integer in the range [-2^53+1, 2^53-1]. Represented as OCaml's standard [int].
10
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-1.3> RFC 8620, Section 1.3 *)
11
+
type jint = int
12
+
13
+
(** The UnsignedInt data type.
14
+
An integer in the range [0, 2^53-1]. Represented as OCaml's standard [int].
15
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-1.3> RFC 8620, Section 1.3 *)
16
+
type uint = int
17
+
18
+
(** The Date data type.
19
+
A string in RFC 3339 "date-time" format.
20
+
Represented as a float using Unix time.
21
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-1.4> RFC 8620, Section 1.4 *)
22
+
type date = float
23
+
24
+
(** The UTCDate data type.
25
+
A string in RFC 3339 "date-time" format, restricted to UTC (Z timezone).
26
+
Represented as a float using Unix time.
27
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-1.4> RFC 8620, Section 1.4 *)
28
+
type utc_date = float
29
+
30
+
(** Represents a JSON object used as a map String -> V. *)
31
+
type 'v string_map = (string, 'v) Hashtbl.t
32
+
33
+
(** Represents a JSON object used as a map Id -> V. *)
34
+
type 'v id_map = (id, 'v) Hashtbl.t
35
+
36
+
(** Represents a JSON Pointer path with JMAP extensions.
37
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.7> RFC 8620, Section 3.7 *)
38
+
type json_pointer = string
+80
jmap/jmap_wire.mli
+80
jmap/jmap_wire.mli
···
1
+
(** JMAP Wire Protocol Structures (Request/Response). *)
2
+
3
+
open Jmap_types
4
+
5
+
(** An invocation tuple within a request or response.
6
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.2> RFC 8620, Section 3.2 *)
7
+
module Invocation : sig
8
+
type t
9
+
10
+
val method_name : t -> string
11
+
val arguments : t -> Yojson.Safe.t
12
+
val method_call_id : t -> string
13
+
14
+
val v :
15
+
?arguments:Yojson.Safe.t ->
16
+
method_name:string ->
17
+
method_call_id:string ->
18
+
unit ->
19
+
t
20
+
end
21
+
22
+
(** Method error type with context.
23
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.6.2> RFC 8620, Section 3.6.2 *)
24
+
type method_error = Jmap_error.Method_error.t * string
25
+
26
+
(** A response invocation part, which can be a standard response or an error.
27
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.4> RFC 8620, Section 3.4
28
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.6.2> RFC 8620, Section 3.6.2 *)
29
+
type response_invocation = (Invocation.t, method_error) result
30
+
31
+
(** A reference to a previous method call's result.
32
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.7> RFC 8620, Section 3.7 *)
33
+
module Result_reference : sig
34
+
type t
35
+
36
+
val result_of : t -> string
37
+
val name : t -> string
38
+
val path : t -> json_pointer
39
+
40
+
val v :
41
+
result_of:string ->
42
+
name:string ->
43
+
path:json_pointer ->
44
+
unit ->
45
+
t
46
+
end
47
+
48
+
(** The Request object.
49
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.3> RFC 8620, Section 3.3 *)
50
+
module Request : sig
51
+
type t
52
+
53
+
val using : t -> string list
54
+
val method_calls : t -> Invocation.t list
55
+
val created_ids : t -> id id_map option
56
+
57
+
val v :
58
+
using:string list ->
59
+
method_calls:Invocation.t list ->
60
+
?created_ids:id id_map ->
61
+
unit ->
62
+
t
63
+
end
64
+
65
+
(** The Response object.
66
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-3.4> RFC 8620, Section 3.4 *)
67
+
module Response : sig
68
+
type t
69
+
70
+
val method_responses : t -> response_invocation list
71
+
val created_ids : t -> id id_map option
72
+
val session_state : t -> string
73
+
74
+
val v :
75
+
method_responses:response_invocation list ->
76
+
?created_ids:id id_map ->
77
+
session_state:string ->
78
+
unit ->
79
+
t
80
+
end
+15
jmap-email/dune
+15
jmap-email/dune
···
1
+
(library
2
+
(name jmap_email)
3
+
(public_name jmap-email)
4
+
(libraries jmap yojson uri)
5
+
(modules_without_implementation jmap_email jmap_email_types jmap_identity
6
+
jmap_mailbox jmap_search_snippet jmap_submission jmap_thread jmap_vacation)
7
+
(modules
8
+
jmap_email
9
+
jmap_email_types
10
+
jmap_mailbox
11
+
jmap_thread
12
+
jmap_search_snippet
13
+
jmap_identity
14
+
jmap_submission
15
+
jmap_vacation))
+503
jmap-email/jmap_email.mli
+503
jmap-email/jmap_email.mli
···
1
+
(** JMAP Mail Extension Library (RFC 8621).
2
+
3
+
This library extends the core JMAP protocol with email-specific
4
+
functionality as defined in RFC 8621. It provides types and signatures
5
+
for interacting with JMAP Mail data types: Mailbox, Thread, Email,
6
+
SearchSnippet, Identity, EmailSubmission, and VacationResponse.
7
+
8
+
Requires the core Jmap library and Jmap_unix library for network operations.
9
+
10
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html> RFC 8621: JMAP for Mail
11
+
*)
12
+
13
+
open Jmap.Types
14
+
15
+
(** {1 Core Types} *)
16
+
module Types = Jmap_email_types
17
+
18
+
(** {1 Mailbox}
19
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-2> RFC 8621, Section 2 *)
20
+
module Mailbox = Jmap_mailbox
21
+
22
+
(** {1 Thread}
23
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-3> RFC 8621, Section 3 *)
24
+
module Thread = Jmap_thread
25
+
26
+
(** {1 Search Snippet}
27
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-5> RFC 8621, Section 5 *)
28
+
module SearchSnippet = Jmap_search_snippet
29
+
30
+
(** {1 Identity}
31
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-6> RFC 8621, Section 6 *)
32
+
module Identity = Jmap_identity
33
+
34
+
(** {1 Email Submission}
35
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7> RFC 8621, Section 7 *)
36
+
module Submission = Jmap_submission
37
+
38
+
(** {1 Vacation Response}
39
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-8> RFC 8621, Section 8 *)
40
+
module Vacation = Jmap_vacation
41
+
42
+
(** {1 Example Usage}
43
+
44
+
The following example demonstrates using the JMAP Email library to fetch unread emails
45
+
from a specific sender.
46
+
47
+
{[
48
+
(* OCaml 5.1 required for Lwt let operators *)
49
+
open Lwt.Syntax
50
+
open Jmap
51
+
open Jmap.Types
52
+
open Jmap.Wire
53
+
open Jmap.Methods
54
+
open Jmap_email
55
+
open Jmap.Unix
56
+
57
+
let list_unread_from_sender ctx session sender_email =
58
+
(* Find the primary mail account *)
59
+
let primary_mail_account_id =
60
+
Hashtbl.find session.primary_accounts capability_mail
61
+
in
62
+
(* Construct the filter *)
63
+
let filter : filter =
64
+
Filter_operator (Filter_operator.v
65
+
~operator:`AND
66
+
~conditions:[
67
+
Filter_condition (Yojson.Safe.to_basic (`Assoc [
68
+
("from", `String sender_email);
69
+
]));
70
+
Filter_condition (Yojson.Safe.to_basic (`Assoc [
71
+
("hasKeyword", `String keyword_seen);
72
+
("value", `Bool false);
73
+
]));
74
+
]
75
+
())
76
+
in
77
+
(* Prepare the Email/query invocation *)
78
+
let query_args = Query_args.v
79
+
~account_id:primary_mail_account_id
80
+
~filter
81
+
~sort:[
82
+
Comparator.v
83
+
~property:"receivedAt"
84
+
~is_ascending:false
85
+
()
86
+
]
87
+
~position:0
88
+
~limit:20 (* Get latest 20 *)
89
+
~calculate_total:false
90
+
~collapse_threads:false
91
+
()
92
+
in
93
+
let query_invocation = Invocation.v
94
+
~method_name:"Email/query"
95
+
~arguments:(* Yojson conversion of query_args needed here *)
96
+
~method_call_id:"q1"
97
+
()
98
+
in
99
+
100
+
(* Prepare the Email/get invocation using a back-reference *)
101
+
let get_args = Get_args.v
102
+
~account_id:primary_mail_account_id
103
+
~properties:["id"; "subject"; "receivedAt"; "from"]
104
+
()
105
+
in
106
+
let get_invocation = Invocation.v
107
+
~method_name:"Email/get"
108
+
~arguments:(* Yojson conversion of get_args, with ids replaced by a ResultReference to q1 needed here *)
109
+
~method_call_id:"g1"
110
+
()
111
+
in
112
+
113
+
(* Prepare the JMAP request *)
114
+
let request = Request.v
115
+
~using:[ Jmap.capability_core; capability_mail ]
116
+
~method_calls:[ query_invocation; get_invocation ]
117
+
()
118
+
in
119
+
120
+
(* Send the request *)
121
+
let* response = Jmap.Unix.request ctx request in
122
+
123
+
(* Process the response (extract Email/get results) *)
124
+
(* ... Omitted: find the Email/get response in response.method_responses ... *)
125
+
Lwt.return_unit
126
+
]}
127
+
*)
128
+
129
+
(** Capability URI for JMAP Mail.
130
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-1.3.1> RFC 8621, Section 1.3.1 *)
131
+
val capability_mail : string
132
+
133
+
(** Capability URI for JMAP Submission.
134
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-1.3.2> RFC 8621, Section 1.3.2 *)
135
+
val capability_submission : string
136
+
137
+
(** Capability URI for JMAP Vacation Response.
138
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-1.3.3> RFC 8621, Section 1.3.3 *)
139
+
val capability_vacationresponse : string
140
+
141
+
(** Type name for EmailDelivery push notifications.
142
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-1.5> RFC 8621, Section 1.5 *)
143
+
val push_event_type_email_delivery : string
144
+
145
+
(** Keyword string constants for JMAP email flags.
146
+
Provides easy access to standardized keyword string values.
147
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.1.1> RFC 8621, Section 4.1.1 *)
148
+
module Keyword : sig
149
+
(** {1 IMAP System Flags} *)
150
+
151
+
(** "$draft": The Email is a draft the user is composing *)
152
+
val draft : string
153
+
154
+
(** "$seen": The Email has been read *)
155
+
val seen : string
156
+
157
+
(** "$flagged": The Email has been flagged for urgent/special attention *)
158
+
val flagged : string
159
+
160
+
(** "$answered": The Email has been replied to *)
161
+
val answered : string
162
+
163
+
(** {1 Common Extension Keywords} *)
164
+
165
+
(** "$forwarded": The Email has been forwarded *)
166
+
val forwarded : string
167
+
168
+
(** "$phishing": The Email is likely to be phishing *)
169
+
val phishing : string
170
+
171
+
(** "$junk": The Email is spam/junk *)
172
+
val junk : string
173
+
174
+
(** "$notjunk": The Email is explicitly marked as not spam/junk *)
175
+
val notjunk : string
176
+
177
+
(** {1 Apple Mail and Vendor Extensions}
178
+
@see <https://datatracker.ietf.org/doc/draft-ietf-mailmaint-messageflag-mailboxattribute/> *)
179
+
180
+
(** "$notify": Request to be notified when this email gets a reply *)
181
+
val notify : string
182
+
183
+
(** "$muted": Email is muted (notifications disabled) *)
184
+
val muted : string
185
+
186
+
(** "$followed": Email thread is followed for notifications *)
187
+
val followed : string
188
+
189
+
(** "$memo": Email has a memo/note associated with it *)
190
+
val memo : string
191
+
192
+
(** "$hasmemo": Email has a memo, annotation or note property *)
193
+
val hasmemo : string
194
+
195
+
(** "$autosent": Email was generated or sent automatically *)
196
+
val autosent : string
197
+
198
+
(** "$unsubscribed": User has unsubscribed from this sender *)
199
+
val unsubscribed : string
200
+
201
+
(** "$canunsubscribe": Email contains unsubscribe information *)
202
+
val canunsubscribe : string
203
+
204
+
(** "$imported": Email was imported from another system *)
205
+
val imported : string
206
+
207
+
(** "$istrusted": Email is from a trusted/verified sender *)
208
+
val istrusted : string
209
+
210
+
(** "$maskedemail": Email is to/from a masked/anonymous address *)
211
+
val maskedemail : string
212
+
213
+
(** "$new": Email was recently delivered *)
214
+
val new_mail : string
215
+
216
+
(** {1 Apple Mail Color Flag Bits} *)
217
+
218
+
(** "$MailFlagBit0": First color flag bit (red) *)
219
+
val mailflagbit0 : string
220
+
221
+
(** "$MailFlagBit1": Second color flag bit (orange) *)
222
+
val mailflagbit1 : string
223
+
224
+
(** "$MailFlagBit2": Third color flag bit (yellow) *)
225
+
val mailflagbit2 : string
226
+
227
+
(** {1 Color Flag Combinations} *)
228
+
229
+
(** Get color flag bit values for a specific color
230
+
@return A list of flags to set to create the requested color *)
231
+
val color_flags : [`Red | `Orange | `Yellow | `Green | `Blue | `Purple | `Gray] -> string list
232
+
233
+
(** Check if a string is a valid keyword according to the RFC
234
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.1.1> RFC 8621, Section 4.1.1 *)
235
+
val is_valid : string -> bool
236
+
end
237
+
238
+
(** For backward compatibility - DEPRECATED, use Keyword.draft instead *)
239
+
val keyword_draft : string
240
+
241
+
(** For backward compatibility - DEPRECATED, use Keyword.seen instead *)
242
+
val keyword_seen : string
243
+
244
+
(** For backward compatibility - DEPRECATED, use Keyword.flagged instead *)
245
+
val keyword_flagged : string
246
+
247
+
(** For backward compatibility - DEPRECATED, use Keyword.answered instead *)
248
+
val keyword_answered : string
249
+
250
+
(** For backward compatibility - DEPRECATED, use Keyword.forwarded instead *)
251
+
val keyword_forwarded : string
252
+
253
+
(** For backward compatibility - DEPRECATED, use Keyword.phishing instead *)
254
+
val keyword_phishing : string
255
+
256
+
(** For backward compatibility - DEPRECATED, use Keyword.junk instead *)
257
+
val keyword_junk : string
258
+
259
+
(** For backward compatibility - DEPRECATED, use Keyword.notjunk instead *)
260
+
val keyword_notjunk : string
261
+
262
+
(** Email keyword operations.
263
+
Functions to manipulate and update email keywords/flags. *)
264
+
module Keyword_ops : sig
265
+
(** Add a keyword/flag to an email *)
266
+
val add : Types.Email.t -> Types.Keywords.keyword -> Types.Email.t
267
+
268
+
(** Remove a keyword/flag from an email *)
269
+
val remove : Types.Email.t -> Types.Keywords.keyword -> Types.Email.t
270
+
271
+
(** {1 System Flag Operations} *)
272
+
273
+
(** Mark an email as seen/read *)
274
+
val mark_as_seen : Types.Email.t -> Types.Email.t
275
+
276
+
(** Mark an email as unseen/unread *)
277
+
val mark_as_unseen : Types.Email.t -> Types.Email.t
278
+
279
+
(** Mark an email as flagged/important *)
280
+
val mark_as_flagged : Types.Email.t -> Types.Email.t
281
+
282
+
(** Remove flagged/important marking from an email *)
283
+
val unmark_flagged : Types.Email.t -> Types.Email.t
284
+
285
+
(** Mark an email as a draft *)
286
+
val mark_as_draft : Types.Email.t -> Types.Email.t
287
+
288
+
(** Remove draft marking from an email *)
289
+
val unmark_draft : Types.Email.t -> Types.Email.t
290
+
291
+
(** Mark an email as answered/replied *)
292
+
val mark_as_answered : Types.Email.t -> Types.Email.t
293
+
294
+
(** Remove answered/replied marking from an email *)
295
+
val unmark_answered : Types.Email.t -> Types.Email.t
296
+
297
+
(** Mark an email as forwarded *)
298
+
val mark_as_forwarded : Types.Email.t -> Types.Email.t
299
+
300
+
(** Mark an email as spam/junk *)
301
+
val mark_as_junk : Types.Email.t -> Types.Email.t
302
+
303
+
(** Mark an email as not spam/junk *)
304
+
val mark_as_not_junk : Types.Email.t -> Types.Email.t
305
+
306
+
(** Mark an email as phishing *)
307
+
val mark_as_phishing : Types.Email.t -> Types.Email.t
308
+
309
+
(** {1 Extension Flag Operations} *)
310
+
311
+
(** Mark an email for notification when replied to *)
312
+
val mark_as_notify : Types.Email.t -> Types.Email.t
313
+
314
+
(** Remove notification flag from an email *)
315
+
val unmark_notify : Types.Email.t -> Types.Email.t
316
+
317
+
(** Mark an email as muted (no notifications) *)
318
+
val mark_as_muted : Types.Email.t -> Types.Email.t
319
+
320
+
(** Unmute an email (allow notifications) *)
321
+
val unmark_muted : Types.Email.t -> Types.Email.t
322
+
323
+
(** Mark an email thread as followed for notifications *)
324
+
val mark_as_followed : Types.Email.t -> Types.Email.t
325
+
326
+
(** Remove followed status from an email thread *)
327
+
val unmark_followed : Types.Email.t -> Types.Email.t
328
+
329
+
(** Mark an email with a memo *)
330
+
val mark_as_memo : Types.Email.t -> Types.Email.t
331
+
332
+
(** Mark an email with the hasmemo flag *)
333
+
val mark_as_hasmemo : Types.Email.t -> Types.Email.t
334
+
335
+
(** Mark an email as automatically sent *)
336
+
val mark_as_autosent : Types.Email.t -> Types.Email.t
337
+
338
+
(** Mark an email as being from an unsubscribed sender *)
339
+
val mark_as_unsubscribed : Types.Email.t -> Types.Email.t
340
+
341
+
(** Mark an email as having unsubscribe capability *)
342
+
val mark_as_canunsubscribe : Types.Email.t -> Types.Email.t
343
+
344
+
(** Mark an email as imported from another system *)
345
+
val mark_as_imported : Types.Email.t -> Types.Email.t
346
+
347
+
(** Mark an email as from a trusted/verified sender *)
348
+
val mark_as_trusted : Types.Email.t -> Types.Email.t
349
+
350
+
(** Mark an email as having masked/anonymous address *)
351
+
val mark_as_maskedemail : Types.Email.t -> Types.Email.t
352
+
353
+
(** Mark an email as new/recent *)
354
+
val mark_as_new : Types.Email.t -> Types.Email.t
355
+
356
+
(** Remove new/recent flag from an email *)
357
+
val unmark_new : Types.Email.t -> Types.Email.t
358
+
359
+
(** {1 Color Flag Operations} *)
360
+
361
+
(** Set color flag bits on an email *)
362
+
val set_color_flags : Types.Email.t -> red:bool -> orange:bool -> yellow:bool -> Types.Email.t
363
+
364
+
(** Mark an email with a predefined color *)
365
+
val mark_as_color : Types.Email.t ->
366
+
[`Red | `Orange | `Yellow | `Green | `Blue | `Purple | `Gray] -> Types.Email.t
367
+
368
+
(** Remove all color flag bits from an email *)
369
+
val clear_color_flags : Types.Email.t -> Types.Email.t
370
+
371
+
(** {1 Custom Flag Operations} *)
372
+
373
+
(** Add a custom keyword to an email *)
374
+
val add_custom : Types.Email.t -> string -> Types.Email.t
375
+
376
+
(** Remove a custom keyword from an email *)
377
+
val remove_custom : Types.Email.t -> string -> Types.Email.t
378
+
379
+
(** {1 Patch Object Creation} *)
380
+
381
+
(** Create a patch object to add a keyword to emails *)
382
+
val add_keyword_patch : Types.Keywords.keyword -> Jmap.Methods.patch_object
383
+
384
+
(** Create a patch object to remove a keyword from emails *)
385
+
val remove_keyword_patch : Types.Keywords.keyword -> Jmap.Methods.patch_object
386
+
387
+
(** Create a patch object to mark emails as seen/read *)
388
+
val mark_seen_patch : unit -> Jmap.Methods.patch_object
389
+
390
+
(** Create a patch object to mark emails as unseen/unread *)
391
+
val mark_unseen_patch : unit -> Jmap.Methods.patch_object
392
+
393
+
(** Create a patch object to set a specific color on emails *)
394
+
val set_color_patch : [`Red | `Orange | `Yellow | `Green | `Blue | `Purple | `Gray] ->
395
+
Jmap.Methods.patch_object
396
+
end
397
+
398
+
(** Conversion functions for JMAP/IMAP compatibility *)
399
+
module Conversion : sig
400
+
(** {1 Keyword/Flag Conversion} *)
401
+
402
+
(** Convert a JMAP keyword variant to IMAP flag *)
403
+
val keyword_to_imap_flag : Types.Keywords.keyword -> string
404
+
405
+
(** Convert an IMAP flag to JMAP keyword variant *)
406
+
val imap_flag_to_keyword : string -> Types.Keywords.keyword
407
+
408
+
(** Check if a string is valid for use as a custom keyword according to RFC 8621.
409
+
@deprecated Use Keyword.is_valid instead. *)
410
+
val is_valid_custom_keyword : string -> bool
411
+
412
+
(** Get the JMAP protocol string representation of a keyword *)
413
+
val keyword_to_string : Types.Keywords.keyword -> string
414
+
415
+
(** Parse a JMAP protocol string into a keyword variant *)
416
+
val string_to_keyword : string -> Types.Keywords.keyword
417
+
418
+
(** {1 Color Conversion} *)
419
+
420
+
(** Convert a color name to the corresponding flag bit combination *)
421
+
val color_to_flags : [`Red | `Orange | `Yellow | `Green | `Blue | `Purple | `Gray] ->
422
+
Types.Keywords.keyword list
423
+
424
+
(** Try to determine a color from a set of keywords *)
425
+
val keywords_to_color : Types.Keywords.t ->
426
+
[`Red | `Orange | `Yellow | `Green | `Blue | `Purple | `Gray | `None] option
427
+
end
428
+
429
+
(** {1 Helper Functions} *)
430
+
431
+
(** Email query filter helpers *)
432
+
module Email_filter : sig
433
+
(** Create a filter to find messages in a specific mailbox *)
434
+
val in_mailbox : id -> Jmap.Methods.Filter.t
435
+
436
+
(** Create a filter to find messages with a specific keyword/flag *)
437
+
val has_keyword : Types.Keywords.keyword -> Jmap.Methods.Filter.t
438
+
439
+
(** Create a filter to find messages without a specific keyword/flag *)
440
+
val not_has_keyword : Types.Keywords.keyword -> Jmap.Methods.Filter.t
441
+
442
+
(** Create a filter to find unread messages *)
443
+
val unread : unit -> Jmap.Methods.Filter.t
444
+
445
+
(** Create a filter to find messages with a specific subject *)
446
+
val subject : string -> Jmap.Methods.Filter.t
447
+
448
+
(** Create a filter to find messages from a specific sender *)
449
+
val from : string -> Jmap.Methods.Filter.t
450
+
451
+
(** Create a filter to find messages sent to a specific recipient *)
452
+
val to_ : string -> Jmap.Methods.Filter.t
453
+
454
+
(** Create a filter to find messages with attachments *)
455
+
val has_attachment : unit -> Jmap.Methods.Filter.t
456
+
457
+
(** Create a filter to find messages received before a date *)
458
+
val before : date -> Jmap.Methods.Filter.t
459
+
460
+
(** Create a filter to find messages received after a date *)
461
+
val after : date -> Jmap.Methods.Filter.t
462
+
463
+
(** Create a filter to find messages with size larger than the given bytes *)
464
+
val larger_than : uint -> Jmap.Methods.Filter.t
465
+
466
+
(** Create a filter to find messages with size smaller than the given bytes *)
467
+
val smaller_than : uint -> Jmap.Methods.Filter.t
468
+
end
469
+
470
+
(** Common email sorting comparators *)
471
+
module Email_sort : sig
472
+
(** Sort by received date (most recent first) *)
473
+
val received_newest_first : unit -> Jmap.Methods.Comparator.t
474
+
475
+
(** Sort by received date (oldest first) *)
476
+
val received_oldest_first : unit -> Jmap.Methods.Comparator.t
477
+
478
+
(** Sort by sent date (most recent first) *)
479
+
val sent_newest_first : unit -> Jmap.Methods.Comparator.t
480
+
481
+
(** Sort by sent date (oldest first) *)
482
+
val sent_oldest_first : unit -> Jmap.Methods.Comparator.t
483
+
484
+
(** Sort by subject (A-Z) *)
485
+
val subject_asc : unit -> Jmap.Methods.Comparator.t
486
+
487
+
(** Sort by subject (Z-A) *)
488
+
val subject_desc : unit -> Jmap.Methods.Comparator.t
489
+
490
+
(** Sort by size (largest first) *)
491
+
val size_largest_first : unit -> Jmap.Methods.Comparator.t
492
+
493
+
(** Sort by size (smallest first) *)
494
+
val size_smallest_first : unit -> Jmap.Methods.Comparator.t
495
+
496
+
(** Sort by from address (A-Z) *)
497
+
val from_asc : unit -> Jmap.Methods.Comparator.t
498
+
499
+
(** Sort by from address (Z-A) *)
500
+
val from_desc : unit -> Jmap.Methods.Comparator.t
501
+
end
502
+
503
+
(** High-level email operations are implemented in the Jmap.Unix.Email module *)
+519
jmap-email/jmap_email_types.mli
+519
jmap-email/jmap_email_types.mli
···
1
+
(** Common types for JMAP Mail (RFC 8621). *)
2
+
3
+
open Jmap.Types
4
+
5
+
(** Represents an email address with an optional name.
6
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.1.2.3> RFC 8621, Section 4.1.2.3 *)
7
+
module Email_address : sig
8
+
type t
9
+
10
+
(** Get the display name for the address (if any) *)
11
+
val name : t -> string option
12
+
13
+
(** Get the email address *)
14
+
val email : t -> string
15
+
16
+
(** Create a new email address *)
17
+
val v :
18
+
?name:string ->
19
+
email:string ->
20
+
unit -> t
21
+
end
22
+
23
+
(** Represents a group of email addresses.
24
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.1.2.4> RFC 8621, Section 4.1.2.4 *)
25
+
module Email_address_group : sig
26
+
type t
27
+
28
+
(** Get the name of the group (if any) *)
29
+
val name : t -> string option
30
+
31
+
(** Get the list of addresses in the group *)
32
+
val addresses : t -> Email_address.t list
33
+
34
+
(** Create a new address group *)
35
+
val v :
36
+
?name:string ->
37
+
addresses:Email_address.t list ->
38
+
unit -> t
39
+
end
40
+
41
+
(** Represents a header field (name and raw value).
42
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.1.3> RFC 8621, Section 4.1.3 *)
43
+
module Email_header : sig
44
+
type t
45
+
46
+
(** Get the header field name *)
47
+
val name : t -> string
48
+
49
+
(** Get the raw header field value *)
50
+
val value : t -> string
51
+
52
+
(** Create a new header field *)
53
+
val v :
54
+
name:string ->
55
+
value:string ->
56
+
unit -> t
57
+
end
58
+
59
+
(** Represents a body part within an Email's MIME structure.
60
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.1.4> RFC 8621, Section 4.1.4 *)
61
+
module Email_body_part : sig
62
+
type t
63
+
64
+
(** Get the part ID (null only for multipart types) *)
65
+
val id : t -> string option
66
+
67
+
(** Get the blob ID (null only for multipart types) *)
68
+
val blob_id : t -> id option
69
+
70
+
(** Get the size of the part in bytes *)
71
+
val size : t -> uint
72
+
73
+
(** Get the list of headers for this part *)
74
+
val headers : t -> Email_header.t list
75
+
76
+
(** Get the filename (if any) *)
77
+
val name : t -> string option
78
+
79
+
(** Get the MIME type *)
80
+
val mime_type : t -> string
81
+
82
+
(** Get the charset (if any) *)
83
+
val charset : t -> string option
84
+
85
+
(** Get the content disposition (if any) *)
86
+
val disposition : t -> string option
87
+
88
+
(** Get the content ID (if any) *)
89
+
val cid : t -> string option
90
+
91
+
(** Get the list of languages (if any) *)
92
+
val language : t -> string list option
93
+
94
+
(** Get the content location (if any) *)
95
+
val location : t -> string option
96
+
97
+
(** Get the sub-parts (only for multipart types) *)
98
+
val sub_parts : t -> t list option
99
+
100
+
(** Get any other requested headers (header properties) *)
101
+
val other_headers : t -> Yojson.Safe.t string_map
102
+
103
+
(** Create a new body part *)
104
+
val v :
105
+
?id:string ->
106
+
?blob_id:id ->
107
+
size:uint ->
108
+
headers:Email_header.t list ->
109
+
?name:string ->
110
+
mime_type:string ->
111
+
?charset:string ->
112
+
?disposition:string ->
113
+
?cid:string ->
114
+
?language:string list ->
115
+
?location:string ->
116
+
?sub_parts:t list ->
117
+
?other_headers:Yojson.Safe.t string_map ->
118
+
unit -> t
119
+
end
120
+
121
+
(** Represents the decoded value of a text body part.
122
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.1.4> RFC 8621, Section 4.1.4 *)
123
+
module Email_body_value : sig
124
+
type t
125
+
126
+
(** Get the decoded text content *)
127
+
val value : t -> string
128
+
129
+
(** Check if there was an encoding problem *)
130
+
val has_encoding_problem : t -> bool
131
+
132
+
(** Check if the content was truncated *)
133
+
val is_truncated : t -> bool
134
+
135
+
(** Create a new body value *)
136
+
val v :
137
+
value:string ->
138
+
?encoding_problem:bool ->
139
+
?truncated:bool ->
140
+
unit -> t
141
+
end
142
+
143
+
(** Type to represent email message flags/keywords.
144
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.1.1> RFC 8621, Section 4.1.1 *)
145
+
module Keywords : sig
146
+
(** Represents different types of JMAP keywords *)
147
+
type keyword =
148
+
| Draft (** "$draft": The Email is a draft the user is composing *)
149
+
| Seen (** "$seen": The Email has been read *)
150
+
| Flagged (** "$flagged": The Email has been flagged for urgent/special attention *)
151
+
| Answered (** "$answered": The Email has been replied to *)
152
+
153
+
(* Common extension keywords from RFC 5788 *)
154
+
| Forwarded (** "$forwarded": The Email has been forwarded *)
155
+
| Phishing (** "$phishing": The Email is likely to be phishing *)
156
+
| Junk (** "$junk": The Email is spam/junk *)
157
+
| NotJunk (** "$notjunk": The Email is explicitly marked as not spam/junk *)
158
+
159
+
(* Apple Mail and other vendor extension keywords from draft-ietf-mailmaint-messageflag-mailboxattribute *)
160
+
| Notify (** "$notify": Request to be notified when this email gets a reply *)
161
+
| Muted (** "$muted": Email is muted (notifications disabled) *)
162
+
| Followed (** "$followed": Email thread is followed for notifications *)
163
+
| Memo (** "$memo": Email has a memo/note associated with it *)
164
+
| HasMemo (** "$hasmemo": Email has a memo, annotation or note property *)
165
+
| Autosent (** "$autosent": Email was generated or sent automatically *)
166
+
| Unsubscribed (** "$unsubscribed": User has unsubscribed from this sender *)
167
+
| CanUnsubscribe (** "$canunsubscribe": Email contains unsubscribe information *)
168
+
| Imported (** "$imported": Email was imported from another system *)
169
+
| IsTrusted (** "$istrusted": Email is from a trusted/verified sender *)
170
+
| MaskedEmail (** "$maskedemail": Email is to/from a masked/anonymous address *)
171
+
| New (** "$new": Email was recently delivered *)
172
+
173
+
(* Apple Mail flag colors (color bit flags) *)
174
+
| MailFlagBit0 (** "$MailFlagBit0": First color flag bit (red) *)
175
+
| MailFlagBit1 (** "$MailFlagBit1": Second color flag bit (orange) *)
176
+
| MailFlagBit2 (** "$MailFlagBit2": Third color flag bit (yellow) *)
177
+
| Custom of string (** Arbitrary user-defined keyword *)
178
+
179
+
(** A set of keywords applied to an email *)
180
+
type t = keyword list
181
+
182
+
(** Check if an email has the draft flag *)
183
+
val is_draft : t -> bool
184
+
185
+
(** Check if an email has been read *)
186
+
val is_seen : t -> bool
187
+
188
+
(** Check if an email has neither been read nor is a draft *)
189
+
val is_unread : t -> bool
190
+
191
+
(** Check if an email has been flagged *)
192
+
val is_flagged : t -> bool
193
+
194
+
(** Check if an email has been replied to *)
195
+
val is_answered : t -> bool
196
+
197
+
(** Check if an email has been forwarded *)
198
+
val is_forwarded : t -> bool
199
+
200
+
(** Check if an email is marked as likely phishing *)
201
+
val is_phishing : t -> bool
202
+
203
+
(** Check if an email is marked as junk/spam *)
204
+
val is_junk : t -> bool
205
+
206
+
(** Check if an email is explicitly marked as not junk/spam *)
207
+
val is_not_junk : t -> bool
208
+
209
+
(** Check if a specific custom keyword is set *)
210
+
val has_keyword : t -> string -> bool
211
+
212
+
(** Get a list of all custom keywords (excluding system keywords) *)
213
+
val custom_keywords : t -> string list
214
+
215
+
(** Add a keyword to the set *)
216
+
val add : t -> keyword -> t
217
+
218
+
(** Remove a keyword from the set *)
219
+
val remove : t -> keyword -> t
220
+
221
+
(** Create an empty keyword set *)
222
+
val empty : unit -> t
223
+
224
+
(** Create a new keyword set with the specified keywords *)
225
+
val of_list : keyword list -> t
226
+
227
+
(** Get the string representation of a keyword as used in the JMAP protocol *)
228
+
val to_string : keyword -> string
229
+
230
+
(** Parse a string into a keyword *)
231
+
val of_string : string -> keyword
232
+
233
+
(** Convert keyword set to string map representation as used in JMAP *)
234
+
val to_map : t -> bool string_map
235
+
end
236
+
237
+
(** Email properties enum.
238
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.1> RFC 8621, Section 4.1 *)
239
+
type email_property =
240
+
| Id (** The id of the email *)
241
+
| BlobId (** The id of the blob containing the raw message *)
242
+
| ThreadId (** The id of the thread this email belongs to *)
243
+
| MailboxIds (** The mailboxes this email belongs to *)
244
+
| Keywords (** The keywords/flags for this email *)
245
+
| Size (** Size of the message in bytes *)
246
+
| ReceivedAt (** When the message was received by the server *)
247
+
| MessageId (** Value of the Message-ID header *)
248
+
| InReplyTo (** Value of the In-Reply-To header *)
249
+
| References (** Value of the References header *)
250
+
| Sender (** Value of the Sender header *)
251
+
| From (** Value of the From header *)
252
+
| To (** Value of the To header *)
253
+
| Cc (** Value of the Cc header *)
254
+
| Bcc (** Value of the Bcc header *)
255
+
| ReplyTo (** Value of the Reply-To header *)
256
+
| Subject (** Value of the Subject header *)
257
+
| SentAt (** Value of the Date header *)
258
+
| HasAttachment (** Whether the email has attachments *)
259
+
| Preview (** Preview text of the email *)
260
+
| BodyStructure (** MIME structure of the email *)
261
+
| BodyValues (** Decoded body part values *)
262
+
| TextBody (** Text body parts *)
263
+
| HtmlBody (** HTML body parts *)
264
+
| Attachments (** Attachments *)
265
+
| Header of string (** Specific header *)
266
+
| Other of string (** Extension property *)
267
+
268
+
(** Represents an Email object.
269
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.1> RFC 8621, Section 4.1 *)
270
+
module Email : sig
271
+
(** Email type *)
272
+
type t
273
+
274
+
(** ID of the email *)
275
+
val id : t -> id option
276
+
277
+
(** ID of the blob containing the raw message *)
278
+
val blob_id : t -> id option
279
+
280
+
(** ID of the thread this email belongs to *)
281
+
val thread_id : t -> id option
282
+
283
+
(** The set of mailbox IDs this email belongs to *)
284
+
val mailbox_ids : t -> bool id_map option
285
+
286
+
(** The set of keywords/flags for this email *)
287
+
val keywords : t -> Keywords.t option
288
+
289
+
(** Size of the message in bytes *)
290
+
val size : t -> uint option
291
+
292
+
(** When the message was received by the server *)
293
+
val received_at : t -> date option
294
+
295
+
(** Subject of the email (if requested) *)
296
+
val subject : t -> string option
297
+
298
+
(** Preview text of the email (if requested) *)
299
+
val preview : t -> string option
300
+
301
+
(** From addresses (if requested) *)
302
+
val from : t -> Email_address.t list option
303
+
304
+
(** To addresses (if requested) *)
305
+
val to_ : t -> Email_address.t list option
306
+
307
+
(** CC addresses (if requested) *)
308
+
val cc : t -> Email_address.t list option
309
+
310
+
(** Message ID values (if requested) *)
311
+
val message_id : t -> string list option
312
+
313
+
(** Get whether the email has attachments (if requested) *)
314
+
val has_attachment : t -> bool option
315
+
316
+
(** Get text body parts (if requested) *)
317
+
val text_body : t -> Email_body_part.t list option
318
+
319
+
(** Get HTML body parts (if requested) *)
320
+
val html_body : t -> Email_body_part.t list option
321
+
322
+
(** Get attachments (if requested) *)
323
+
val attachments : t -> Email_body_part.t list option
324
+
325
+
(** Create a new Email object from a server response or for a new email *)
326
+
val create :
327
+
?id:id ->
328
+
?blob_id:id ->
329
+
?thread_id:id ->
330
+
?mailbox_ids:bool id_map ->
331
+
?keywords:Keywords.t ->
332
+
?size:uint ->
333
+
?received_at:date ->
334
+
?subject:string ->
335
+
?preview:string ->
336
+
?from:Email_address.t list ->
337
+
?to_:Email_address.t list ->
338
+
?cc:Email_address.t list ->
339
+
?message_id:string list ->
340
+
?has_attachment:bool ->
341
+
?text_body:Email_body_part.t list ->
342
+
?html_body:Email_body_part.t list ->
343
+
?attachments:Email_body_part.t list ->
344
+
unit -> t
345
+
346
+
(** Create a patch object for updating email properties *)
347
+
val make_patch :
348
+
?add_keywords:Keywords.t ->
349
+
?remove_keywords:Keywords.t ->
350
+
?add_mailboxes:id list ->
351
+
?remove_mailboxes:id list ->
352
+
unit -> Jmap.Methods.patch_object
353
+
354
+
(** Extract the ID from an email, returning a Result *)
355
+
val get_id : t -> (id, string) result
356
+
357
+
(** Take the ID from an email (fails with an exception if not present) *)
358
+
val take_id : t -> id
359
+
end
360
+
361
+
(** Email/import method arguments and responses.
362
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.8> RFC 8621, Section 4.8 *)
363
+
module Import : sig
364
+
(** Arguments for Email/import method *)
365
+
type args = {
366
+
account_id : id;
367
+
blob_ids : id list;
368
+
mailbox_ids : id id_map;
369
+
keywords : Keywords.t option;
370
+
received_at : date option;
371
+
}
372
+
373
+
(** Create import arguments *)
374
+
val create_args :
375
+
account_id:id ->
376
+
blob_ids:id list ->
377
+
mailbox_ids:id id_map ->
378
+
?keywords:Keywords.t ->
379
+
?received_at:date ->
380
+
unit -> args
381
+
382
+
(** Response for a single imported email *)
383
+
type email_import_result = {
384
+
blob_id : id;
385
+
email : Email.t;
386
+
}
387
+
388
+
(** Create an email import result *)
389
+
val create_result :
390
+
blob_id:id ->
391
+
email:Email.t ->
392
+
unit -> email_import_result
393
+
394
+
(** Response for Email/import method *)
395
+
type response = {
396
+
account_id : id;
397
+
created : email_import_result id_map;
398
+
not_created : Jmap.Error.Set_error.t id_map;
399
+
}
400
+
401
+
(** Create import response *)
402
+
val create_response :
403
+
account_id:id ->
404
+
created:email_import_result id_map ->
405
+
not_created:Jmap.Error.Set_error.t id_map ->
406
+
unit -> response
407
+
end
408
+
409
+
(** Email/parse method arguments and responses.
410
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.9> RFC 8621, Section 4.9 *)
411
+
module Parse : sig
412
+
(** Arguments for Email/parse method *)
413
+
type args = {
414
+
account_id : id;
415
+
blob_ids : id list;
416
+
properties : string list option;
417
+
}
418
+
419
+
(** Create parse arguments *)
420
+
val create_args :
421
+
account_id:id ->
422
+
blob_ids:id list ->
423
+
?properties:string list ->
424
+
unit -> args
425
+
426
+
(** Response for a single parsed email *)
427
+
type email_parse_result = {
428
+
blob_id : id;
429
+
parsed : Email.t;
430
+
}
431
+
432
+
(** Create an email parse result *)
433
+
val create_result :
434
+
blob_id:id ->
435
+
parsed:Email.t ->
436
+
unit -> email_parse_result
437
+
438
+
(** Response for Email/parse method *)
439
+
type response = {
440
+
account_id : id;
441
+
parsed : email_parse_result id_map;
442
+
not_parsed : string id_map;
443
+
}
444
+
445
+
(** Create parse response *)
446
+
val create_response :
447
+
account_id:id ->
448
+
parsed:email_parse_result id_map ->
449
+
not_parsed:string id_map ->
450
+
unit -> response
451
+
end
452
+
453
+
(** Email import options.
454
+
@deprecated Use Import.args instead.
455
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.8> RFC 8621, Section 4.8 *)
456
+
type email_import_options = {
457
+
import_to_mailboxes : id list;
458
+
import_keywords : Keywords.t option;
459
+
import_received_at : date option;
460
+
}
461
+
462
+
(** Email/copy method arguments and responses.
463
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.7> RFC 8621, Section 4.7 *)
464
+
module Copy : sig
465
+
(** Arguments for Email/copy method *)
466
+
type args = {
467
+
from_account_id : id;
468
+
account_id : id;
469
+
create : (id * id id_map) id_map;
470
+
on_success_destroy_original : bool option;
471
+
destroy_from_if_in_state : string option;
472
+
}
473
+
474
+
(** Create copy arguments *)
475
+
val create_args :
476
+
from_account_id:id ->
477
+
account_id:id ->
478
+
create:(id * id id_map) id_map ->
479
+
?on_success_destroy_original:bool ->
480
+
?destroy_from_if_in_state:string ->
481
+
unit -> args
482
+
483
+
(** Response for Email/copy method *)
484
+
type response = {
485
+
from_account_id : id;
486
+
account_id : id;
487
+
created : Email.t id_map option;
488
+
not_created : Jmap.Error.Set_error.t id_map option;
489
+
}
490
+
491
+
(** Create copy response *)
492
+
val create_response :
493
+
from_account_id:id ->
494
+
account_id:id ->
495
+
?created:Email.t id_map ->
496
+
?not_created:Jmap.Error.Set_error.t id_map ->
497
+
unit -> response
498
+
end
499
+
500
+
(** Email copy options.
501
+
@deprecated Use Copy.args instead.
502
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-4.7> RFC 8621, Section 4.7 *)
503
+
type email_copy_options = {
504
+
copy_to_account_id : id;
505
+
copy_to_mailboxes : id list;
506
+
copy_on_success_destroy_original : bool option;
507
+
}
508
+
509
+
(** Convert a property variant to its string representation *)
510
+
val email_property_to_string : email_property -> string
511
+
512
+
(** Parse a string into a property variant *)
513
+
val string_to_email_property : string -> email_property
514
+
515
+
(** Get a list of common properties useful for displaying email lists *)
516
+
val common_email_properties : email_property list
517
+
518
+
(** Get a list of common properties for detailed email view *)
519
+
val detailed_email_properties : email_property list
+114
jmap-email/jmap_identity.mli
+114
jmap-email/jmap_identity.mli
···
1
+
(** JMAP Identity.
2
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-6> RFC 8621, Section 6 *)
3
+
4
+
open Jmap.Types
5
+
open Jmap.Methods
6
+
7
+
(** Identity object.
8
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-6> RFC 8621, Section 6 *)
9
+
type t
10
+
11
+
(** Get the identity ID (immutable, server-set) *)
12
+
val id : t -> id
13
+
14
+
(** Get the display name (defaults to "") *)
15
+
val name : t -> string
16
+
17
+
(** Get the email address (immutable) *)
18
+
val email : t -> string
19
+
20
+
(** Get the reply-to addresses (if any) *)
21
+
val reply_to : t -> Jmap_email_types.Email_address.t list option
22
+
23
+
(** Get the bcc addresses (if any) *)
24
+
val bcc : t -> Jmap_email_types.Email_address.t list option
25
+
26
+
(** Get the plain text signature (defaults to "") *)
27
+
val text_signature : t -> string
28
+
29
+
(** Get the HTML signature (defaults to "") *)
30
+
val html_signature : t -> string
31
+
32
+
(** Check if this identity may be deleted (server-set) *)
33
+
val may_delete : t -> bool
34
+
35
+
(** Create a new identity object *)
36
+
val v :
37
+
id:id ->
38
+
?name:string ->
39
+
email:string ->
40
+
?reply_to:Jmap_email_types.Email_address.t list ->
41
+
?bcc:Jmap_email_types.Email_address.t list ->
42
+
?text_signature:string ->
43
+
?html_signature:string ->
44
+
may_delete:bool ->
45
+
unit -> t
46
+
47
+
(** Types and functions for identity creation and updates *)
48
+
module Create : sig
49
+
type t
50
+
51
+
(** Get the name (if specified) *)
52
+
val name : t -> string option
53
+
54
+
(** Get the email address *)
55
+
val email : t -> string
56
+
57
+
(** Get the reply-to addresses (if any) *)
58
+
val reply_to : t -> Jmap_email_types.Email_address.t list option
59
+
60
+
(** Get the bcc addresses (if any) *)
61
+
val bcc : t -> Jmap_email_types.Email_address.t list option
62
+
63
+
(** Get the plain text signature (if specified) *)
64
+
val text_signature : t -> string option
65
+
66
+
(** Get the HTML signature (if specified) *)
67
+
val html_signature : t -> string option
68
+
69
+
(** Create a new identity creation object *)
70
+
val v :
71
+
?name:string ->
72
+
email:string ->
73
+
?reply_to:Jmap_email_types.Email_address.t list ->
74
+
?bcc:Jmap_email_types.Email_address.t list ->
75
+
?text_signature:string ->
76
+
?html_signature:string ->
77
+
unit -> t
78
+
79
+
(** Server response with info about the created identity *)
80
+
module Response : sig
81
+
type t
82
+
83
+
(** Get the server-assigned ID for the created identity *)
84
+
val id : t -> id
85
+
86
+
(** Check if this identity may be deleted *)
87
+
val may_delete : t -> bool
88
+
89
+
(** Create a new response object *)
90
+
val v :
91
+
id:id ->
92
+
may_delete:bool ->
93
+
unit -> t
94
+
end
95
+
end
96
+
97
+
(** Identity object for update.
98
+
Patch object, specific structure not enforced here.
99
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-6.3> RFC 8621, Section 6.3 *)
100
+
type update = patch_object
101
+
102
+
(** Server-set/computed info for updated identity.
103
+
Contains only changed server-set props.
104
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-6.3> RFC 8621, Section 6.3 *)
105
+
module Update_response : sig
106
+
type t
107
+
108
+
(** Convert to a full Identity object (contains only changed server-set props) *)
109
+
val to_identity : t -> t
110
+
111
+
(** Create from a full Identity object *)
112
+
val of_identity : t -> t
113
+
end
114
+
+187
jmap-email/jmap_mailbox.mli
+187
jmap-email/jmap_mailbox.mli
···
1
+
(** JMAP Mailbox.
2
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-2> RFC 8621, Section 2 *)
3
+
4
+
open Jmap.Types
5
+
open Jmap.Methods
6
+
7
+
(** Standard mailbox roles as defined in RFC 8621.
8
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-2> RFC 8621, Section 2 *)
9
+
type role =
10
+
| Inbox (** Messages in the primary inbox *)
11
+
| Archive (** Archived messages *)
12
+
| Drafts (** Draft messages being composed *)
13
+
| Sent (** Messages that have been sent *)
14
+
| Trash (** Messages that have been deleted *)
15
+
| Junk (** Messages determined to be spam *)
16
+
| Important (** Messages deemed important *)
17
+
| Snoozed (** Messages snoozed for later notification/reappearance, from draft-ietf-mailmaint-messageflag-mailboxattribute *)
18
+
| Scheduled (** Messages scheduled for sending at a later time, from draft-ietf-mailmaint-messageflag-mailboxattribute *)
19
+
| Memos (** Messages containing memos or notes, from draft-ietf-mailmaint-messageflag-mailboxattribute *)
20
+
21
+
| Other of string (** Custom or non-standard role *)
22
+
| None (** No specific role assigned *)
23
+
24
+
(** Mailbox property identifiers.
25
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-2> RFC 8621, Section 2 *)
26
+
type property =
27
+
| Id (** The id of the mailbox *)
28
+
| Name (** The name of the mailbox *)
29
+
| ParentId (** The id of the parent mailbox *)
30
+
| Role (** The role of the mailbox *)
31
+
| SortOrder (** The sort order of the mailbox *)
32
+
| TotalEmails (** The total number of emails in the mailbox *)
33
+
| UnreadEmails (** The number of unread emails in the mailbox *)
34
+
| TotalThreads (** The total number of threads in the mailbox *)
35
+
| UnreadThreads (** The number of unread threads in the mailbox *)
36
+
| MyRights (** The rights the user has for the mailbox *)
37
+
| IsSubscribed (** Whether the mailbox is subscribed to *)
38
+
| Other of string (** Any server-specific extension properties *)
39
+
40
+
(** Mailbox access rights.
41
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-2> RFC 8621, Section 2 *)
42
+
type mailbox_rights = {
43
+
may_read_items : bool;
44
+
may_add_items : bool;
45
+
may_remove_items : bool;
46
+
may_set_seen : bool;
47
+
may_set_keywords : bool;
48
+
may_create_child : bool;
49
+
may_rename : bool;
50
+
may_delete : bool;
51
+
may_submit : bool;
52
+
}
53
+
54
+
(** Mailbox object.
55
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-2> RFC 8621, Section 2 *)
56
+
type mailbox = {
57
+
mailbox_id : id; (** immutable, server-set *)
58
+
name : string;
59
+
parent_id : id option;
60
+
role : role option;
61
+
sort_order : uint; (* default: 0 *)
62
+
total_emails : uint; (** server-set *)
63
+
unread_emails : uint; (** server-set *)
64
+
total_threads : uint; (** server-set *)
65
+
unread_threads : uint; (** server-set *)
66
+
my_rights : mailbox_rights; (** server-set *)
67
+
is_subscribed : bool;
68
+
}
69
+
70
+
(** Mailbox object for creation.
71
+
Excludes server-set fields.
72
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-2> RFC 8621, Section 2 *)
73
+
type mailbox_create = {
74
+
mailbox_create_name : string;
75
+
mailbox_create_parent_id : id option;
76
+
mailbox_create_role : role option;
77
+
mailbox_create_sort_order : uint option;
78
+
mailbox_create_is_subscribed : bool option;
79
+
}
80
+
81
+
(** Mailbox object for update.
82
+
Patch object, specific structure not enforced here.
83
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-2.5> RFC 8621, Section 2.5 *)
84
+
type mailbox_update = patch_object
85
+
86
+
(** Server-set info for created mailbox.
87
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-2.5> RFC 8621, Section 2.5 *)
88
+
type mailbox_created_info = {
89
+
mailbox_created_id : id;
90
+
mailbox_created_role : role option; (** If default used *)
91
+
mailbox_created_sort_order : uint; (** If default used *)
92
+
mailbox_created_total_emails : uint;
93
+
mailbox_created_unread_emails : uint;
94
+
mailbox_created_total_threads : uint;
95
+
mailbox_created_unread_threads : uint;
96
+
mailbox_created_my_rights : mailbox_rights;
97
+
mailbox_created_is_subscribed : bool; (** If default used *)
98
+
}
99
+
100
+
(** Server-set/computed info for updated mailbox.
101
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-2.5> RFC 8621, Section 2.5 *)
102
+
type mailbox_updated_info = mailbox (* Contains only changed server-set props *)
103
+
104
+
(** FilterCondition for Mailbox/query.
105
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-2.3> RFC 8621, Section 2.3 *)
106
+
type mailbox_filter_condition = {
107
+
filter_parent_id : id option option; (* Use option option for explicit null *)
108
+
filter_name : string option;
109
+
filter_role : role option option; (* Use option option for explicit null *)
110
+
filter_has_any_role : bool option;
111
+
filter_is_subscribed : bool option;
112
+
}
113
+
114
+
(** {2 Role and Property Conversion Functions} *)
115
+
116
+
(** Convert a role variant to its string representation *)
117
+
val role_to_string : role -> string
118
+
119
+
(** Parse a string into a role variant *)
120
+
val string_to_role : string -> role
121
+
122
+
(** Convert a property variant to its string representation *)
123
+
val property_to_string : property -> string
124
+
125
+
(** Parse a string into a property variant *)
126
+
val string_to_property : string -> property
127
+
128
+
(** Get a list of common properties useful for displaying mailboxes *)
129
+
val common_properties : property list
130
+
131
+
(** Get a list of all standard properties *)
132
+
val all_properties : property list
133
+
134
+
(** Check if a property is a count property (TotalEmails, UnreadEmails, etc.) *)
135
+
val is_count_property : property -> bool
136
+
137
+
(** {2 Mailbox Creation and Manipulation} *)
138
+
139
+
(** Create a set of default rights with all permissions *)
140
+
val default_rights : unit -> mailbox_rights
141
+
142
+
(** Create a set of read-only rights *)
143
+
val readonly_rights : unit -> mailbox_rights
144
+
145
+
(** Create a new mailbox object with minimal required fields *)
146
+
val create :
147
+
name:string ->
148
+
?parent_id:id ->
149
+
?role:role ->
150
+
?sort_order:uint ->
151
+
?is_subscribed:bool ->
152
+
unit -> mailbox_create
153
+
154
+
(** Build a patch object for updating mailbox properties *)
155
+
val update :
156
+
?name:string ->
157
+
?parent_id:id option ->
158
+
?role:role option ->
159
+
?sort_order:uint ->
160
+
?is_subscribed:bool ->
161
+
unit -> mailbox_update
162
+
163
+
(** Get the list of standard role names and their string representations *)
164
+
val standard_role_names : (role * string) list
165
+
166
+
(** {2 Filter Construction} *)
167
+
168
+
(** Create a filter to match mailboxes with a specific role *)
169
+
val filter_has_role : role -> Jmap.Methods.Filter.t
170
+
171
+
(** Create a filter to match mailboxes with no role *)
172
+
val filter_has_no_role : unit -> Jmap.Methods.Filter.t
173
+
174
+
(** Create a filter to match mailboxes that are child of a given parent *)
175
+
val filter_has_parent : id -> Jmap.Methods.Filter.t
176
+
177
+
(** Create a filter to match mailboxes at the root level (no parent) *)
178
+
val filter_is_root : unit -> Jmap.Methods.Filter.t
179
+
180
+
(** Create a filter to match subscribed mailboxes *)
181
+
val filter_is_subscribed : unit -> Jmap.Methods.Filter.t
182
+
183
+
(** Create a filter to match unsubscribed mailboxes *)
184
+
val filter_is_not_subscribed : unit -> Jmap.Methods.Filter.t
185
+
186
+
(** Create a filter to match mailboxes by name (using case-insensitive substring matching) *)
187
+
val filter_name_contains : string -> Jmap.Methods.Filter.t
+89
jmap-email/jmap_search_snippet.mli
+89
jmap-email/jmap_search_snippet.mli
···
1
+
(** JMAP Search Snippet.
2
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-5> RFC 8621, Section 5 *)
3
+
4
+
open Jmap.Types
5
+
open Jmap.Methods
6
+
7
+
(** SearchSnippet object.
8
+
Provides highlighted snippets of emails matching search criteria.
9
+
Note: Does not have an 'id' property; the key is the emailId.
10
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-5> RFC 8621, Section 5 *)
11
+
module SearchSnippet : sig
12
+
type t
13
+
14
+
(** Get the email ID this snippet is for *)
15
+
val email_id : t -> id
16
+
17
+
(** Get the highlighted subject snippet (if matched) *)
18
+
val subject : t -> string option
19
+
20
+
(** Get the highlighted preview snippet (if matched) *)
21
+
val preview : t -> string option
22
+
23
+
(** Create a new SearchSnippet object *)
24
+
val v :
25
+
email_id:id ->
26
+
?subject:string ->
27
+
?preview:string ->
28
+
unit -> t
29
+
end
30
+
31
+
(** {1 SearchSnippet Methods} *)
32
+
33
+
(** Arguments for SearchSnippet/get.
34
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-5.1> RFC 8621, Section 5.1 *)
35
+
module Get_args : sig
36
+
type t
37
+
38
+
(** The account ID *)
39
+
val account_id : t -> id
40
+
41
+
(** The filter to use for the search *)
42
+
val filter : t -> Filter.t
43
+
44
+
(** Email IDs to return snippets for. If null, all matching emails are included *)
45
+
val email_ids : t -> id list option
46
+
47
+
(** Creation arguments *)
48
+
val v :
49
+
account_id:id ->
50
+
filter:Filter.t ->
51
+
?email_ids:id list ->
52
+
unit -> t
53
+
end
54
+
55
+
(** Response for SearchSnippet/get.
56
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-5.1> RFC 8621, Section 5.1 *)
57
+
module Get_response : sig
58
+
type t
59
+
60
+
(** The account ID *)
61
+
val account_id : t -> id
62
+
63
+
(** The search state string (for caching) *)
64
+
val list : t -> SearchSnippet.t id_map
65
+
66
+
(** IDs requested that weren't found *)
67
+
val not_found : t -> id list
68
+
69
+
(** Creation *)
70
+
val v :
71
+
account_id:id ->
72
+
list:SearchSnippet.t id_map ->
73
+
not_found:id list ->
74
+
unit -> t
75
+
end
76
+
77
+
(** {1 Helper Functions} *)
78
+
79
+
(** Helper to extract all matched keywords from a snippet.
80
+
This parses highlighted portions from the snippet to get the actual search terms. *)
81
+
val extract_matched_terms : string -> string list
82
+
83
+
(** Helper to create a filter that searches in email body text.
84
+
This is commonly used for SearchSnippet/get requests. *)
85
+
val create_body_text_filter : string -> Filter.t
86
+
87
+
(** Helper to create a filter that searches across multiple email fields.
88
+
This searches subject, body, and headers for the given text. *)
89
+
val create_fulltext_filter : string -> Filter.t
+136
jmap-email/jmap_submission.mli
+136
jmap-email/jmap_submission.mli
···
1
+
(** JMAP Email Submission.
2
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7> RFC 8621, Section 7 *)
3
+
4
+
open Jmap.Types
5
+
open Jmap.Methods
6
+
7
+
(** Address object for Envelope.
8
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7> RFC 8621, Section 7 *)
9
+
type envelope_address = {
10
+
env_addr_email : string;
11
+
env_addr_parameters : Yojson.Safe.t string_map option;
12
+
}
13
+
14
+
(** Envelope object.
15
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7> RFC 8621, Section 7 *)
16
+
type envelope = {
17
+
env_mail_from : envelope_address;
18
+
env_rcpt_to : envelope_address list;
19
+
}
20
+
21
+
(** Delivery status for a recipient.
22
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7> RFC 8621, Section 7 *)
23
+
type delivery_status = {
24
+
delivery_smtp_reply : string;
25
+
delivery_delivered : [ `Queued | `Yes | `No | `Unknown ];
26
+
delivery_displayed : [ `Yes | `Unknown ];
27
+
}
28
+
29
+
(** EmailSubmission object.
30
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7> RFC 8621, Section 7 *)
31
+
type email_submission = {
32
+
email_sub_id : id; (** immutable, server-set *)
33
+
identity_id : id; (** immutable *)
34
+
email_id : id; (** immutable *)
35
+
thread_id : id; (** immutable, server-set *)
36
+
envelope : envelope option; (** immutable *)
37
+
send_at : utc_date; (** immutable, server-set *)
38
+
undo_status : [ `Pending | `Final | `Canceled ];
39
+
delivery_status : delivery_status string_map option; (** server-set *)
40
+
dsn_blob_ids : id list; (** server-set *)
41
+
mdn_blob_ids : id list; (** server-set *)
42
+
}
43
+
44
+
(** EmailSubmission object for creation.
45
+
Excludes server-set fields.
46
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7> RFC 8621, Section 7 *)
47
+
type email_submission_create = {
48
+
email_sub_create_identity_id : id;
49
+
email_sub_create_email_id : id;
50
+
email_sub_create_envelope : envelope option;
51
+
}
52
+
53
+
(** EmailSubmission object for update.
54
+
Only undoStatus can be updated (to 'canceled').
55
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7> RFC 8621, Section 7 *)
56
+
type email_submission_update = patch_object
57
+
58
+
(** Server-set info for created email submission.
59
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7.5> RFC 8621, Section 7.5 *)
60
+
type email_submission_created_info = {
61
+
email_sub_created_id : id;
62
+
email_sub_created_thread_id : id;
63
+
email_sub_created_send_at : utc_date;
64
+
}
65
+
66
+
(** Server-set/computed info for updated email submission.
67
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7.5> RFC 8621, Section 7.5 *)
68
+
type email_submission_updated_info = email_submission (* Contains only changed server-set props *)
69
+
70
+
(** FilterCondition for EmailSubmission/query.
71
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7.3> RFC 8621, Section 7.3 *)
72
+
type email_submission_filter_condition = {
73
+
filter_identity_ids : id list option;
74
+
filter_email_ids : id list option;
75
+
filter_thread_ids : id list option;
76
+
filter_undo_status : [ `Pending | `Final | `Canceled ] option;
77
+
filter_before : utc_date option;
78
+
filter_after : utc_date option;
79
+
}
80
+
81
+
(** EmailSubmission/get: Args type (specialized from ['record Get_args.t]). *)
82
+
module Email_submission_get_args : sig
83
+
type t = email_submission Get_args.t
84
+
end
85
+
86
+
(** EmailSubmission/get: Response type (specialized from ['record Get_response.t]). *)
87
+
module Email_submission_get_response : sig
88
+
type t = email_submission Get_response.t
89
+
end
90
+
91
+
(** EmailSubmission/changes: Args type (specialized from [Changes_args.t]). *)
92
+
module Email_submission_changes_args : sig
93
+
type t = Changes_args.t
94
+
end
95
+
96
+
(** EmailSubmission/changes: Response type (specialized from [Changes_response.t]). *)
97
+
module Email_submission_changes_response : sig
98
+
type t = Changes_response.t
99
+
end
100
+
101
+
(** EmailSubmission/query: Args type (specialized from [Query_args.t]). *)
102
+
module Email_submission_query_args : sig
103
+
type t = Query_args.t
104
+
end
105
+
106
+
(** EmailSubmission/query: Response type (specialized from [Query_response.t]). *)
107
+
module Email_submission_query_response : sig
108
+
type t = Query_response.t
109
+
end
110
+
111
+
(** EmailSubmission/queryChanges: Args type (specialized from [Query_changes_args.t]). *)
112
+
module Email_submission_query_changes_args : sig
113
+
type t = Query_changes_args.t
114
+
end
115
+
116
+
(** EmailSubmission/queryChanges: Response type (specialized from [Query_changes_response.t]). *)
117
+
module Email_submission_query_changes_response : sig
118
+
type t = Query_changes_response.t
119
+
end
120
+
121
+
(** EmailSubmission/set: Args type (specialized from [('c, 'u) set_args]).
122
+
Includes onSuccess arguments.
123
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-7.5> RFC 8621, Section 7.5 *)
124
+
type email_submission_set_args = {
125
+
set_account_id : id;
126
+
set_if_in_state : string option;
127
+
set_create : email_submission_create id_map option;
128
+
set_update : email_submission_update id_map option;
129
+
set_destroy : id list option;
130
+
set_on_success_destroy_email : id list option;
131
+
}
132
+
133
+
(** EmailSubmission/set: Response type (specialized from [('c, 'u) Set_response.t]). *)
134
+
module Email_submission_set_response : sig
135
+
type t = (email_submission_created_info, email_submission_updated_info) Set_response.t
136
+
end
+131
jmap-email/jmap_thread.mli
+131
jmap-email/jmap_thread.mli
···
1
+
(** JMAP Thread.
2
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-3> RFC 8621, Section 3 *)
3
+
4
+
open Jmap.Types
5
+
open Jmap.Methods
6
+
7
+
(** Thread object.
8
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-3> RFC 8621, Section 3 *)
9
+
module Thread : sig
10
+
type t
11
+
12
+
(** Get the thread ID (server-set, immutable) *)
13
+
val id : t -> id
14
+
15
+
(** Get the IDs of emails in the thread (server-set) *)
16
+
val email_ids : t -> id list
17
+
18
+
(** Create a new Thread object *)
19
+
val v : id:id -> email_ids:id list -> t
20
+
end
21
+
22
+
(** Thread properties that can be requested in Thread/get.
23
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-3.1> RFC 8621, Section 3.1 *)
24
+
type property =
25
+
| Id (** The Thread id *)
26
+
| EmailIds (** The list of email IDs in the Thread *)
27
+
28
+
(** Convert a property variant to its string representation *)
29
+
val property_to_string : property -> string
30
+
31
+
(** Parse a string into a property variant *)
32
+
val string_to_property : string -> property
33
+
34
+
(** Get a list of all standard Thread properties *)
35
+
val all_properties : property list
36
+
37
+
(** {1 Thread Methods} *)
38
+
39
+
(** Arguments for Thread/get - extends standard get arguments.
40
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-3.1> RFC 8621, Section 3.1 *)
41
+
module Get_args : sig
42
+
type t
43
+
44
+
val account_id : t -> id
45
+
val ids : t -> id list option
46
+
val properties : t -> string list option
47
+
48
+
val v :
49
+
account_id:id ->
50
+
?ids:id list ->
51
+
?properties:string list ->
52
+
unit -> t
53
+
end
54
+
55
+
(** Response for Thread/get - extends standard get response.
56
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-3.1> RFC 8621, Section 3.1 *)
57
+
module Get_response : sig
58
+
type t
59
+
60
+
val account_id : t -> id
61
+
val state : t -> string
62
+
val list : t -> Thread.t list
63
+
val not_found : t -> id list
64
+
65
+
val v :
66
+
account_id:id ->
67
+
state:string ->
68
+
list:Thread.t list ->
69
+
not_found:id list ->
70
+
unit -> t
71
+
end
72
+
73
+
(** Arguments for Thread/changes - extends standard changes arguments.
74
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-3.2> RFC 8621, Section 3.2 *)
75
+
module Changes_args : sig
76
+
type t
77
+
78
+
val account_id : t -> id
79
+
val since_state : t -> string
80
+
val max_changes : t -> uint option
81
+
82
+
val v :
83
+
account_id:id ->
84
+
since_state:string ->
85
+
?max_changes:uint ->
86
+
unit -> t
87
+
end
88
+
89
+
(** Response for Thread/changes - extends standard changes response.
90
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-3.2> RFC 8621, Section 3.2 *)
91
+
module Changes_response : sig
92
+
type t
93
+
94
+
val account_id : t -> id
95
+
val old_state : t -> string
96
+
val new_state : t -> string
97
+
val has_more_changes : t -> bool
98
+
val created : t -> id list
99
+
val updated : t -> id list
100
+
val destroyed : t -> id list
101
+
102
+
val v :
103
+
account_id:id ->
104
+
old_state:string ->
105
+
new_state:string ->
106
+
has_more_changes:bool ->
107
+
created:id list ->
108
+
updated:id list ->
109
+
destroyed:id list ->
110
+
unit -> t
111
+
end
112
+
113
+
(** {1 Helper Functions} *)
114
+
115
+
(** Create a filter to find threads with specific email ID *)
116
+
val filter_has_email : id -> Filter.t
117
+
118
+
(** Create a filter to find threads with emails from a specific sender *)
119
+
val filter_from : string -> Filter.t
120
+
121
+
(** Create a filter to find threads with emails to a specific recipient *)
122
+
val filter_to : string -> Filter.t
123
+
124
+
(** Create a filter to find threads with specific subject *)
125
+
val filter_subject : string -> Filter.t
126
+
127
+
(** Create a filter to find threads with emails received before a date *)
128
+
val filter_before : date -> Filter.t
129
+
130
+
(** Create a filter to find threads with emails received after a date *)
131
+
val filter_after : date -> Filter.t
+102
jmap-email/jmap_vacation.mli
+102
jmap-email/jmap_vacation.mli
···
1
+
(** JMAP Vacation Response.
2
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-8> RFC 8621, Section 8 *)
3
+
4
+
open Jmap.Types
5
+
open Jmap.Methods
6
+
open Jmap.Error
7
+
8
+
(** VacationResponse object.
9
+
Note: id is always "singleton".
10
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-8> RFC 8621, Section 8 *)
11
+
module Vacation_response : sig
12
+
type t
13
+
14
+
(** Id of the vacation response (immutable, server-set, MUST be "singleton") *)
15
+
val id : t -> id
16
+
val is_enabled : t -> bool
17
+
val from_date : t -> utc_date option
18
+
val to_date : t -> utc_date option
19
+
val subject : t -> string option
20
+
val text_body : t -> string option
21
+
val html_body : t -> string option
22
+
23
+
val v :
24
+
id:id ->
25
+
is_enabled:bool ->
26
+
?from_date:utc_date ->
27
+
?to_date:utc_date ->
28
+
?subject:string ->
29
+
?text_body:string ->
30
+
?html_body:string ->
31
+
unit ->
32
+
t
33
+
end
34
+
35
+
(** VacationResponse object for update.
36
+
Patch object, specific structure not enforced here.
37
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-8.2> RFC 8621, Section 8.2 *)
38
+
type vacation_response_update = patch_object
39
+
40
+
(** VacationResponse/get: Args type (specialized from ['record get_args]). *)
41
+
module Vacation_response_get_args : sig
42
+
type t = Vacation_response.t Get_args.t
43
+
44
+
val v :
45
+
account_id:id ->
46
+
?ids:id list ->
47
+
?properties:string list ->
48
+
unit ->
49
+
t
50
+
end
51
+
52
+
(** VacationResponse/get: Response type (specialized from ['record get_response]). *)
53
+
module Vacation_response_get_response : sig
54
+
type t = Vacation_response.t Get_response.t
55
+
56
+
val v :
57
+
account_id:id ->
58
+
state:string ->
59
+
list:Vacation_response.t list ->
60
+
not_found:id list ->
61
+
unit ->
62
+
t
63
+
end
64
+
65
+
(** VacationResponse/set: Args type.
66
+
Only allows update, id must be "singleton".
67
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-8.2> RFC 8621, Section 8.2 *)
68
+
module Vacation_response_set_args : sig
69
+
type t
70
+
71
+
val account_id : t -> id
72
+
val if_in_state : t -> string option
73
+
val update : t -> vacation_response_update id_map option
74
+
75
+
val v :
76
+
account_id:id ->
77
+
?if_in_state:string ->
78
+
?update:vacation_response_update id_map ->
79
+
unit ->
80
+
t
81
+
end
82
+
83
+
(** VacationResponse/set: Response type.
84
+
@see <https://www.rfc-editor.org/rfc/rfc8621.html#section-8.2> RFC 8621, Section 8.2 *)
85
+
module Vacation_response_set_response : sig
86
+
type t
87
+
88
+
val account_id : t -> id
89
+
val old_state : t -> string option
90
+
val new_state : t -> string
91
+
val updated : t -> Vacation_response.t option id_map option
92
+
val not_updated : t -> Set_error.t id_map option
93
+
94
+
val v :
95
+
account_id:id ->
96
+
?old_state:string ->
97
+
new_state:string ->
98
+
?updated:Vacation_response.t option id_map ->
99
+
?not_updated:Set_error.t id_map ->
100
+
unit ->
101
+
t
102
+
end
+35
jmap-email.opam
+35
jmap-email.opam
···
1
+
opam-version: "2.0"
2
+
name: "jmap-email"
3
+
version: "~dev"
4
+
synopsis: "JMAP Email extensions library (RFC 8621)"
5
+
description: """
6
+
OCaml implementation of the JMAP Mail extensions protocol as defined in RFC 8621.
7
+
Provides type definitions and structures for working with email in JMAP.
8
+
"""
9
+
maintainer: ["user@example.com"]
10
+
authors: ["Example User"]
11
+
license: "MIT"
12
+
homepage: "https://github.com/example/jmap"
13
+
bug-reports: "https://github.com/example/jmap/issues"
14
+
depends: [
15
+
"ocaml" {>= "4.08.0"}
16
+
"dune" {>= "3.0"}
17
+
"jmap"
18
+
"yojson"
19
+
"uri"
20
+
"odoc" {with-doc}
21
+
]
22
+
build: [
23
+
["dune" "subst"] {dev}
24
+
[
25
+
"dune"
26
+
"build"
27
+
"-p"
28
+
name
29
+
"-j"
30
+
jobs
31
+
"@install"
32
+
"@runtest" {with-test}
33
+
"@doc" {with-doc}
34
+
]
35
+
]
+62
jmap-unix/README.md
+62
jmap-unix/README.md
···
1
+
# JMAP Unix Implementation
2
+
3
+
This library provides Unix-specific implementation for the core JMAP protocol.
4
+
5
+
## Overview
6
+
7
+
Jmap_unix provides the implementation needed to make actual connections to JMAP servers
8
+
using OCaml's Unix module. It handles:
9
+
10
+
- HTTP connections to JMAP endpoints
11
+
- Authentication
12
+
- Session discovery
13
+
- Request/response handling
14
+
- Blob upload/download
15
+
- High-level email operations (Jmap_unix.Email)
16
+
17
+
## Usage
18
+
19
+
```ocaml
20
+
open Jmap
21
+
open Jmap_unix
22
+
23
+
(* Create a connection to a JMAP server *)
24
+
let credentials = Basic("username", "password") in
25
+
let (ctx, session) = Jmap_unix.connect ~host:"jmap.example.com" ~credentials in
26
+
27
+
(* Use the connection for JMAP requests *)
28
+
let response = Jmap_unix.request ctx request in
29
+
30
+
(* Close the connection when done *)
31
+
Jmap_unix.close ctx
32
+
```
33
+
34
+
## Email Operations
35
+
36
+
The Email module provides high-level operations for working with emails:
37
+
38
+
```ocaml
39
+
open Jmap
40
+
open Jmap.Unix
41
+
42
+
(* Get an email *)
43
+
let email = Email.get_email ctx ~account_id ~email_id ()
44
+
45
+
(* Search for unread emails *)
46
+
let filter = Jmap_email.Email_filter.unread ()
47
+
let (ids, emails) = Email.search_emails ctx ~account_id ~filter ()
48
+
49
+
(* Mark emails as read *)
50
+
Email.mark_as_seen ctx ~account_id ~email_ids:["email1"; "email2"] ()
51
+
52
+
(* Move emails to another mailbox *)
53
+
Email.move_emails ctx ~account_id ~email_ids ~mailbox_id ()
54
+
```
55
+
56
+
## Dependencies
57
+
58
+
- jmap (core library)
59
+
- jmap-email (email types and helpers)
60
+
- yojson
61
+
- uri
62
+
- unix
+6
jmap-unix/dune
+6
jmap-unix/dune
+359
jmap-unix/jmap_unix.mli
+359
jmap-unix/jmap_unix.mli
···
1
+
(** Unix-specific JMAP client implementation interface.
2
+
3
+
This module provides functions to interact with a JMAP server using
4
+
Unix sockets for network communication.
5
+
6
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-4> RFC 8620, Section 4
7
+
*)
8
+
9
+
(** Configuration options for a JMAP client context *)
10
+
type client_config = {
11
+
connect_timeout : float option; (** Connection timeout in seconds *)
12
+
request_timeout : float option; (** Request timeout in seconds *)
13
+
max_concurrent_requests : int option; (** Maximum concurrent requests *)
14
+
max_request_size : int option; (** Maximum request size in bytes *)
15
+
user_agent : string option; (** User-Agent header value *)
16
+
authentication_header : string option; (** Custom Authentication header name *)
17
+
}
18
+
19
+
(** Authentication method options *)
20
+
type auth_method =
21
+
| Basic of string * string (** Basic auth with username and password *)
22
+
| Bearer of string (** Bearer token auth *)
23
+
| Custom of (string * string) (** Custom header name and value *)
24
+
| Session_cookie of (string * string) (** Session cookie name and value *)
25
+
| No_auth (** No authentication *)
26
+
27
+
(** Represents an active JMAP connection context. Opaque type. *)
28
+
type context
29
+
30
+
(** Represents an active EventSource connection. Opaque type. *)
31
+
type event_source_connection
32
+
33
+
(** A request builder for constructing and sending JMAP requests *)
34
+
type request_builder
35
+
36
+
(** Create default configuration options *)
37
+
val default_config : unit -> client_config
38
+
39
+
(** Create a client context with the specified configuration
40
+
@return The context object used for JMAP API calls
41
+
*)
42
+
val create_client :
43
+
?config:client_config ->
44
+
unit ->
45
+
context
46
+
47
+
(** Connect to a JMAP server and retrieve the session.
48
+
This handles discovery (if needed) and authentication.
49
+
@param ctx The client context.
50
+
@param ?session_url Optional direct URL to the Session resource.
51
+
@param ?username Optional username (e.g., email address) for discovery.
52
+
@param ?auth_method Authentication method to use (default Basic).
53
+
@param credentials Authentication credentials.
54
+
@return A result with either (context, session) or an error.
55
+
*)
56
+
val connect :
57
+
context ->
58
+
?session_url:Uri.t ->
59
+
?username:string ->
60
+
host:string ->
61
+
?port:int ->
62
+
?auth_method:auth_method ->
63
+
unit ->
64
+
(context * Jmap.Session.Session.t) Jmap.Error.result
65
+
66
+
(** Create a request builder for constructing a JMAP request.
67
+
@param ctx The client context.
68
+
@return A request builder object.
69
+
*)
70
+
val build : context -> request_builder
71
+
72
+
(** Set the using capabilities for a request.
73
+
@param builder The request builder.
74
+
@param capabilities List of capability URIs to use.
75
+
@return The updated request builder.
76
+
*)
77
+
val using : request_builder -> string list -> request_builder
78
+
79
+
(** Add a method call to a request builder.
80
+
@param builder The request builder.
81
+
@param name Method name (e.g., "Email/get").
82
+
@param args Method arguments.
83
+
@param id Method call ID.
84
+
@return The updated request builder.
85
+
*)
86
+
val add_method_call :
87
+
request_builder ->
88
+
string ->
89
+
Yojson.Safe.t ->
90
+
string ->
91
+
request_builder
92
+
93
+
(** Create a reference to a previous method call result.
94
+
@param result_of Method call ID to reference.
95
+
@param name Path in the response.
96
+
@return A ResultReference to use in another method call.
97
+
*)
98
+
val create_reference : string -> string -> Jmap.Wire.Result_reference.t
99
+
100
+
(** Execute a request and return the response.
101
+
@param builder The request builder to execute.
102
+
@return The JMAP response from the server.
103
+
*)
104
+
val execute : request_builder -> Jmap.Wire.Response.t Jmap.Error.result
105
+
106
+
(** Perform a JMAP API request.
107
+
@param ctx The connection context.
108
+
@param request The JMAP request object.
109
+
@return The JMAP response from the server.
110
+
*)
111
+
val request : context -> Jmap.Wire.Request.t -> Jmap.Wire.Response.t Jmap.Error.result
112
+
113
+
(** Upload binary data.
114
+
@param ctx The connection context.
115
+
@param account_id The target account ID.
116
+
@param content_type The MIME type of the data.
117
+
@param data_stream A stream providing the binary data chunks.
118
+
@return A result with either an upload response or an error.
119
+
*)
120
+
val upload :
121
+
context ->
122
+
account_id:Jmap.Types.id ->
123
+
content_type:string ->
124
+
data_stream:string Seq.t ->
125
+
Jmap.Binary.Upload_response.t Jmap.Error.result
126
+
127
+
(** Download binary data.
128
+
@param ctx The connection context.
129
+
@param account_id The account ID.
130
+
@param blob_id The blob ID to download.
131
+
@param ?content_type The desired Content-Type for the download response.
132
+
@param ?name The desired filename for the download response.
133
+
@return A result with either a stream of data chunks or an error.
134
+
*)
135
+
val download :
136
+
context ->
137
+
account_id:Jmap.Types.id ->
138
+
blob_id:Jmap.Types.id ->
139
+
?content_type:string ->
140
+
?name:string ->
141
+
(string Seq.t) Jmap.Error.result
142
+
143
+
(** Copy blobs between accounts.
144
+
@param ctx The connection context.
145
+
@param from_account_id Source account ID.
146
+
@param account_id Destination account ID.
147
+
@param blob_ids List of blob IDs to copy.
148
+
@return A result with either the copy response or an error.
149
+
*)
150
+
val copy_blobs :
151
+
context ->
152
+
from_account_id:Jmap.Types.id ->
153
+
account_id:Jmap.Types.id ->
154
+
blob_ids:Jmap.Types.id list ->
155
+
Jmap.Binary.Blob_copy_response.t Jmap.Error.result
156
+
157
+
(** Connect to the EventSource for push notifications.
158
+
@param ctx The connection context.
159
+
@param ?types List of types to subscribe to (default "*").
160
+
@param ?close_after Request server to close after first state event.
161
+
@param ?ping Request ping interval in seconds (default 0).
162
+
@return A result with either a tuple of connection handle and event stream, or an error.
163
+
@see <https://www.rfc-editor.org/rfc/rfc8620.html#section-7.3> RFC 8620, Section 7.3 *)
164
+
val connect_event_source :
165
+
context ->
166
+
?types:string list ->
167
+
?close_after:[`State | `No] ->
168
+
?ping:Jmap.Types.uint ->
169
+
(event_source_connection *
170
+
([`State of Jmap.Push.State_change.t | `Ping of Jmap.Push.Event_source_ping_data.t ] Seq.t)) Jmap.Error.result
171
+
172
+
(** Create a websocket connection for JMAP over WebSocket.
173
+
@param ctx The connection context.
174
+
@return A result with either a websocket connection or an error.
175
+
@see <https://www.rfc-editor.org/rfc/rfc8887.html> RFC 8887 *)
176
+
val connect_websocket :
177
+
context ->
178
+
event_source_connection Jmap.Error.result
179
+
180
+
(** Send a message over a websocket connection.
181
+
@param conn The websocket connection.
182
+
@param request The JMAP request to send.
183
+
@return A result with either the response or an error.
184
+
*)
185
+
val websocket_send :
186
+
event_source_connection ->
187
+
Jmap.Wire.Request.t ->
188
+
Jmap.Wire.Response.t Jmap.Error.result
189
+
190
+
(** Close an EventSource or WebSocket connection.
191
+
@param conn The connection handle.
192
+
@return A result with either unit or an error.
193
+
*)
194
+
val close_connection : event_source_connection -> unit Jmap.Error.result
195
+
196
+
(** Close the JMAP connection context.
197
+
@return A result with either unit or an error.
198
+
*)
199
+
val close : context -> unit Jmap.Error.result
200
+
201
+
(** {2 Helper Methods for Common Tasks} *)
202
+
203
+
(** Helper to get a single object by ID.
204
+
@param ctx The context.
205
+
@param method_name The get method (e.g., "Email/get").
206
+
@param account_id The account ID.
207
+
@param object_id The ID of the object to get.
208
+
@param ?properties Optional list of properties to fetch.
209
+
@return A result with either the object as JSON or an error.
210
+
*)
211
+
val get_object :
212
+
context ->
213
+
method_name:string ->
214
+
account_id:Jmap.Types.id ->
215
+
object_id:Jmap.Types.id ->
216
+
?properties:string list ->
217
+
Yojson.Safe.t Jmap.Error.result
218
+
219
+
(** Helper to set up the connection with minimal options.
220
+
@param host The JMAP server hostname.
221
+
@param username Username for basic auth.
222
+
@param password Password for basic auth.
223
+
@return A result with either (context, session) or an error.
224
+
*)
225
+
val quick_connect :
226
+
host:string ->
227
+
username:string ->
228
+
password:string ->
229
+
(context * Jmap.Session.Session.t) Jmap.Error.result
230
+
231
+
(** Perform a Core/echo request to test connectivity.
232
+
@param ctx The JMAP connection context.
233
+
@param ?data Optional data to echo back.
234
+
@return A result with either the response or an error.
235
+
*)
236
+
val echo :
237
+
context ->
238
+
?data:Yojson.Safe.t ->
239
+
unit ->
240
+
Yojson.Safe.t Jmap.Error.result
241
+
242
+
(** {2 Email Operations} *)
243
+
244
+
(** High-level email operations that map to JMAP email methods *)
245
+
module Email : sig
246
+
open Jmap_email.Types
247
+
248
+
(** Get an email by ID
249
+
@param ctx The JMAP client context
250
+
@param account_id The account ID
251
+
@param email_id The email ID to fetch
252
+
@param ?properties Optional list of properties to fetch
253
+
@return The email object or an error
254
+
*)
255
+
val get_email :
256
+
context ->
257
+
account_id:Jmap.Types.id ->
258
+
email_id:Jmap.Types.id ->
259
+
?properties:string list ->
260
+
unit ->
261
+
Email.t Jmap.Error.result
262
+
263
+
(** Search for emails using a filter
264
+
@param ctx The JMAP client context
265
+
@param account_id The account ID
266
+
@param filter The search filter
267
+
@param ?sort Optional sort criteria (default received date newest first)
268
+
@param ?limit Optional maximum number of results
269
+
@param ?properties Optional properties to fetch for the matching emails
270
+
@return The list of matching email IDs and optionally the email objects
271
+
*)
272
+
val search_emails :
273
+
context ->
274
+
account_id:Jmap.Types.id ->
275
+
filter:Jmap.Methods.Filter.t ->
276
+
?sort:Jmap.Methods.Comparator.t list ->
277
+
?limit:Jmap.Types.uint ->
278
+
?position:int ->
279
+
?properties:string list ->
280
+
unit ->
281
+
(Jmap.Types.id list * Email.t list option) Jmap.Error.result
282
+
283
+
(** Mark multiple emails with a keyword
284
+
@param ctx The JMAP client context
285
+
@param account_id The account ID
286
+
@param email_ids List of email IDs to update
287
+
@param keyword The keyword to add
288
+
@return The result of the operation
289
+
*)
290
+
val mark_emails :
291
+
context ->
292
+
account_id:Jmap.Types.id ->
293
+
email_ids:Jmap.Types.id list ->
294
+
keyword:Keywords.keyword ->
295
+
unit ->
296
+
unit Jmap.Error.result
297
+
298
+
(** Mark emails as seen/read
299
+
@param ctx The JMAP client context
300
+
@param account_id The account ID
301
+
@param email_ids List of email IDs to mark
302
+
@return The result of the operation
303
+
*)
304
+
val mark_as_seen :
305
+
context ->
306
+
account_id:Jmap.Types.id ->
307
+
email_ids:Jmap.Types.id list ->
308
+
unit ->
309
+
unit Jmap.Error.result
310
+
311
+
(** Mark emails as unseen/unread
312
+
@param ctx The JMAP client context
313
+
@param account_id The account ID
314
+
@param email_ids List of email IDs to mark
315
+
@return The result of the operation
316
+
*)
317
+
val mark_as_unseen :
318
+
context ->
319
+
account_id:Jmap.Types.id ->
320
+
email_ids:Jmap.Types.id list ->
321
+
unit ->
322
+
unit Jmap.Error.result
323
+
324
+
(** Move emails to a different mailbox
325
+
@param ctx The JMAP client context
326
+
@param account_id The account ID
327
+
@param email_ids List of email IDs to move
328
+
@param mailbox_id Destination mailbox ID
329
+
@param ?remove_from_mailboxes Optional list of source mailbox IDs to remove from
330
+
@return The result of the operation
331
+
*)
332
+
val move_emails :
333
+
context ->
334
+
account_id:Jmap.Types.id ->
335
+
email_ids:Jmap.Types.id list ->
336
+
mailbox_id:Jmap.Types.id ->
337
+
?remove_from_mailboxes:Jmap.Types.id list ->
338
+
unit ->
339
+
unit Jmap.Error.result
340
+
341
+
(** Import an RFC822 message
342
+
@param ctx The JMAP client context
343
+
@param account_id The account ID
344
+
@param rfc822 Raw message content
345
+
@param mailbox_ids Mailboxes to add the message to
346
+
@param ?keywords Optional keywords to set
347
+
@param ?received_at Optional received timestamp
348
+
@return The ID of the imported email
349
+
*)
350
+
val import_email :
351
+
context ->
352
+
account_id:Jmap.Types.id ->
353
+
rfc822:string ->
354
+
mailbox_ids:Jmap.Types.id list ->
355
+
?keywords:Keywords.t ->
356
+
?received_at:Jmap.Types.date ->
357
+
unit ->
358
+
Jmap.Types.id Jmap.Error.result
359
+
end
+21
jmap-unix.opam
+21
jmap-unix.opam
···
1
+
opam-version: "2.0"
2
+
name: "jmap-unix"
3
+
version: "~dev"
4
+
synopsis: "JMAP Unix implementation"
5
+
description: "Unix-specific implementation of the JMAP protocol (RFC8620)"
6
+
maintainer: ["maintainer@example.com"]
7
+
authors: ["JMAP OCaml Team"]
8
+
license: "MIT"
9
+
homepage: "https://github.com/example/jmap-ocaml"
10
+
bug-reports: "https://github.com/example/jmap-ocaml/issues"
11
+
depends: [
12
+
"ocaml" {>= "4.08.0"}
13
+
"dune" {>= "2.0.0"}
14
+
"jmap"
15
+
"yojson" {>= "1.7.0"}
16
+
"uri" {>= "4.0.0"}
17
+
"unix"
18
+
]
19
+
build: [
20
+
["dune" "build" "-p" name "-j" jobs]
21
+
]
-37
jmap.opam
-37
jmap.opam
···
1
-
# This file is generated by dune, edit dune-project instead
2
-
opam-version: "2.0"
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>"]
8
-
license: "ISC"
9
-
homepage: "https://tangled.org/@anil.recoil.org/ocaml-jmap"
10
-
bug-reports: "https://tangled.org/@anil.recoil.org/ocaml-jmap/issues"
11
-
depends: [
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}
20
-
"odoc" {with-doc}
21
-
]
22
-
depopts: ["eio" "requests" "brr"]
23
-
build: [
24
-
["dune" "subst"] {dev}
25
-
[
26
-
"dune"
27
-
"build"
28
-
"-p"
29
-
name
30
-
"-j"
31
-
jobs
32
-
"@install"
33
-
"@runtest" {with-test}
34
-
"@doc" {with-doc}
35
-
]
36
-
]
37
-
x-maintenance-intent: ["(latest)"]
-851
lib/core/chain.ml
-851
lib/core/chain.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
open Jmap_proto
7
-
8
-
(* Phantom types for handle kinds *)
9
-
type query
10
-
type get
11
-
type changes
12
-
type set
13
-
type query_changes
14
-
type copy
15
-
type import
16
-
type parse
17
-
18
-
(* Internal handle representation with GADT for response type *)
19
-
type (_, _) handle =
20
-
| Query_handle : {
21
-
call_id : string;
22
-
method_name : string;
23
-
} -> (query, Method.query_response) handle
24
-
| Query_changes_handle : {
25
-
call_id : string;
26
-
method_name : string;
27
-
} -> (query_changes, Method.query_changes_response) handle
28
-
| Email_get_handle : {
29
-
call_id : string;
30
-
method_name : string;
31
-
} -> (get, Email.t Method.get_response) handle
32
-
| Thread_get_handle : {
33
-
call_id : string;
34
-
method_name : string;
35
-
} -> (get, Thread.t Method.get_response) handle
36
-
| Mailbox_get_handle : {
37
-
call_id : string;
38
-
method_name : string;
39
-
} -> (get, Mailbox.t Method.get_response) handle
40
-
| Identity_get_handle : {
41
-
call_id : string;
42
-
method_name : string;
43
-
} -> (get, Identity.t Method.get_response) handle
44
-
| Submission_get_handle : {
45
-
call_id : string;
46
-
method_name : string;
47
-
} -> (get, Submission.t Method.get_response) handle
48
-
| Search_snippet_get_handle : {
49
-
call_id : string;
50
-
method_name : string;
51
-
} -> (get, Search_snippet.t Method.get_response) handle
52
-
| Vacation_get_handle : {
53
-
call_id : string;
54
-
method_name : string;
55
-
} -> (get, Vacation.t Method.get_response) handle
56
-
| Changes_handle : {
57
-
call_id : string;
58
-
method_name : string;
59
-
} -> (changes, Method.changes_response) handle
60
-
| Email_set_handle : {
61
-
call_id : string;
62
-
method_name : string;
63
-
} -> (set, Email.t Method.set_response) handle
64
-
| Mailbox_set_handle : {
65
-
call_id : string;
66
-
method_name : string;
67
-
} -> (set, Mailbox.t Method.set_response) handle
68
-
| Identity_set_handle : {
69
-
call_id : string;
70
-
method_name : string;
71
-
} -> (set, Identity.t Method.set_response) handle
72
-
| Submission_set_handle : {
73
-
call_id : string;
74
-
method_name : string;
75
-
} -> (set, Submission.t Method.set_response) handle
76
-
| Vacation_set_handle : {
77
-
call_id : string;
78
-
method_name : string;
79
-
} -> (set, Vacation.t Method.set_response) handle
80
-
| Email_copy_handle : {
81
-
call_id : string;
82
-
method_name : string;
83
-
} -> (copy, Email.t Method.copy_response) handle
84
-
| Raw_handle : {
85
-
call_id : string;
86
-
method_name : string;
87
-
} -> (unit, Jsont.Json.t) handle
88
-
89
-
let call_id : type k r. (k, r) handle -> string = function
90
-
| Query_handle h -> h.call_id
91
-
| Query_changes_handle h -> h.call_id
92
-
| Email_get_handle h -> h.call_id
93
-
| Thread_get_handle h -> h.call_id
94
-
| Mailbox_get_handle h -> h.call_id
95
-
| Identity_get_handle h -> h.call_id
96
-
| Submission_get_handle h -> h.call_id
97
-
| Search_snippet_get_handle h -> h.call_id
98
-
| Vacation_get_handle h -> h.call_id
99
-
| Changes_handle h -> h.call_id
100
-
| Email_set_handle h -> h.call_id
101
-
| Mailbox_set_handle h -> h.call_id
102
-
| Identity_set_handle h -> h.call_id
103
-
| Submission_set_handle h -> h.call_id
104
-
| Vacation_set_handle h -> h.call_id
105
-
| Email_copy_handle h -> h.call_id
106
-
| Raw_handle h -> h.call_id
107
-
108
-
let method_name : type k r. (k, r) handle -> string = function
109
-
| Query_handle h -> h.method_name
110
-
| Query_changes_handle h -> h.method_name
111
-
| Email_get_handle h -> h.method_name
112
-
| Thread_get_handle h -> h.method_name
113
-
| Mailbox_get_handle h -> h.method_name
114
-
| Identity_get_handle h -> h.method_name
115
-
| Submission_get_handle h -> h.method_name
116
-
| Search_snippet_get_handle h -> h.method_name
117
-
| Vacation_get_handle h -> h.method_name
118
-
| Changes_handle h -> h.method_name
119
-
| Email_set_handle h -> h.method_name
120
-
| Mailbox_set_handle h -> h.method_name
121
-
| Identity_set_handle h -> h.method_name
122
-
| Submission_set_handle h -> h.method_name
123
-
| Vacation_set_handle h -> h.method_name
124
-
| Email_copy_handle h -> h.method_name
125
-
| Raw_handle h -> h.method_name
126
-
127
-
(* Creation IDs *)
128
-
type 'a create_id = string
129
-
130
-
let created_id cid = Id.of_string_exn ("#" ^ cid)
131
-
let created_id_of_string s = Id.of_string_exn ("#" ^ s)
132
-
133
-
(* ID sources *)
134
-
type id_source =
135
-
| Ids of Id.t list
136
-
| Ref of Invocation.result_reference
137
-
138
-
let ids lst = Ids lst
139
-
let id x = Ids [x]
140
-
141
-
let make_ref ~call_id ~method_name ~path =
142
-
Ref (Invocation.result_reference_of_strings
143
-
~result_of:call_id
144
-
~name:method_name
145
-
~path)
146
-
147
-
let from_query : type r. (query, r) handle -> id_source = fun h ->
148
-
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/ids"
149
-
150
-
let from_get_ids : type r. (get, r) handle -> id_source = fun h ->
151
-
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/list/*/id"
152
-
153
-
let from_get_field : type r. (get, r) handle -> string -> id_source = fun h field ->
154
-
make_ref ~call_id:(call_id h) ~method_name:(method_name h)
155
-
~path:(Printf.sprintf "/list/*/%s" field)
156
-
157
-
let from_changes_created : type r. (changes, r) handle -> id_source = fun h ->
158
-
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/created"
159
-
160
-
let from_changes_updated : type r. (changes, r) handle -> id_source = fun h ->
161
-
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/updated"
162
-
163
-
let from_changes_destroyed : type r. (changes, r) handle -> id_source = fun h ->
164
-
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/destroyed"
165
-
166
-
let from_set_created : type r. (set, r) handle -> id_source = fun h ->
167
-
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/created/*/id"
168
-
169
-
let from_set_updated : type r. (set, r) handle -> id_source = fun h ->
170
-
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/updated"
171
-
172
-
let from_query_changes_removed : type r. (query_changes, r) handle -> id_source = fun h ->
173
-
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/removed"
174
-
175
-
let from_query_changes_added : type r. (query_changes, r) handle -> id_source = fun h ->
176
-
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/added/*/id"
177
-
178
-
let from_copy_created : type r. (copy, r) handle -> id_source = fun h ->
179
-
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/created/*/id"
180
-
181
-
let from_import_created : type r. (import, r) handle -> id_source = fun h ->
182
-
make_ref ~call_id:(call_id h) ~method_name:(method_name h) ~path:"/created/*/id"
183
-
184
-
(* Chain state *)
185
-
type state = {
186
-
mutable next_id : int;
187
-
mutable next_create_id : int;
188
-
mutable invocations : Invocation.t list;
189
-
}
190
-
191
-
(* Chain monad *)
192
-
type 'a t = state -> 'a
193
-
194
-
let return x _state = x
195
-
196
-
let bind m f state =
197
-
let a = m state in
198
-
f a state
199
-
200
-
let map f m state =
201
-
f (m state)
202
-
203
-
let both a b state =
204
-
let x = a state in
205
-
let y = b state in
206
-
(x, y)
207
-
208
-
let ( let* ) = bind
209
-
let ( let+ ) m f = map f m
210
-
let ( and* ) = both
211
-
let ( and+ ) = both
212
-
213
-
(* Building *)
214
-
let fresh_call_id state =
215
-
let id = Printf.sprintf "c%d" state.next_id in
216
-
state.next_id <- state.next_id + 1;
217
-
id
218
-
219
-
let fresh_create_id () state =
220
-
let id = Printf.sprintf "k%d" state.next_create_id in
221
-
state.next_create_id <- state.next_create_id + 1;
222
-
id
223
-
224
-
let record_invocation inv state =
225
-
state.invocations <- inv :: state.invocations
226
-
227
-
let build ~capabilities chain =
228
-
let state = { next_id = 0; next_create_id = 0; invocations = [] } in
229
-
let result = chain state in
230
-
let request = Request.create
231
-
~using:capabilities
232
-
~method_calls:(List.rev state.invocations)
233
-
()
234
-
in
235
-
(request, result)
236
-
237
-
let build_request ~capabilities chain =
238
-
fst (build ~capabilities chain)
239
-
240
-
(* JSON helpers - exported *)
241
-
let json_null = Jsont.Null ((), Jsont.Meta.none)
242
-
243
-
let json_bool b = Jsont.Bool (b, Jsont.Meta.none)
244
-
245
-
let json_string s = Jsont.String (s, Jsont.Meta.none)
246
-
247
-
let json_int n = Jsont.Number (Int64.to_float n, Jsont.Meta.none)
248
-
249
-
let json_name s = (s, Jsont.Meta.none)
250
-
251
-
let json_obj fields =
252
-
let fields' = List.map (fun (k, v) -> (json_name k, v)) fields in
253
-
Jsont.Object (fields', Jsont.Meta.none)
254
-
255
-
let json_array items = Jsont.Array (items, Jsont.Meta.none)
256
-
257
-
(* JSON helpers - internal *)
258
-
let json_of_id id =
259
-
Jsont.String (Id.to_string id, Jsont.Meta.none)
260
-
261
-
let json_of_id_list ids =
262
-
let items = List.map json_of_id ids in
263
-
Jsont.Array (items, Jsont.Meta.none)
264
-
265
-
let json_of_string_list strs =
266
-
let items = List.map json_string strs in
267
-
Jsont.Array (items, Jsont.Meta.none)
268
-
269
-
let json_map pairs =
270
-
let fields' = List.map (fun (k, v) -> (json_name k, v)) pairs in
271
-
Jsont.Object (fields', Jsont.Meta.none)
272
-
273
-
let encode_to_json jsont value =
274
-
match Jsont.Json.encode' jsont value with
275
-
| Ok j -> j
276
-
| Error _ -> json_obj []
277
-
278
-
let encode_list_to_json jsont values =
279
-
match Jsont.Json.encode' (Jsont.list jsont) values with
280
-
| Ok j -> j
281
-
| Error _ -> Jsont.Array ([], Jsont.Meta.none)
282
-
283
-
(* Add id_source to args *)
284
-
let add_ids_arg args = function
285
-
| None -> args
286
-
| Some (Ids ids) ->
287
-
("ids", json_of_id_list ids) :: args
288
-
| Some (Ref ref_) ->
289
-
let ref_json = encode_to_json Invocation.result_reference_jsont ref_ in
290
-
("#ids", ref_json) :: args
291
-
292
-
let add_destroy_arg args = function
293
-
| None -> args
294
-
| Some (Ids ids) ->
295
-
("destroy", json_of_id_list ids) :: args
296
-
| Some (Ref ref_) ->
297
-
let ref_json = encode_to_json Invocation.result_reference_jsont ref_ in
298
-
("#destroy", ref_json) :: args
299
-
300
-
(* Query builder helper *)
301
-
let build_query_args ~account_id ?filter ?filter_jsont ?sort ?position ?anchor
302
-
?anchor_offset ?limit ?calculate_total () =
303
-
let args = [ ("accountId", json_of_id account_id) ] in
304
-
let args = match filter, filter_jsont with
305
-
| Some f, Some jsont -> ("filter", encode_to_json jsont f) :: args
306
-
| _ -> args
307
-
in
308
-
let args = match sort with
309
-
| None -> args
310
-
| Some comparators -> ("sort", encode_list_to_json Filter.comparator_jsont comparators) :: args
311
-
in
312
-
let args = match position with
313
-
| None -> args
314
-
| Some n -> ("position", json_int n) :: args
315
-
in
316
-
let args = match anchor with
317
-
| None -> args
318
-
| Some id -> ("anchor", json_of_id id) :: args
319
-
in
320
-
let args = match anchor_offset with
321
-
| None -> args
322
-
| Some n -> ("anchorOffset", json_int n) :: args
323
-
in
324
-
let args = match limit with
325
-
| None -> args
326
-
| Some n -> ("limit", json_int n) :: args
327
-
in
328
-
let args = match calculate_total with
329
-
| None -> args
330
-
| Some b -> ("calculateTotal", json_bool b) :: args
331
-
in
332
-
args
333
-
334
-
(* Changes builder helper *)
335
-
let build_changes_args ~account_id ~since_state ?max_changes () =
336
-
let args = [
337
-
("accountId", json_of_id account_id);
338
-
("sinceState", json_string since_state);
339
-
] in
340
-
let args = match max_changes with
341
-
| None -> args
342
-
| Some n -> ("maxChanges", json_int n) :: args
343
-
in
344
-
args
345
-
346
-
(* QueryChanges builder helper *)
347
-
let build_query_changes_args ~account_id ~since_query_state ?filter ?filter_jsont
348
-
?sort ?max_changes ?up_to_id ?calculate_total () =
349
-
let args = [
350
-
("accountId", json_of_id account_id);
351
-
("sinceQueryState", json_string since_query_state);
352
-
] in
353
-
let args = match filter, filter_jsont with
354
-
| Some f, Some jsont -> ("filter", encode_to_json jsont f) :: args
355
-
| _ -> args
356
-
in
357
-
let args = match sort with
358
-
| None -> args
359
-
| Some comparators -> ("sort", encode_list_to_json Filter.comparator_jsont comparators) :: args
360
-
in
361
-
let args = match max_changes with
362
-
| None -> args
363
-
| Some n -> ("maxChanges", json_int n) :: args
364
-
in
365
-
let args = match up_to_id with
366
-
| None -> args
367
-
| Some id -> ("upToId", json_of_id id) :: args
368
-
in
369
-
let args = match calculate_total with
370
-
| None -> args
371
-
| Some b -> ("calculateTotal", json_bool b) :: args
372
-
in
373
-
args
374
-
375
-
(* Set builder helper *)
376
-
let build_set_args ~account_id ?if_in_state ?create ?update ?destroy () =
377
-
let args = [ ("accountId", json_of_id account_id) ] in
378
-
let args = match if_in_state with
379
-
| None -> args
380
-
| Some s -> ("ifInState", json_string s) :: args
381
-
in
382
-
let args = match create with
383
-
| None | Some [] -> args
384
-
| Some items ->
385
-
let create_map = json_map (List.map (fun (cid, obj) -> (cid, obj)) items) in
386
-
("create", create_map) :: args
387
-
in
388
-
let args = match update with
389
-
| None | Some [] -> args
390
-
| Some items ->
391
-
let update_map = json_map (List.map (fun (id, patch) -> (Id.to_string id, patch)) items) in
392
-
("update", update_map) :: args
393
-
in
394
-
let args = add_destroy_arg args destroy in
395
-
args
396
-
397
-
(* Method builders *)
398
-
399
-
let email_query ~account_id ?filter ?sort ?position ?anchor ?anchor_offset
400
-
?limit ?calculate_total ?collapse_threads () state =
401
-
let call_id = fresh_call_id state in
402
-
let args = build_query_args ~account_id ?filter
403
-
~filter_jsont:Mail_filter.email_filter_jsont
404
-
?sort ?position ?anchor ?anchor_offset ?limit ?calculate_total () in
405
-
let args = match collapse_threads with
406
-
| None -> args
407
-
| Some b -> ("collapseThreads", json_bool b) :: args
408
-
in
409
-
let inv = Invocation.create
410
-
~name:"Email/query"
411
-
~arguments:(json_obj args)
412
-
~method_call_id:call_id
413
-
in
414
-
record_invocation inv state;
415
-
Query_handle { call_id; method_name = "Email/query" }
416
-
417
-
let email_get ~account_id ?ids ?properties ?body_properties
418
-
?fetch_text_body_values ?fetch_html_body_values ?fetch_all_body_values
419
-
?max_body_value_bytes () state =
420
-
let call_id = fresh_call_id state in
421
-
let args = [ ("accountId", json_of_id account_id) ] in
422
-
let args = add_ids_arg args ids in
423
-
let args = match properties with
424
-
| None -> args
425
-
| Some props -> ("properties", json_of_string_list props) :: args
426
-
in
427
-
let args = match body_properties with
428
-
| None -> args
429
-
| Some props -> ("bodyProperties", json_of_string_list props) :: args
430
-
in
431
-
let args = match fetch_text_body_values with
432
-
| None -> args
433
-
| Some b -> ("fetchTextBodyValues", json_bool b) :: args
434
-
in
435
-
let args = match fetch_html_body_values with
436
-
| None -> args
437
-
| Some b -> ("fetchHTMLBodyValues", json_bool b) :: args
438
-
in
439
-
let args = match fetch_all_body_values with
440
-
| None -> args
441
-
| Some b -> ("fetchAllBodyValues", json_bool b) :: args
442
-
in
443
-
let args = match max_body_value_bytes with
444
-
| None -> args
445
-
| Some n -> ("maxBodyValueBytes", json_int n) :: args
446
-
in
447
-
let inv = Invocation.create
448
-
~name:"Email/get"
449
-
~arguments:(json_obj args)
450
-
~method_call_id:call_id
451
-
in
452
-
record_invocation inv state;
453
-
Email_get_handle { call_id; method_name = "Email/get" }
454
-
455
-
let email_changes ~account_id ~since_state ?max_changes () state =
456
-
let call_id = fresh_call_id state in
457
-
let args = build_changes_args ~account_id ~since_state ?max_changes () in
458
-
let inv = Invocation.create
459
-
~name:"Email/changes"
460
-
~arguments:(json_obj args)
461
-
~method_call_id:call_id
462
-
in
463
-
record_invocation inv state;
464
-
Changes_handle { call_id; method_name = "Email/changes" }
465
-
466
-
let email_query_changes ~account_id ~since_query_state ?filter ?sort
467
-
?max_changes ?up_to_id ?calculate_total () state =
468
-
let call_id = fresh_call_id state in
469
-
let args = build_query_changes_args ~account_id ~since_query_state
470
-
?filter ~filter_jsont:Mail_filter.email_filter_jsont
471
-
?sort ?max_changes ?up_to_id ?calculate_total () in
472
-
let inv = Invocation.create
473
-
~name:"Email/queryChanges"
474
-
~arguments:(json_obj args)
475
-
~method_call_id:call_id
476
-
in
477
-
record_invocation inv state;
478
-
Query_changes_handle { call_id; method_name = "Email/queryChanges" }
479
-
480
-
let email_set ~account_id ?if_in_state ?create ?update ?destroy () state =
481
-
let call_id = fresh_call_id state in
482
-
let args = build_set_args ~account_id ?if_in_state ?create ?update ?destroy () in
483
-
let inv = Invocation.create
484
-
~name:"Email/set"
485
-
~arguments:(json_obj args)
486
-
~method_call_id:call_id
487
-
in
488
-
record_invocation inv state;
489
-
Email_set_handle { call_id; method_name = "Email/set" }
490
-
491
-
let email_copy ~from_account_id ~account_id ?if_from_in_state ?if_in_state
492
-
?create ?on_success_destroy_original ?destroy_from_if_in_state () state =
493
-
let call_id = fresh_call_id state in
494
-
let args = [
495
-
("fromAccountId", json_of_id from_account_id);
496
-
("accountId", json_of_id account_id);
497
-
] in
498
-
let args = match if_from_in_state with
499
-
| None -> args
500
-
| Some s -> ("ifFromInState", json_string s) :: args
501
-
in
502
-
let args = match if_in_state with
503
-
| None -> args
504
-
| Some s -> ("ifInState", json_string s) :: args
505
-
in
506
-
let args = match create with
507
-
| None | Some [] -> args
508
-
| Some items ->
509
-
let create_map = json_map (List.map (fun (id, obj) -> (Id.to_string id, obj)) items) in
510
-
("create", create_map) :: args
511
-
in
512
-
let args = match on_success_destroy_original with
513
-
| None -> args
514
-
| Some b -> ("onSuccessDestroyOriginal", json_bool b) :: args
515
-
in
516
-
let args = match destroy_from_if_in_state with
517
-
| None -> args
518
-
| Some s -> ("destroyFromIfInState", json_string s) :: args
519
-
in
520
-
let inv = Invocation.create
521
-
~name:"Email/copy"
522
-
~arguments:(json_obj args)
523
-
~method_call_id:call_id
524
-
in
525
-
record_invocation inv state;
526
-
Email_copy_handle { call_id; method_name = "Email/copy" }
527
-
528
-
let thread_get ~account_id ?ids () state =
529
-
let call_id = fresh_call_id state in
530
-
let args = [ ("accountId", json_of_id account_id) ] in
531
-
let args = add_ids_arg args ids in
532
-
let inv = Invocation.create
533
-
~name:"Thread/get"
534
-
~arguments:(json_obj args)
535
-
~method_call_id:call_id
536
-
in
537
-
record_invocation inv state;
538
-
Thread_get_handle { call_id; method_name = "Thread/get" }
539
-
540
-
let thread_changes ~account_id ~since_state ?max_changes () state =
541
-
let call_id = fresh_call_id state in
542
-
let args = build_changes_args ~account_id ~since_state ?max_changes () in
543
-
let inv = Invocation.create
544
-
~name:"Thread/changes"
545
-
~arguments:(json_obj args)
546
-
~method_call_id:call_id
547
-
in
548
-
record_invocation inv state;
549
-
Changes_handle { call_id; method_name = "Thread/changes" }
550
-
551
-
let mailbox_query ~account_id ?filter ?sort ?position ?anchor ?anchor_offset
552
-
?limit ?calculate_total () state =
553
-
let call_id = fresh_call_id state in
554
-
let args = build_query_args ~account_id ?filter
555
-
~filter_jsont:Mail_filter.mailbox_filter_jsont
556
-
?sort ?position ?anchor ?anchor_offset ?limit ?calculate_total () in
557
-
let inv = Invocation.create
558
-
~name:"Mailbox/query"
559
-
~arguments:(json_obj args)
560
-
~method_call_id:call_id
561
-
in
562
-
record_invocation inv state;
563
-
Query_handle { call_id; method_name = "Mailbox/query" }
564
-
565
-
let mailbox_get ~account_id ?ids ?properties () state =
566
-
let call_id = fresh_call_id state in
567
-
let args = [ ("accountId", json_of_id account_id) ] in
568
-
let args = add_ids_arg args ids in
569
-
let args = match properties with
570
-
| None -> args
571
-
| Some props -> ("properties", json_of_string_list props) :: args
572
-
in
573
-
let inv = Invocation.create
574
-
~name:"Mailbox/get"
575
-
~arguments:(json_obj args)
576
-
~method_call_id:call_id
577
-
in
578
-
record_invocation inv state;
579
-
Mailbox_get_handle { call_id; method_name = "Mailbox/get" }
580
-
581
-
let mailbox_changes ~account_id ~since_state ?max_changes () state =
582
-
let call_id = fresh_call_id state in
583
-
let args = build_changes_args ~account_id ~since_state ?max_changes () in
584
-
let inv = Invocation.create
585
-
~name:"Mailbox/changes"
586
-
~arguments:(json_obj args)
587
-
~method_call_id:call_id
588
-
in
589
-
record_invocation inv state;
590
-
Changes_handle { call_id; method_name = "Mailbox/changes" }
591
-
592
-
let mailbox_query_changes ~account_id ~since_query_state ?filter ?sort
593
-
?max_changes ?up_to_id ?calculate_total () state =
594
-
let call_id = fresh_call_id state in
595
-
let args = build_query_changes_args ~account_id ~since_query_state
596
-
?filter ~filter_jsont:Mail_filter.mailbox_filter_jsont
597
-
?sort ?max_changes ?up_to_id ?calculate_total () in
598
-
let inv = Invocation.create
599
-
~name:"Mailbox/queryChanges"
600
-
~arguments:(json_obj args)
601
-
~method_call_id:call_id
602
-
in
603
-
record_invocation inv state;
604
-
Query_changes_handle { call_id; method_name = "Mailbox/queryChanges" }
605
-
606
-
let mailbox_set ~account_id ?if_in_state ?create ?update ?destroy
607
-
?on_destroy_remove_emails () state =
608
-
let call_id = fresh_call_id state in
609
-
let args = build_set_args ~account_id ?if_in_state ?create ?update ?destroy () in
610
-
let args = match on_destroy_remove_emails with
611
-
| None -> args
612
-
| Some b -> ("onDestroyRemoveEmails", json_bool b) :: args
613
-
in
614
-
let inv = Invocation.create
615
-
~name:"Mailbox/set"
616
-
~arguments:(json_obj args)
617
-
~method_call_id:call_id
618
-
in
619
-
record_invocation inv state;
620
-
Mailbox_set_handle { call_id; method_name = "Mailbox/set" }
621
-
622
-
let identity_get ~account_id ?ids ?properties () state =
623
-
let call_id = fresh_call_id state in
624
-
let args = [ ("accountId", json_of_id account_id) ] in
625
-
let args = add_ids_arg args ids in
626
-
let args = match properties with
627
-
| None -> args
628
-
| Some props -> ("properties", json_of_string_list props) :: args
629
-
in
630
-
let inv = Invocation.create
631
-
~name:"Identity/get"
632
-
~arguments:(json_obj args)
633
-
~method_call_id:call_id
634
-
in
635
-
record_invocation inv state;
636
-
Identity_get_handle { call_id; method_name = "Identity/get" }
637
-
638
-
let identity_changes ~account_id ~since_state ?max_changes () state =
639
-
let call_id = fresh_call_id state in
640
-
let args = build_changes_args ~account_id ~since_state ?max_changes () in
641
-
let inv = Invocation.create
642
-
~name:"Identity/changes"
643
-
~arguments:(json_obj args)
644
-
~method_call_id:call_id
645
-
in
646
-
record_invocation inv state;
647
-
Changes_handle { call_id; method_name = "Identity/changes" }
648
-
649
-
let identity_set ~account_id ?if_in_state ?create ?update ?destroy () state =
650
-
let call_id = fresh_call_id state in
651
-
let args = build_set_args ~account_id ?if_in_state ?create ?update ?destroy () in
652
-
let inv = Invocation.create
653
-
~name:"Identity/set"
654
-
~arguments:(json_obj args)
655
-
~method_call_id:call_id
656
-
in
657
-
record_invocation inv state;
658
-
Identity_set_handle { call_id; method_name = "Identity/set" }
659
-
660
-
let email_submission_query ~account_id ?filter ?sort ?position ?anchor
661
-
?anchor_offset ?limit ?calculate_total () state =
662
-
let call_id = fresh_call_id state in
663
-
let args = build_query_args ~account_id ?filter
664
-
~filter_jsont:Mail_filter.submission_filter_jsont
665
-
?sort ?position ?anchor ?anchor_offset ?limit ?calculate_total () in
666
-
let inv = Invocation.create
667
-
~name:"EmailSubmission/query"
668
-
~arguments:(json_obj args)
669
-
~method_call_id:call_id
670
-
in
671
-
record_invocation inv state;
672
-
Query_handle { call_id; method_name = "EmailSubmission/query" }
673
-
674
-
let email_submission_get ~account_id ?ids ?properties () state =
675
-
let call_id = fresh_call_id state in
676
-
let args = [ ("accountId", json_of_id account_id) ] in
677
-
let args = add_ids_arg args ids in
678
-
let args = match properties with
679
-
| None -> args
680
-
| Some props -> ("properties", json_of_string_list props) :: args
681
-
in
682
-
let inv = Invocation.create
683
-
~name:"EmailSubmission/get"
684
-
~arguments:(json_obj args)
685
-
~method_call_id:call_id
686
-
in
687
-
record_invocation inv state;
688
-
Submission_get_handle { call_id; method_name = "EmailSubmission/get" }
689
-
690
-
let email_submission_changes ~account_id ~since_state ?max_changes () state =
691
-
let call_id = fresh_call_id state in
692
-
let args = build_changes_args ~account_id ~since_state ?max_changes () in
693
-
let inv = Invocation.create
694
-
~name:"EmailSubmission/changes"
695
-
~arguments:(json_obj args)
696
-
~method_call_id:call_id
697
-
in
698
-
record_invocation inv state;
699
-
Changes_handle { call_id; method_name = "EmailSubmission/changes" }
700
-
701
-
let email_submission_query_changes ~account_id ~since_query_state ?filter ?sort
702
-
?max_changes ?up_to_id ?calculate_total () state =
703
-
let call_id = fresh_call_id state in
704
-
let args = build_query_changes_args ~account_id ~since_query_state
705
-
?filter ~filter_jsont:Mail_filter.submission_filter_jsont
706
-
?sort ?max_changes ?up_to_id ?calculate_total () in
707
-
let inv = Invocation.create
708
-
~name:"EmailSubmission/queryChanges"
709
-
~arguments:(json_obj args)
710
-
~method_call_id:call_id
711
-
in
712
-
record_invocation inv state;
713
-
Query_changes_handle { call_id; method_name = "EmailSubmission/queryChanges" }
714
-
715
-
let email_submission_set ~account_id ?if_in_state ?create ?update ?destroy
716
-
?on_success_update_email ?on_success_destroy_email () state =
717
-
let call_id = fresh_call_id state in
718
-
let args = build_set_args ~account_id ?if_in_state ?create ?update ?destroy () in
719
-
let args = match on_success_update_email with
720
-
| None | Some [] -> args
721
-
| Some items ->
722
-
let update_map = json_map items in
723
-
("onSuccessUpdateEmail", update_map) :: args
724
-
in
725
-
let args = match on_success_destroy_email with
726
-
| None | Some [] -> args
727
-
| Some ids ->
728
-
("onSuccessDestroyEmail", json_of_string_list ids) :: args
729
-
in
730
-
let inv = Invocation.create
731
-
~name:"EmailSubmission/set"
732
-
~arguments:(json_obj args)
733
-
~method_call_id:call_id
734
-
in
735
-
record_invocation inv state;
736
-
Submission_set_handle { call_id; method_name = "EmailSubmission/set" }
737
-
738
-
let search_snippet_get ~account_id ~filter ~email_ids () state =
739
-
let call_id = fresh_call_id state in
740
-
let args = [ ("accountId", json_of_id account_id) ] in
741
-
let args = ("filter", encode_to_json Mail_filter.email_filter_jsont filter) :: args in
742
-
let args = match email_ids with
743
-
| Ids ids -> ("emailIds", json_of_id_list ids) :: args
744
-
| Ref ref_ ->
745
-
let ref_json = encode_to_json Invocation.result_reference_jsont ref_ in
746
-
("#emailIds", ref_json) :: args
747
-
in
748
-
let inv = Invocation.create
749
-
~name:"SearchSnippet/get"
750
-
~arguments:(json_obj args)
751
-
~method_call_id:call_id
752
-
in
753
-
record_invocation inv state;
754
-
Search_snippet_get_handle { call_id; method_name = "SearchSnippet/get" }
755
-
756
-
let vacation_response_get ~account_id ?properties () state =
757
-
let call_id = fresh_call_id state in
758
-
let args = [ ("accountId", json_of_id account_id) ] in
759
-
let args = match properties with
760
-
| None -> args
761
-
| Some props -> ("properties", json_of_string_list props) :: args
762
-
in
763
-
let inv = Invocation.create
764
-
~name:"VacationResponse/get"
765
-
~arguments:(json_obj args)
766
-
~method_call_id:call_id
767
-
in
768
-
record_invocation inv state;
769
-
Vacation_get_handle { call_id; method_name = "VacationResponse/get" }
770
-
771
-
let vacation_response_set ~account_id ?if_in_state ~update () state =
772
-
let call_id = fresh_call_id state in
773
-
let args = [ ("accountId", json_of_id account_id) ] in
774
-
let args = match if_in_state with
775
-
| None -> args
776
-
| Some s -> ("ifInState", json_string s) :: args
777
-
in
778
-
let args = ("update", json_map [("singleton", update)]) :: args in
779
-
let inv = Invocation.create
780
-
~name:"VacationResponse/set"
781
-
~arguments:(json_obj args)
782
-
~method_call_id:call_id
783
-
in
784
-
record_invocation inv state;
785
-
Vacation_set_handle { call_id; method_name = "VacationResponse/set" }
786
-
787
-
let raw_invocation ~name ~arguments state =
788
-
let call_id = fresh_call_id state in
789
-
let inv = Invocation.create
790
-
~name
791
-
~arguments
792
-
~method_call_id:call_id
793
-
in
794
-
record_invocation inv state;
795
-
Raw_handle { call_id; method_name = name }
796
-
797
-
(* Response parsing *)
798
-
799
-
let find_invocation ~call_id response =
800
-
List.find_opt
801
-
(fun inv -> Invocation.method_call_id inv = call_id)
802
-
(Response.method_responses response)
803
-
804
-
let parse : type k r. (k, r) handle -> Response.t -> (r, Jsont.Error.t) result =
805
-
fun handle response ->
806
-
let cid = call_id handle in
807
-
match find_invocation ~call_id:cid response with
808
-
| None ->
809
-
Error (Jsont.Error.msgf Jsont.Meta.none "No response found for call_id: %s" cid)
810
-
| Some inv ->
811
-
let args = Invocation.arguments inv in
812
-
match handle with
813
-
| Query_handle _ ->
814
-
Jsont.Json.decode' Method.query_response_jsont args
815
-
| Query_changes_handle _ ->
816
-
Jsont.Json.decode' Method.query_changes_response_jsont args
817
-
| Email_get_handle _ ->
818
-
Jsont.Json.decode' (Method.get_response_jsont Email.jsont) args
819
-
| Thread_get_handle _ ->
820
-
Jsont.Json.decode' (Method.get_response_jsont Thread.jsont) args
821
-
| Mailbox_get_handle _ ->
822
-
Jsont.Json.decode' (Method.get_response_jsont Mailbox.jsont) args
823
-
| Identity_get_handle _ ->
824
-
Jsont.Json.decode' (Method.get_response_jsont Identity.jsont) args
825
-
| Submission_get_handle _ ->
826
-
Jsont.Json.decode' (Method.get_response_jsont Submission.jsont) args
827
-
| Search_snippet_get_handle _ ->
828
-
Jsont.Json.decode' (Method.get_response_jsont Search_snippet.jsont) args
829
-
| Vacation_get_handle _ ->
830
-
Jsont.Json.decode' (Method.get_response_jsont Vacation.jsont) args
831
-
| Changes_handle _ ->
832
-
Jsont.Json.decode' Method.changes_response_jsont args
833
-
| Email_set_handle _ ->
834
-
Jsont.Json.decode' (Method.set_response_jsont Email.jsont) args
835
-
| Mailbox_set_handle _ ->
836
-
Jsont.Json.decode' (Method.set_response_jsont Mailbox.jsont) args
837
-
| Identity_set_handle _ ->
838
-
Jsont.Json.decode' (Method.set_response_jsont Identity.jsont) args
839
-
| Submission_set_handle _ ->
840
-
Jsont.Json.decode' (Method.set_response_jsont Submission.jsont) args
841
-
| Vacation_set_handle _ ->
842
-
Jsont.Json.decode' (Method.set_response_jsont Vacation.jsont) args
843
-
| Email_copy_handle _ ->
844
-
Jsont.Json.decode' (Method.copy_response_jsont Email.jsont) args
845
-
| Raw_handle _ ->
846
-
Ok args
847
-
848
-
let parse_exn handle response =
849
-
match parse handle response with
850
-
| Ok r -> r
851
-
| Error e -> failwith (Jsont.Error.to_string e)
-556
lib/core/chain.mli
-556
lib/core/chain.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP method chaining with automatic result references.
7
-
8
-
This module provides a monadic interface for building JMAP requests
9
-
where method calls can reference results from previous calls in the
10
-
same request. Call IDs are generated automatically.
11
-
12
-
{2 Basic Example}
13
-
14
-
Query for emails and fetch their details in a single request:
15
-
{[
16
-
let open Jmap.Chain in
17
-
let request, emails = build ~capabilities:[core; mail] begin
18
-
let* query = email_query ~account_id
19
-
~filter:(Condition { in_mailbox = Some inbox_id; _ })
20
-
~limit:50L ()
21
-
in
22
-
let* emails = email_get ~account_id
23
-
~ids:(from_query query)
24
-
~properties:["subject"; "from"; "receivedAt"]
25
-
()
26
-
in
27
-
return emails
28
-
end in
29
-
match Client.request client request with
30
-
| Ok response ->
31
-
let emails = parse emails response in
32
-
...
33
-
]}
34
-
35
-
{2 Creation and Submission}
36
-
37
-
Create a draft email and submit it in one request:
38
-
{[
39
-
let* set_h, draft_cid = email_set ~account_id
40
-
~create:[email_create ~mailbox_ids:[drafts_id] ~subject:"Hello" ...]
41
-
()
42
-
in
43
-
let* _ = email_submission_set ~account_id
44
-
~create:[submission_create
45
-
~email_id:(created_id draft_cid)
46
-
~identity_id]
47
-
()
48
-
in
49
-
return set_h
50
-
]}
51
-
52
-
{2 Multi-step Chains}
53
-
54
-
The RFC 8620 example - fetch from/date/subject for all emails in
55
-
the first 10 threads in the inbox:
56
-
{[
57
-
let* q = email_query ~account_id
58
-
~filter:(Condition { in_mailbox = Some inbox_id; _ })
59
-
~sort:[comparator ~is_ascending:false "receivedAt"]
60
-
~collapse_threads:true ~limit:10L ()
61
-
in
62
-
let* e1 = email_get ~account_id
63
-
~ids:(from_query q)
64
-
~properties:["threadId"]
65
-
()
66
-
in
67
-
let* threads = thread_get ~account_id
68
-
~ids:(from_get_field e1 "threadId")
69
-
()
70
-
in
71
-
let* e2 = email_get ~account_id
72
-
~ids:(from_get_field threads "emailIds")
73
-
~properties:["from"; "receivedAt"; "subject"]
74
-
()
75
-
in
76
-
return e2
77
-
]} *)
78
-
79
-
(** {1 Handles}
80
-
81
-
Method invocations return handles that encode both the method kind
82
-
(for building result references) and the exact response type
83
-
(for type-safe parsing). *)
84
-
85
-
(** Phantom type for query method handles. *)
86
-
type query
87
-
88
-
(** Phantom type for get method handles. *)
89
-
type get
90
-
91
-
(** Phantom type for changes method handles. *)
92
-
type changes
93
-
94
-
(** Phantom type for set method handles. *)
95
-
type set
96
-
97
-
(** Phantom type for query_changes method handles. *)
98
-
type query_changes
99
-
100
-
(** Phantom type for copy method handles. *)
101
-
type copy
102
-
103
-
(** Phantom type for import method handles. *)
104
-
type import
105
-
106
-
(** Phantom type for parse method handles. *)
107
-
type parse
108
-
109
-
(** A handle to a method invocation.
110
-
111
-
The first type parameter indicates the method kind (query/get/changes/set/...),
112
-
used for building result references. The second type parameter is the
113
-
parsed response type, enabling type-safe parsing via {!parse}. *)
114
-
type (_, _) handle
115
-
116
-
val call_id : (_, _) handle -> string
117
-
(** [call_id h] returns the auto-generated call ID for this invocation. *)
118
-
119
-
val method_name : (_, _) handle -> string
120
-
(** [method_name h] returns the method name (e.g., "Email/query"). *)
121
-
122
-
(** {1 Creation IDs}
123
-
124
-
When creating objects via [/set] methods, you can reference the
125
-
server-assigned ID before the request completes using creation IDs. *)
126
-
127
-
type 'a create_id
128
-
(** A creation ID for an object of type ['a]. Used to reference
129
-
newly created objects within the same request. *)
130
-
131
-
val created_id : _ create_id -> Jmap_proto.Id.t
132
-
(** [created_id cid] returns a placeholder ID (["#cN"]) that the server
133
-
will substitute with the real ID. Use this to reference a created
134
-
object in subsequent method calls within the same request. *)
135
-
136
-
val created_id_of_string : string -> Jmap_proto.Id.t
137
-
(** [created_id_of_string s] returns a placeholder ID for a string creation ID.
138
-
For example, [created_id_of_string "draft1"] returns ["#draft1"]. *)
139
-
140
-
(** {1 ID Sources}
141
-
142
-
Methods that accept IDs can take them either as concrete values
143
-
or as references to results from previous method calls. *)
144
-
145
-
type id_source =
146
-
| Ids of Jmap_proto.Id.t list
147
-
(** Concrete list of IDs. *)
148
-
| Ref of Jmap_proto.Invocation.result_reference
149
-
(** Back-reference to a previous method's result. *)
150
-
151
-
val ids : Jmap_proto.Id.t list -> id_source
152
-
(** [ids lst] provides concrete IDs. *)
153
-
154
-
val id : Jmap_proto.Id.t -> id_source
155
-
(** [id x] provides a single concrete ID. *)
156
-
157
-
(** {2 References from Query} *)
158
-
159
-
val from_query : (query, _) handle -> id_source
160
-
(** [from_query h] references [/ids] from a query response. *)
161
-
162
-
(** {2 References from Get} *)
163
-
164
-
val from_get_ids : (get, _) handle -> id_source
165
-
(** [from_get_ids h] references [/list/*/id] from a get response. *)
166
-
167
-
val from_get_field : (get, _) handle -> string -> id_source
168
-
(** [from_get_field h field] references [/list/*/field] from a get response.
169
-
Common fields: ["threadId"], ["emailIds"], ["mailboxIds"]. *)
170
-
171
-
(** {2 References from Changes} *)
172
-
173
-
val from_changes_created : (changes, _) handle -> id_source
174
-
(** [from_changes_created h] references [/created] from a changes response. *)
175
-
176
-
val from_changes_updated : (changes, _) handle -> id_source
177
-
(** [from_changes_updated h] references [/updated] from a changes response. *)
178
-
179
-
val from_changes_destroyed : (changes, _) handle -> id_source
180
-
(** [from_changes_destroyed h] references [/destroyed] from a changes response. *)
181
-
182
-
(** {2 References from Set} *)
183
-
184
-
val from_set_created : (set, _) handle -> id_source
185
-
(** [from_set_created h] references [/created/*/id] - IDs of objects created
186
-
by a set operation. *)
187
-
188
-
val from_set_updated : (set, _) handle -> id_source
189
-
(** [from_set_updated h] references [/updated] - IDs of objects updated. *)
190
-
191
-
(** {2 References from QueryChanges} *)
192
-
193
-
val from_query_changes_removed : (query_changes, _) handle -> id_source
194
-
(** [from_query_changes_removed h] references [/removed] from queryChanges. *)
195
-
196
-
val from_query_changes_added : (query_changes, _) handle -> id_source
197
-
(** [from_query_changes_added h] references [/added/*/id] from queryChanges. *)
198
-
199
-
(** {2 References from Copy} *)
200
-
201
-
val from_copy_created : (copy, _) handle -> id_source
202
-
(** [from_copy_created h] references [/created/*/id] from copy response. *)
203
-
204
-
(** {2 References from Import} *)
205
-
206
-
val from_import_created : (import, _) handle -> id_source
207
-
(** [from_import_created h] references [/created/*/id] from import response. *)
208
-
209
-
(** {1 Chain Monad}
210
-
211
-
A monad for building JMAP requests with automatic call ID generation
212
-
and invocation collection. *)
213
-
214
-
type 'a t
215
-
(** A chain computation that produces ['a] (typically a handle). *)
216
-
217
-
val return : 'a -> 'a t
218
-
(** [return x] is a computation that produces [x] without adding any
219
-
method invocations. *)
220
-
221
-
val bind : 'a t -> ('a -> 'b t) -> 'b t
222
-
(** [bind m f] sequences computations, threading the chain state. *)
223
-
224
-
val map : ('a -> 'b) -> 'a t -> 'b t
225
-
(** [map f m] applies [f] to the result of [m]. *)
226
-
227
-
val both : 'a t -> 'b t -> ('a * 'b) t
228
-
(** [both a b] runs both computations, returning their results as a pair. *)
229
-
230
-
(** {2 Syntax} *)
231
-
232
-
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
233
-
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
234
-
val ( and* ) : 'a t -> 'b t -> ('a * 'b) t
235
-
val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t
236
-
237
-
(** {1 Building Requests} *)
238
-
239
-
val build :
240
-
capabilities:string list ->
241
-
'a t ->
242
-
Jmap_proto.Request.t * 'a
243
-
(** [build ~capabilities chain] runs the chain computation, returning
244
-
the JMAP request and the final value (typically a handle for parsing). *)
245
-
246
-
val build_request :
247
-
capabilities:string list ->
248
-
'a t ->
249
-
Jmap_proto.Request.t
250
-
(** [build_request ~capabilities chain] is like {!build} but discards
251
-
the final value. *)
252
-
253
-
(** {1 Method Builders}
254
-
255
-
Each builder returns a handle wrapped in the chain monad.
256
-
Call IDs are assigned automatically based on invocation order. *)
257
-
258
-
(** {2 Email Methods} *)
259
-
260
-
val email_query :
261
-
account_id:Jmap_proto.Id.t ->
262
-
?filter:Jmap_proto.Mail_filter.email_filter ->
263
-
?sort:Jmap_proto.Filter.comparator list ->
264
-
?position:int64 ->
265
-
?anchor:Jmap_proto.Id.t ->
266
-
?anchor_offset:int64 ->
267
-
?limit:int64 ->
268
-
?calculate_total:bool ->
269
-
?collapse_threads:bool ->
270
-
unit ->
271
-
(query, Jmap_proto.Method.query_response) handle t
272
-
273
-
val email_get :
274
-
account_id:Jmap_proto.Id.t ->
275
-
?ids:id_source ->
276
-
?properties:string list ->
277
-
?body_properties:string list ->
278
-
?fetch_text_body_values:bool ->
279
-
?fetch_html_body_values:bool ->
280
-
?fetch_all_body_values:bool ->
281
-
?max_body_value_bytes:int64 ->
282
-
unit ->
283
-
(get, Jmap_proto.Email.t Jmap_proto.Method.get_response) handle t
284
-
285
-
val email_changes :
286
-
account_id:Jmap_proto.Id.t ->
287
-
since_state:string ->
288
-
?max_changes:int64 ->
289
-
unit ->
290
-
(changes, Jmap_proto.Method.changes_response) handle t
291
-
292
-
val email_query_changes :
293
-
account_id:Jmap_proto.Id.t ->
294
-
since_query_state:string ->
295
-
?filter:Jmap_proto.Mail_filter.email_filter ->
296
-
?sort:Jmap_proto.Filter.comparator list ->
297
-
?max_changes:int64 ->
298
-
?up_to_id:Jmap_proto.Id.t ->
299
-
?calculate_total:bool ->
300
-
unit ->
301
-
(query_changes, Jmap_proto.Method.query_changes_response) handle t
302
-
303
-
val email_set :
304
-
account_id:Jmap_proto.Id.t ->
305
-
?if_in_state:string ->
306
-
?create:(string * Jsont.Json.t) list ->
307
-
?update:(Jmap_proto.Id.t * Jsont.Json.t) list ->
308
-
?destroy:id_source ->
309
-
unit ->
310
-
(set, Jmap_proto.Email.t Jmap_proto.Method.set_response) handle t
311
-
(** Build an Email/set invocation.
312
-
313
-
[create] is a list of [(creation_id, email_object)] pairs where
314
-
[creation_id] is a client-chosen string (e.g., "draft1") and
315
-
[email_object] is the JSON representation of the email to create.
316
-
317
-
Use {!created_id_of_string} to reference created objects in later calls. *)
318
-
319
-
val email_copy :
320
-
from_account_id:Jmap_proto.Id.t ->
321
-
account_id:Jmap_proto.Id.t ->
322
-
?if_from_in_state:string ->
323
-
?if_in_state:string ->
324
-
?create:(Jmap_proto.Id.t * Jsont.Json.t) list ->
325
-
?on_success_destroy_original:bool ->
326
-
?destroy_from_if_in_state:string ->
327
-
unit ->
328
-
(copy, Jmap_proto.Email.t Jmap_proto.Method.copy_response) handle t
329
-
(** Build an Email/copy invocation.
330
-
331
-
[create] maps source email IDs to override objects. The source email
332
-
is copied to the target account with any overridden properties. *)
333
-
334
-
(** {2 Thread Methods} *)
335
-
336
-
val thread_get :
337
-
account_id:Jmap_proto.Id.t ->
338
-
?ids:id_source ->
339
-
unit ->
340
-
(get, Jmap_proto.Thread.t Jmap_proto.Method.get_response) handle t
341
-
342
-
val thread_changes :
343
-
account_id:Jmap_proto.Id.t ->
344
-
since_state:string ->
345
-
?max_changes:int64 ->
346
-
unit ->
347
-
(changes, Jmap_proto.Method.changes_response) handle t
348
-
349
-
(** {2 Mailbox Methods} *)
350
-
351
-
val mailbox_query :
352
-
account_id:Jmap_proto.Id.t ->
353
-
?filter:Jmap_proto.Mail_filter.mailbox_filter ->
354
-
?sort:Jmap_proto.Filter.comparator list ->
355
-
?position:int64 ->
356
-
?anchor:Jmap_proto.Id.t ->
357
-
?anchor_offset:int64 ->
358
-
?limit:int64 ->
359
-
?calculate_total:bool ->
360
-
unit ->
361
-
(query, Jmap_proto.Method.query_response) handle t
362
-
363
-
val mailbox_get :
364
-
account_id:Jmap_proto.Id.t ->
365
-
?ids:id_source ->
366
-
?properties:string list ->
367
-
unit ->
368
-
(get, Jmap_proto.Mailbox.t Jmap_proto.Method.get_response) handle t
369
-
370
-
val mailbox_changes :
371
-
account_id:Jmap_proto.Id.t ->
372
-
since_state:string ->
373
-
?max_changes:int64 ->
374
-
unit ->
375
-
(changes, Jmap_proto.Method.changes_response) handle t
376
-
377
-
val mailbox_query_changes :
378
-
account_id:Jmap_proto.Id.t ->
379
-
since_query_state:string ->
380
-
?filter:Jmap_proto.Mail_filter.mailbox_filter ->
381
-
?sort:Jmap_proto.Filter.comparator list ->
382
-
?max_changes:int64 ->
383
-
?up_to_id:Jmap_proto.Id.t ->
384
-
?calculate_total:bool ->
385
-
unit ->
386
-
(query_changes, Jmap_proto.Method.query_changes_response) handle t
387
-
388
-
val mailbox_set :
389
-
account_id:Jmap_proto.Id.t ->
390
-
?if_in_state:string ->
391
-
?create:(string * Jsont.Json.t) list ->
392
-
?update:(Jmap_proto.Id.t * Jsont.Json.t) list ->
393
-
?destroy:id_source ->
394
-
?on_destroy_remove_emails:bool ->
395
-
unit ->
396
-
(set, Jmap_proto.Mailbox.t Jmap_proto.Method.set_response) handle t
397
-
398
-
(** {2 Identity Methods} *)
399
-
400
-
val identity_get :
401
-
account_id:Jmap_proto.Id.t ->
402
-
?ids:id_source ->
403
-
?properties:string list ->
404
-
unit ->
405
-
(get, Jmap_proto.Identity.t Jmap_proto.Method.get_response) handle t
406
-
407
-
val identity_changes :
408
-
account_id:Jmap_proto.Id.t ->
409
-
since_state:string ->
410
-
?max_changes:int64 ->
411
-
unit ->
412
-
(changes, Jmap_proto.Method.changes_response) handle t
413
-
414
-
val identity_set :
415
-
account_id:Jmap_proto.Id.t ->
416
-
?if_in_state:string ->
417
-
?create:(string * Jsont.Json.t) list ->
418
-
?update:(Jmap_proto.Id.t * Jsont.Json.t) list ->
419
-
?destroy:id_source ->
420
-
unit ->
421
-
(set, Jmap_proto.Identity.t Jmap_proto.Method.set_response) handle t
422
-
423
-
(** {2 EmailSubmission Methods} *)
424
-
425
-
val email_submission_query :
426
-
account_id:Jmap_proto.Id.t ->
427
-
?filter:Jmap_proto.Mail_filter.submission_filter ->
428
-
?sort:Jmap_proto.Filter.comparator list ->
429
-
?position:int64 ->
430
-
?anchor:Jmap_proto.Id.t ->
431
-
?anchor_offset:int64 ->
432
-
?limit:int64 ->
433
-
?calculate_total:bool ->
434
-
unit ->
435
-
(query, Jmap_proto.Method.query_response) handle t
436
-
437
-
val email_submission_get :
438
-
account_id:Jmap_proto.Id.t ->
439
-
?ids:id_source ->
440
-
?properties:string list ->
441
-
unit ->
442
-
(get, Jmap_proto.Submission.t Jmap_proto.Method.get_response) handle t
443
-
444
-
val email_submission_changes :
445
-
account_id:Jmap_proto.Id.t ->
446
-
since_state:string ->
447
-
?max_changes:int64 ->
448
-
unit ->
449
-
(changes, Jmap_proto.Method.changes_response) handle t
450
-
451
-
val email_submission_query_changes :
452
-
account_id:Jmap_proto.Id.t ->
453
-
since_query_state:string ->
454
-
?filter:Jmap_proto.Mail_filter.submission_filter ->
455
-
?sort:Jmap_proto.Filter.comparator list ->
456
-
?max_changes:int64 ->
457
-
?up_to_id:Jmap_proto.Id.t ->
458
-
?calculate_total:bool ->
459
-
unit ->
460
-
(query_changes, Jmap_proto.Method.query_changes_response) handle t
461
-
462
-
val email_submission_set :
463
-
account_id:Jmap_proto.Id.t ->
464
-
?if_in_state:string ->
465
-
?create:(string * Jsont.Json.t) list ->
466
-
?update:(Jmap_proto.Id.t * Jsont.Json.t) list ->
467
-
?destroy:id_source ->
468
-
?on_success_update_email:(string * Jsont.Json.t) list ->
469
-
?on_success_destroy_email:string list ->
470
-
unit ->
471
-
(set, Jmap_proto.Submission.t Jmap_proto.Method.set_response) handle t
472
-
(** Build an EmailSubmission/set invocation.
473
-
474
-
[on_success_update_email] and [on_success_destroy_email] take creation IDs
475
-
(like ["#draft1"]) or real email IDs to update/destroy the email after
476
-
successful submission. *)
477
-
478
-
(** {2 SearchSnippet Methods} *)
479
-
480
-
val search_snippet_get :
481
-
account_id:Jmap_proto.Id.t ->
482
-
filter:Jmap_proto.Mail_filter.email_filter ->
483
-
email_ids:id_source ->
484
-
unit ->
485
-
(get, Jmap_proto.Search_snippet.t Jmap_proto.Method.get_response) handle t
486
-
(** Build a SearchSnippet/get invocation. Note that the filter must match
487
-
the filter used in the Email/query that produced the email IDs. *)
488
-
489
-
(** {2 VacationResponse Methods} *)
490
-
491
-
val vacation_response_get :
492
-
account_id:Jmap_proto.Id.t ->
493
-
?properties:string list ->
494
-
unit ->
495
-
(get, Jmap_proto.Vacation.t Jmap_proto.Method.get_response) handle t
496
-
497
-
val vacation_response_set :
498
-
account_id:Jmap_proto.Id.t ->
499
-
?if_in_state:string ->
500
-
update:Jsont.Json.t ->
501
-
unit ->
502
-
(set, Jmap_proto.Vacation.t Jmap_proto.Method.set_response) handle t
503
-
(** VacationResponse is a singleton - you can only update "singleton". *)
504
-
505
-
(** {1 Response Parsing} *)
506
-
507
-
val parse :
508
-
(_, 'resp) handle ->
509
-
Jmap_proto.Response.t ->
510
-
('resp, Jsont.Error.t) result
511
-
(** [parse handle response] extracts and parses the response for [handle].
512
-
513
-
The response type is determined by the handle's type parameter,
514
-
providing compile-time type safety. *)
515
-
516
-
val parse_exn : (_, 'resp) handle -> Jmap_proto.Response.t -> 'resp
517
-
(** [parse_exn handle response] is like {!parse} but raises on error. *)
518
-
519
-
(** {1 JSON Helpers}
520
-
521
-
Convenience functions for building JSON patch objects for /set methods. *)
522
-
523
-
val json_null : Jsont.Json.t
524
-
(** A JSON null value. Use to unset a property. *)
525
-
526
-
val json_bool : bool -> Jsont.Json.t
527
-
(** [json_bool b] creates a JSON boolean. *)
528
-
529
-
val json_string : string -> Jsont.Json.t
530
-
(** [json_string s] creates a JSON string. *)
531
-
532
-
val json_int : int64 -> Jsont.Json.t
533
-
(** [json_int n] creates a JSON number from an int64. *)
534
-
535
-
val json_obj : (string * Jsont.Json.t) list -> Jsont.Json.t
536
-
(** [json_obj fields] creates a JSON object from key-value pairs. *)
537
-
538
-
val json_array : Jsont.Json.t list -> Jsont.Json.t
539
-
(** [json_array items] creates a JSON array. *)
540
-
541
-
(** {1 Creation ID Helpers} *)
542
-
543
-
val fresh_create_id : unit -> 'a create_id t
544
-
(** [fresh_create_id ()] generates a fresh creation ID within the chain.
545
-
The ID is unique within the request. *)
546
-
547
-
(** {1 Low-Level Access}
548
-
549
-
For users who need direct access to the underlying invocation. *)
550
-
551
-
val raw_invocation :
552
-
name:string ->
553
-
arguments:Jsont.Json.t ->
554
-
(unit, Jsont.Json.t) handle t
555
-
(** [raw_invocation ~name ~arguments] adds a raw method invocation.
556
-
Use this for methods not yet supported by the high-level API. *)
-446
lib/core/jmap.ml
-446
lib/core/jmap.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Unified JMAP interface for OCaml
7
-
8
-
This module provides a clean, ergonomic API for working with JMAP
9
-
(RFC 8620/8621), combining the protocol and mail layers with abstract
10
-
types and polymorphic variants.
11
-
12
-
{2 Quick Start}
13
-
14
-
{[
15
-
open Jmap
16
-
17
-
(* Keywords use polymorphic variants *)
18
-
let is_unread email =
19
-
not (List.mem `Seen (Email.keywords email))
20
-
21
-
(* Mailbox roles are also polymorphic *)
22
-
let find_inbox mailboxes =
23
-
List.find_opt (fun m -> Mailbox.role m = Some `Inbox) mailboxes
24
-
]}
25
-
26
-
{2 Module Structure}
27
-
28
-
- {!Proto} - Low-level protocol and mail types (RFC 8620/8621)
29
-
- {!Error}, {!Id}, {!Keyword}, {!Role}, {!Capability} - Core types
30
-
- {!Session}, {!Email}, {!Mailbox}, etc. - Abstract type accessors
31
-
*)
32
-
33
-
(** {1 Protocol Layer Re-exports} *)
34
-
35
-
(** Low-level JMAP protocol types (RFC 8620/8621).
36
-
37
-
These are the raw protocol and mail types. For most use cases, prefer the
38
-
higher-level types in this module. *)
39
-
module Proto = Jmap_proto
40
-
41
-
(** {1 Core Types} *)
42
-
43
-
(** Unified error type for JMAP operations.
44
-
45
-
All errors from JSON parsing, HTTP, session management, and JMAP method
46
-
calls are represented as polymorphic variants. *)
47
-
module Error = Jmap_types.Error
48
-
49
-
(** JMAP identifier type.
50
-
51
-
Identifiers are opaque strings assigned by the server. *)
52
-
module Id = Jmap_types.Id
53
-
54
-
(** Email keyword type.
55
-
56
-
Standard keywords are represented as polymorphic variants.
57
-
Custom keywords use [`Custom of string]. *)
58
-
module Keyword = Jmap_types.Keyword
59
-
60
-
(** Mailbox role type.
61
-
62
-
Standard roles are represented as polymorphic variants.
63
-
Custom roles use [`Custom of string]. *)
64
-
module Role = Jmap_types.Role
65
-
66
-
(** JMAP capability type.
67
-
68
-
Standard capabilities are represented as polymorphic variants.
69
-
Custom capabilities use [`Custom of string]. *)
70
-
module Capability = Jmap_types.Capability
71
-
72
-
(** {1 Session Types} *)
73
-
74
-
(** JMAP session information.
75
-
76
-
The session contains server capabilities, account information,
77
-
and API endpoint URLs. *)
78
-
module Session = struct
79
-
(** Account information. *)
80
-
module Account = struct
81
-
type t = Jmap_types.account
82
-
83
-
let name a = Proto.Session.Account.name a
84
-
let is_personal a = Proto.Session.Account.is_personal a
85
-
let is_read_only a = Proto.Session.Account.is_read_only a
86
-
end
87
-
88
-
type t = Jmap_types.session
89
-
90
-
let capabilities s = Proto.Session.capabilities s
91
-
let accounts s = Proto.Session.accounts s
92
-
let primary_accounts s = Proto.Session.primary_accounts s
93
-
let username s = Proto.Session.username s
94
-
let api_url s = Proto.Session.api_url s
95
-
let download_url s = Proto.Session.download_url s
96
-
let upload_url s = Proto.Session.upload_url s
97
-
let event_source_url s = Proto.Session.event_source_url s
98
-
let state s = Proto.Session.state s
99
-
100
-
let get_account id s = Proto.Session.get_account id s
101
-
let primary_account_for cap s = Proto.Session.primary_account_for cap s
102
-
let has_capability uri s = Proto.Session.has_capability uri s
103
-
end
104
-
105
-
(** {1 Mail Types} *)
106
-
107
-
(** Email address with optional display name. *)
108
-
module Email_address = struct
109
-
type t = Jmap_types.email_address
110
-
111
-
let name a = Proto.Email_address.name a
112
-
let email a = Proto.Email_address.email a
113
-
114
-
let create ?name email =
115
-
Proto.Email_address.create ?name email
116
-
end
117
-
118
-
(** Email mailbox. *)
119
-
module Mailbox = struct
120
-
type t = Jmap_types.mailbox
121
-
122
-
let id m = Proto.Mailbox.id m
123
-
let name m = Proto.Mailbox.name m
124
-
let parent_id m = Proto.Mailbox.parent_id m
125
-
let sort_order m = Proto.Mailbox.sort_order m
126
-
let total_emails m = Proto.Mailbox.total_emails m
127
-
let unread_emails m = Proto.Mailbox.unread_emails m
128
-
let total_threads m = Proto.Mailbox.total_threads m
129
-
let unread_threads m = Proto.Mailbox.unread_threads m
130
-
let is_subscribed m = Proto.Mailbox.is_subscribed m
131
-
132
-
let role m =
133
-
(* Proto.Mailbox.role now returns polymorphic variants directly *)
134
-
let convert_role : Proto.Mailbox.role -> Role.t = function
135
-
| `Inbox -> `Inbox
136
-
| `Sent -> `Sent
137
-
| `Drafts -> `Drafts
138
-
| `Trash -> `Trash
139
-
| `Junk -> `Junk
140
-
| `Archive -> `Archive
141
-
| `Flagged -> `Flagged
142
-
| `Important -> `Important
143
-
| `All -> `All
144
-
| `Subscribed -> `Subscribed
145
-
| `Snoozed -> `Snoozed
146
-
| `Scheduled -> `Scheduled
147
-
| `Memos -> `Memos
148
-
| `Other s -> `Custom s
149
-
in
150
-
Option.map convert_role (Proto.Mailbox.role m)
151
-
152
-
(** Mailbox rights. *)
153
-
module Rights = struct
154
-
type t = Proto.Mailbox.Rights.t
155
-
156
-
let may_read_items r = Proto.Mailbox.Rights.may_read_items r
157
-
let may_add_items r = Proto.Mailbox.Rights.may_add_items r
158
-
let may_remove_items r = Proto.Mailbox.Rights.may_remove_items r
159
-
let may_set_seen r = Proto.Mailbox.Rights.may_set_seen r
160
-
let may_set_keywords r = Proto.Mailbox.Rights.may_set_keywords r
161
-
let may_create_child r = Proto.Mailbox.Rights.may_create_child r
162
-
let may_rename r = Proto.Mailbox.Rights.may_rename r
163
-
let may_delete r = Proto.Mailbox.Rights.may_delete r
164
-
let may_submit r = Proto.Mailbox.Rights.may_submit r
165
-
end
166
-
167
-
let my_rights m = Proto.Mailbox.my_rights m
168
-
end
169
-
170
-
(** Email thread. *)
171
-
module Thread = struct
172
-
type t = Jmap_types.thread
173
-
174
-
let id t = Proto.Thread.id t
175
-
let email_ids t = Proto.Thread.email_ids t
176
-
end
177
-
178
-
(** Email message. *)
179
-
module Email = struct
180
-
(** Email body part. *)
181
-
module Body = struct
182
-
type part = Proto.Email_body.Part.t
183
-
type value = Proto.Email_body.Value.t
184
-
185
-
let part_id p = Proto.Email_body.Part.part_id p
186
-
let blob_id p = Proto.Email_body.Part.blob_id p
187
-
let size p = Proto.Email_body.Part.size p
188
-
let name p = Proto.Email_body.Part.name p
189
-
let type_ p = Proto.Email_body.Part.type_ p
190
-
let charset p = Proto.Email_body.Part.charset p
191
-
let disposition p = Proto.Email_body.Part.disposition p
192
-
let cid p = Proto.Email_body.Part.cid p
193
-
let language p = Proto.Email_body.Part.language p
194
-
let location p = Proto.Email_body.Part.location p
195
-
196
-
let value_text v = Proto.Email_body.Value.value v
197
-
let value_is_truncated v = Proto.Email_body.Value.is_truncated v
198
-
let value_is_encoding_problem v = Proto.Email_body.Value.is_encoding_problem v
199
-
end
200
-
201
-
type t = Jmap_types.email
202
-
203
-
let id e = Proto.Email.id e
204
-
let blob_id e = Proto.Email.blob_id e
205
-
let thread_id e = Proto.Email.thread_id e
206
-
let mailbox_ids e = Proto.Email.mailbox_ids e
207
-
let size e = Proto.Email.size e
208
-
let received_at e = Proto.Email.received_at e
209
-
let message_id e = Proto.Email.message_id e
210
-
let in_reply_to e = Proto.Email.in_reply_to e
211
-
let references e = Proto.Email.references e
212
-
let subject e = Proto.Email.subject e
213
-
let sent_at e = Proto.Email.sent_at e
214
-
let has_attachment e = Proto.Email.has_attachment e
215
-
let preview e = Proto.Email.preview e
216
-
217
-
(** Get active keywords as polymorphic variants. *)
218
-
let keywords e =
219
-
match Proto.Email.keywords e with
220
-
| None -> []
221
-
| Some kw_map ->
222
-
List.filter_map (fun (k, v) ->
223
-
if v then Some (Keyword.of_string k) else None
224
-
) kw_map
225
-
226
-
(** Check if email has a specific keyword. *)
227
-
let has_keyword kw e =
228
-
let kw_str = Keyword.to_string kw in
229
-
match Proto.Email.keywords e with
230
-
| None -> false
231
-
| Some kw_map -> List.exists (fun (k, v) -> k = kw_str && v) kw_map
232
-
233
-
let from e = Proto.Email.from e
234
-
let to_ e = Proto.Email.to_ e
235
-
let cc e = Proto.Email.cc e
236
-
let bcc e = Proto.Email.bcc e
237
-
let reply_to e = Proto.Email.reply_to e
238
-
let sender e = Proto.Email.sender e
239
-
240
-
let text_body e = Proto.Email.text_body e
241
-
let html_body e = Proto.Email.html_body e
242
-
let attachments e = Proto.Email.attachments e
243
-
let body_values e = Proto.Email.body_values e
244
-
end
245
-
246
-
(** Email identity for sending. *)
247
-
module Identity = struct
248
-
type t = Jmap_types.identity
249
-
250
-
let id i = Proto.Identity.id i
251
-
let name i = Proto.Identity.name i
252
-
let email i = Proto.Identity.email i
253
-
let reply_to i = Proto.Identity.reply_to i
254
-
let bcc i = Proto.Identity.bcc i
255
-
let text_signature i = Proto.Identity.text_signature i
256
-
let html_signature i = Proto.Identity.html_signature i
257
-
let may_delete i = Proto.Identity.may_delete i
258
-
end
259
-
260
-
(** Email submission for outgoing mail. *)
261
-
module Submission = struct
262
-
type t = Jmap_types.submission
263
-
264
-
let id s = Proto.Submission.id s
265
-
let identity_id s = Proto.Submission.identity_id s
266
-
let email_id s = Proto.Submission.email_id s
267
-
let thread_id s = Proto.Submission.thread_id s
268
-
let send_at s = Proto.Submission.send_at s
269
-
let undo_status s = Proto.Submission.undo_status s
270
-
let delivery_status s = Proto.Submission.delivery_status s
271
-
let dsn_blob_ids s = Proto.Submission.dsn_blob_ids s
272
-
let mdn_blob_ids s = Proto.Submission.mdn_blob_ids s
273
-
end
274
-
275
-
(** Vacation auto-response. *)
276
-
module Vacation = struct
277
-
type t = Jmap_types.vacation
278
-
279
-
let id v = Proto.Vacation.id v
280
-
let is_enabled v = Proto.Vacation.is_enabled v
281
-
let from_date v = Proto.Vacation.from_date v
282
-
let to_date v = Proto.Vacation.to_date v
283
-
let subject v = Proto.Vacation.subject v
284
-
let text_body v = Proto.Vacation.text_body v
285
-
let html_body v = Proto.Vacation.html_body v
286
-
end
287
-
288
-
(** Search snippet with highlighted matches. *)
289
-
module Search_snippet = struct
290
-
type t = Jmap_types.search_snippet
291
-
292
-
let email_id s = Proto.Search_snippet.email_id s
293
-
let subject s = Proto.Search_snippet.subject s
294
-
let preview s = Proto.Search_snippet.preview s
295
-
end
296
-
297
-
(** {1 Filter Types} *)
298
-
299
-
(** Email filter conditions for queries. *)
300
-
module Email_filter = struct
301
-
type condition = Proto.Email.Filter_condition.t
302
-
303
-
(** Create an email filter condition.
304
-
305
-
All parameters are optional. Omitted parameters are not included
306
-
in the filter. Use [make ()] for an empty filter. *)
307
-
let make
308
-
?in_mailbox
309
-
?in_mailbox_other_than
310
-
?before
311
-
?after
312
-
?min_size
313
-
?max_size
314
-
?(all_in_thread_have_keyword : Keyword.t option)
315
-
?(some_in_thread_have_keyword : Keyword.t option)
316
-
?(none_in_thread_have_keyword : Keyword.t option)
317
-
?(has_keyword : Keyword.t option)
318
-
?(not_keyword : Keyword.t option)
319
-
?has_attachment
320
-
?text
321
-
?from
322
-
?to_
323
-
?cc
324
-
?bcc
325
-
?subject
326
-
?body
327
-
?header
328
-
() : condition =
329
-
{
330
-
in_mailbox;
331
-
in_mailbox_other_than;
332
-
before;
333
-
after;
334
-
min_size;
335
-
max_size;
336
-
all_in_thread_have_keyword = Option.map Keyword.to_string all_in_thread_have_keyword;
337
-
some_in_thread_have_keyword = Option.map Keyword.to_string some_in_thread_have_keyword;
338
-
none_in_thread_have_keyword = Option.map Keyword.to_string none_in_thread_have_keyword;
339
-
has_keyword = Option.map Keyword.to_string has_keyword;
340
-
not_keyword = Option.map Keyword.to_string not_keyword;
341
-
has_attachment;
342
-
text;
343
-
from;
344
-
to_;
345
-
cc;
346
-
bcc;
347
-
subject;
348
-
body;
349
-
header;
350
-
}
351
-
end
352
-
353
-
(** Mailbox filter conditions for queries. *)
354
-
module Mailbox_filter = struct
355
-
type condition = Proto.Mailbox.Filter_condition.t
356
-
357
-
let convert_role : Role.t -> Proto.Mailbox.role = function
358
-
| `Inbox -> `Inbox
359
-
| `Sent -> `Sent
360
-
| `Drafts -> `Drafts
361
-
| `Trash -> `Trash
362
-
| `Junk -> `Junk
363
-
| `Archive -> `Archive
364
-
| `Flagged -> `Flagged
365
-
| `Important -> `Important
366
-
| `All -> `All
367
-
| `Subscribed -> `Subscribed
368
-
| `Snoozed -> `Snoozed
369
-
| `Scheduled -> `Scheduled
370
-
| `Memos -> `Memos
371
-
| `Custom s -> `Other s
372
-
373
-
(** Create a mailbox filter condition.
374
-
375
-
All parameters are optional.
376
-
For [role]: [Some (Some r)] filters by role [r], [Some None] filters for
377
-
mailboxes with no role, [None] doesn't filter by role. *)
378
-
let make
379
-
?parent_id
380
-
?name
381
-
?role
382
-
?has_any_role
383
-
?is_subscribed
384
-
() : condition =
385
-
{
386
-
parent_id;
387
-
name;
388
-
role = Option.map (Option.map convert_role) role;
389
-
has_any_role;
390
-
is_subscribed;
391
-
}
392
-
end
393
-
394
-
(** {1 Response Types} *)
395
-
396
-
(** Generic /get response wrapper. *)
397
-
module Get_response = struct
398
-
type 'a t = 'a Proto.Method.get_response
399
-
400
-
let account_id (r : 'a t) = r.Proto.Method.account_id
401
-
let state (r : 'a t) = r.Proto.Method.state
402
-
let list (r : 'a t) = r.Proto.Method.list
403
-
let not_found (r : 'a t) = r.Proto.Method.not_found
404
-
end
405
-
406
-
(** Query response. *)
407
-
module Query_response = struct
408
-
type t = Proto.Method.query_response
409
-
410
-
let account_id (r : t) = r.Proto.Method.account_id
411
-
let query_state (r : t) = r.Proto.Method.query_state
412
-
let can_calculate_changes (r : t) = r.Proto.Method.can_calculate_changes
413
-
let position (r : t) = r.Proto.Method.position
414
-
let ids (r : t) = r.Proto.Method.ids
415
-
let total (r : t) = r.Proto.Method.total
416
-
end
417
-
418
-
(** Changes response. *)
419
-
module Changes_response = struct
420
-
type t = Proto.Method.changes_response
421
-
422
-
let account_id (r : t) = r.Proto.Method.account_id
423
-
let old_state (r : t) = r.Proto.Method.old_state
424
-
let new_state (r : t) = r.Proto.Method.new_state
425
-
let has_more_changes (r : t) = r.Proto.Method.has_more_changes
426
-
let created (r : t) = r.Proto.Method.created
427
-
let updated (r : t) = r.Proto.Method.updated
428
-
let destroyed (r : t) = r.Proto.Method.destroyed
429
-
end
430
-
431
-
(** {1 JSONABLE Interface} *)
432
-
433
-
(** Module type for types that can be serialized to/from JSON bytes. *)
434
-
module type JSONABLE = sig
435
-
type t
436
-
437
-
val of_string : string -> (t, Error.t) result
438
-
val to_string : t -> (string, Error.t) result
439
-
end
440
-
441
-
(** {1 Request Chaining} *)
442
-
443
-
(** JMAP method chaining with automatic result references.
444
-
445
-
See {!Chain} for the full interface. *)
446
-
module Chain = Chain
-532
lib/core/jmap.mli
-532
lib/core/jmap.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Unified JMAP interface for OCaml
7
-
8
-
This module provides a clean, ergonomic API for working with JMAP
9
-
(RFC 8620/8621), combining the protocol and mail layers with abstract
10
-
types and polymorphic variants.
11
-
12
-
{2 Quick Start}
13
-
14
-
{[
15
-
open Jmap
16
-
17
-
(* Keywords use polymorphic variants *)
18
-
let is_unread email =
19
-
not (List.mem `Seen (Email.keywords email))
20
-
21
-
(* Mailbox roles are also polymorphic *)
22
-
let find_inbox mailboxes =
23
-
List.find_opt (fun m -> Mailbox.role m = Some `Inbox) mailboxes
24
-
]}
25
-
26
-
{2 Module Structure}
27
-
28
-
- {!Proto} - Low-level protocol and mail types (RFC 8620/8621)
29
-
- {!Error}, {!Id}, {!Keyword}, {!Role}, {!Capability} - Core types
30
-
- {!Session}, {!Email}, {!Mailbox}, etc. - Abstract type accessors
31
-
*)
32
-
33
-
(** {1 Protocol Layer Re-exports} *)
34
-
35
-
(** Low-level JMAP protocol types (RFC 8620/8621).
36
-
37
-
These are the raw protocol and mail types. For most use cases, prefer the
38
-
higher-level types in this module. *)
39
-
module Proto = Jmap_proto
40
-
41
-
(** {1 Core Types} *)
42
-
43
-
(** Unified error type for JMAP operations. *)
44
-
module Error : sig
45
-
(** Request-level error (RFC 7807 Problem Details). *)
46
-
type request = {
47
-
type_ : string;
48
-
status : int option;
49
-
title : string option;
50
-
detail : string option;
51
-
limit : string option;
52
-
}
53
-
54
-
(** Method-level error. *)
55
-
type method_ = {
56
-
type_ : string;
57
-
description : string option;
58
-
}
59
-
60
-
(** Set operation error for a specific object. *)
61
-
type set = {
62
-
type_ : string;
63
-
description : string option;
64
-
properties : string list option;
65
-
}
66
-
67
-
(** Unified error type.
68
-
69
-
All errors from JSON parsing, HTTP, session management, and JMAP method
70
-
calls are represented as polymorphic variants. *)
71
-
type t = [
72
-
| `Request of request
73
-
| `Method of method_
74
-
| `Set of string * set
75
-
| `Json of string
76
-
| `Http of int * string
77
-
| `Connection of string
78
-
| `Session of string
79
-
]
80
-
81
-
val pp : Format.formatter -> t -> unit
82
-
val to_string : t -> string
83
-
end
84
-
85
-
(** JMAP identifier type. *)
86
-
module Id : sig
87
-
type t
88
-
89
-
val of_string : string -> (t, string) result
90
-
val of_string_exn : string -> t
91
-
val to_string : t -> string
92
-
val compare : t -> t -> int
93
-
val equal : t -> t -> bool
94
-
val pp : Format.formatter -> t -> unit
95
-
end
96
-
97
-
(** Email keyword type.
98
-
99
-
Standard keywords are represented as polymorphic variants.
100
-
Custom keywords use [`Custom of string]. *)
101
-
module Keyword : sig
102
-
(** RFC 8621 standard keywords *)
103
-
type standard = [
104
-
| `Seen
105
-
| `Flagged
106
-
| `Answered
107
-
| `Draft
108
-
| `Forwarded
109
-
| `Phishing
110
-
| `Junk
111
-
| `NotJunk
112
-
]
113
-
114
-
(** draft-ietf-mailmaint extended keywords *)
115
-
type extended = [
116
-
| `Notify
117
-
| `Muted
118
-
| `Followed
119
-
| `Memo
120
-
| `HasMemo
121
-
| `HasAttachment
122
-
| `HasNoAttachment
123
-
| `AutoSent
124
-
| `Unsubscribed
125
-
| `CanUnsubscribe
126
-
| `Imported
127
-
| `IsTrusted
128
-
| `MaskedEmail
129
-
| `New
130
-
]
131
-
132
-
(** Apple Mail flag color keywords *)
133
-
type flag_bits = [
134
-
| `MailFlagBit0
135
-
| `MailFlagBit1
136
-
| `MailFlagBit2
137
-
]
138
-
139
-
type t = [
140
-
| standard
141
-
| extended
142
-
| flag_bits
143
-
| `Custom of string
144
-
]
145
-
146
-
val of_string : string -> t
147
-
val to_string : t -> string
148
-
val pp : Format.formatter -> t -> unit
149
-
150
-
(** Apple Mail flag colors *)
151
-
type flag_color = [
152
-
| `Red
153
-
| `Orange
154
-
| `Yellow
155
-
| `Green
156
-
| `Blue
157
-
| `Purple
158
-
| `Gray
159
-
]
160
-
161
-
val flag_color_of_keywords : t list -> flag_color option
162
-
(** [flag_color_of_keywords keywords] extracts the flag color from a list
163
-
of keywords. Returns [None] for invalid bit combinations. *)
164
-
165
-
val flag_color_to_keywords : flag_color -> t list
166
-
(** [flag_color_to_keywords color] returns the keywords to set for the color. *)
167
-
end
168
-
169
-
(** Mailbox role type.
170
-
171
-
Standard roles are represented as polymorphic variants.
172
-
Custom roles use [`Custom of string]. *)
173
-
module Role : sig
174
-
(** RFC 8621 standard roles *)
175
-
type standard = [
176
-
| `Inbox
177
-
| `Sent
178
-
| `Drafts
179
-
| `Trash
180
-
| `Junk
181
-
| `Archive
182
-
| `Flagged
183
-
| `Important
184
-
| `All
185
-
| `Subscribed
186
-
]
187
-
188
-
(** draft-ietf-mailmaint extended roles *)
189
-
type extended = [
190
-
| `Snoozed
191
-
| `Scheduled
192
-
| `Memos
193
-
]
194
-
195
-
type t = [
196
-
| standard
197
-
| extended
198
-
| `Custom of string
199
-
]
200
-
201
-
val of_string : string -> t
202
-
val to_string : t -> string
203
-
val pp : Format.formatter -> t -> unit
204
-
end
205
-
206
-
(** JMAP capability type.
207
-
208
-
Standard capabilities are represented as polymorphic variants.
209
-
Custom capabilities use [`Custom of string]. *)
210
-
module Capability : sig
211
-
type t = [
212
-
| `Core
213
-
| `Mail
214
-
| `Submission
215
-
| `VacationResponse
216
-
| `Custom of string
217
-
]
218
-
219
-
val core_uri : string
220
-
val mail_uri : string
221
-
val submission_uri : string
222
-
val vacation_uri : string
223
-
224
-
val of_string : string -> t
225
-
val to_string : t -> string
226
-
val pp : Format.formatter -> t -> unit
227
-
end
228
-
229
-
(** {1 Session Types} *)
230
-
231
-
(** JMAP session information. *)
232
-
module Session : sig
233
-
(** Account information. *)
234
-
module Account : sig
235
-
type t
236
-
237
-
val name : t -> string
238
-
val is_personal : t -> bool
239
-
val is_read_only : t -> bool
240
-
end
241
-
242
-
type t
243
-
244
-
val capabilities : t -> (string * Jsont.json) list
245
-
val accounts : t -> (Id.t * Account.t) list
246
-
val primary_accounts : t -> (string * Id.t) list
247
-
val username : t -> string
248
-
val api_url : t -> string
249
-
val download_url : t -> string
250
-
val upload_url : t -> string
251
-
val event_source_url : t -> string
252
-
val state : t -> string
253
-
254
-
val get_account : Id.t -> t -> Account.t option
255
-
val primary_account_for : string -> t -> Id.t option
256
-
val has_capability : string -> t -> bool
257
-
end
258
-
259
-
(** {1 Mail Types} *)
260
-
261
-
(** Email address with optional display name. *)
262
-
module Email_address : sig
263
-
type t
264
-
265
-
val name : t -> string option
266
-
val email : t -> string
267
-
val create : ?name:string -> string -> t
268
-
end
269
-
270
-
(** Email mailbox.
271
-
All accessors return option types since responses only include requested properties. *)
272
-
module Mailbox : sig
273
-
type t
274
-
275
-
val id : t -> Id.t option
276
-
val name : t -> string option
277
-
val parent_id : t -> Id.t option
278
-
val sort_order : t -> int64 option
279
-
val total_emails : t -> int64 option
280
-
val unread_emails : t -> int64 option
281
-
val total_threads : t -> int64 option
282
-
val unread_threads : t -> int64 option
283
-
val is_subscribed : t -> bool option
284
-
val role : t -> Role.t option
285
-
286
-
(** Mailbox rights. *)
287
-
module Rights : sig
288
-
type t
289
-
290
-
val may_read_items : t -> bool
291
-
val may_add_items : t -> bool
292
-
val may_remove_items : t -> bool
293
-
val may_set_seen : t -> bool
294
-
val may_set_keywords : t -> bool
295
-
val may_create_child : t -> bool
296
-
val may_rename : t -> bool
297
-
val may_delete : t -> bool
298
-
val may_submit : t -> bool
299
-
end
300
-
301
-
val my_rights : t -> Rights.t option
302
-
end
303
-
304
-
(** Email thread.
305
-
All accessors return option types since responses only include requested properties. *)
306
-
module Thread : sig
307
-
type t
308
-
309
-
val id : t -> Id.t option
310
-
val email_ids : t -> Id.t list option
311
-
end
312
-
313
-
(** Email message. *)
314
-
module Email : sig
315
-
(** Email body part. *)
316
-
module Body : sig
317
-
type part
318
-
type value
319
-
320
-
val part_id : part -> string option
321
-
val blob_id : part -> Id.t option
322
-
val size : part -> int64 option
323
-
val name : part -> string option
324
-
val type_ : part -> string
325
-
val charset : part -> string option
326
-
val disposition : part -> string option
327
-
val cid : part -> string option
328
-
val language : part -> string list option
329
-
val location : part -> string option
330
-
331
-
val value_text : value -> string
332
-
val value_is_truncated : value -> bool
333
-
val value_is_encoding_problem : value -> bool
334
-
end
335
-
336
-
(** All accessors return option types since responses only include requested properties. *)
337
-
type t
338
-
339
-
val id : t -> Id.t option
340
-
val blob_id : t -> Id.t option
341
-
val thread_id : t -> Id.t option
342
-
val mailbox_ids : t -> (Id.t * bool) list option
343
-
val size : t -> int64 option
344
-
val received_at : t -> Ptime.t option
345
-
val message_id : t -> string list option
346
-
val in_reply_to : t -> string list option
347
-
val references : t -> string list option
348
-
val subject : t -> string option
349
-
val sent_at : t -> Ptime.t option
350
-
val has_attachment : t -> bool option
351
-
val preview : t -> string option
352
-
353
-
(** Get active keywords as polymorphic variants.
354
-
Returns empty list if keywords property was not requested. *)
355
-
val keywords : t -> Keyword.t list
356
-
357
-
(** Check if email has a specific keyword.
358
-
Returns false if keywords property was not requested. *)
359
-
val has_keyword : Keyword.t -> t -> bool
360
-
361
-
val from : t -> Email_address.t list option
362
-
val to_ : t -> Email_address.t list option
363
-
val cc : t -> Email_address.t list option
364
-
val bcc : t -> Email_address.t list option
365
-
val reply_to : t -> Email_address.t list option
366
-
val sender : t -> Email_address.t list option
367
-
368
-
val text_body : t -> Body.part list option
369
-
val html_body : t -> Body.part list option
370
-
val attachments : t -> Body.part list option
371
-
val body_values : t -> (string * Body.value) list option
372
-
end
373
-
374
-
(** Email identity for sending.
375
-
All accessors return option types since responses only include requested properties. *)
376
-
module Identity : sig
377
-
type t
378
-
379
-
val id : t -> Id.t option
380
-
val name : t -> string option
381
-
val email : t -> string option
382
-
val reply_to : t -> Email_address.t list option
383
-
val bcc : t -> Email_address.t list option
384
-
val text_signature : t -> string option
385
-
val html_signature : t -> string option
386
-
val may_delete : t -> bool option
387
-
end
388
-
389
-
(** Email submission for outgoing mail.
390
-
All accessors return option types since responses only include requested properties. *)
391
-
module Submission : sig
392
-
type t
393
-
394
-
val id : t -> Id.t option
395
-
val identity_id : t -> Id.t option
396
-
val email_id : t -> Id.t option
397
-
val thread_id : t -> Id.t option
398
-
val send_at : t -> Ptime.t option
399
-
val undo_status : t -> Proto.Submission.undo_status option
400
-
val delivery_status : t -> (string * Proto.Submission.Delivery_status.t) list option
401
-
val dsn_blob_ids : t -> Id.t list option
402
-
val mdn_blob_ids : t -> Id.t list option
403
-
end
404
-
405
-
(** Vacation auto-response. *)
406
-
module Vacation : sig
407
-
type t
408
-
409
-
val id : t -> Id.t
410
-
val is_enabled : t -> bool
411
-
val from_date : t -> Ptime.t option
412
-
val to_date : t -> Ptime.t option
413
-
val subject : t -> string option
414
-
val text_body : t -> string option
415
-
val html_body : t -> string option
416
-
end
417
-
418
-
(** Search snippet with highlighted matches. *)
419
-
module Search_snippet : sig
420
-
type t
421
-
422
-
val email_id : t -> Id.t
423
-
val subject : t -> string option
424
-
val preview : t -> string option
425
-
end
426
-
427
-
(** {1 Filter Types} *)
428
-
429
-
(** Email filter conditions for queries. *)
430
-
module Email_filter : sig
431
-
type condition
432
-
433
-
(** Create an email filter condition.
434
-
435
-
All parameters are optional. Omitted parameters are not included
436
-
in the filter. Use [make ()] for an empty filter. *)
437
-
val make :
438
-
?in_mailbox:Id.t ->
439
-
?in_mailbox_other_than:Id.t list ->
440
-
?before:Ptime.t ->
441
-
?after:Ptime.t ->
442
-
?min_size:int64 ->
443
-
?max_size:int64 ->
444
-
?all_in_thread_have_keyword:Keyword.t ->
445
-
?some_in_thread_have_keyword:Keyword.t ->
446
-
?none_in_thread_have_keyword:Keyword.t ->
447
-
?has_keyword:Keyword.t ->
448
-
?not_keyword:Keyword.t ->
449
-
?has_attachment:bool ->
450
-
?text:string ->
451
-
?from:string ->
452
-
?to_:string ->
453
-
?cc:string ->
454
-
?bcc:string ->
455
-
?subject:string ->
456
-
?body:string ->
457
-
?header:(string * string option) ->
458
-
unit -> condition
459
-
end
460
-
461
-
(** Mailbox filter conditions for queries. *)
462
-
module Mailbox_filter : sig
463
-
type condition
464
-
465
-
(** Create a mailbox filter condition.
466
-
467
-
All parameters are optional.
468
-
For [role]: [Some (Some r)] filters by role [r], [Some None] filters for
469
-
mailboxes with no role, [None] doesn't filter by role. *)
470
-
val make :
471
-
?parent_id:Id.t option ->
472
-
?name:string ->
473
-
?role:Role.t option ->
474
-
?has_any_role:bool ->
475
-
?is_subscribed:bool ->
476
-
unit -> condition
477
-
end
478
-
479
-
(** {1 Response Types} *)
480
-
481
-
(** Generic /get response wrapper. *)
482
-
module Get_response : sig
483
-
type 'a t
484
-
485
-
val account_id : 'a t -> Id.t
486
-
val state : 'a t -> string
487
-
val list : 'a t -> 'a list
488
-
val not_found : 'a t -> Id.t list
489
-
end
490
-
491
-
(** Query response. *)
492
-
module Query_response : sig
493
-
type t
494
-
495
-
val account_id : t -> Id.t
496
-
val query_state : t -> string
497
-
val can_calculate_changes : t -> bool
498
-
val position : t -> int64
499
-
val ids : t -> Id.t list
500
-
val total : t -> int64 option
501
-
end
502
-
503
-
(** Changes response. *)
504
-
module Changes_response : sig
505
-
type t
506
-
507
-
val account_id : t -> Id.t
508
-
val old_state : t -> string
509
-
val new_state : t -> string
510
-
val has_more_changes : t -> bool
511
-
val created : t -> Id.t list
512
-
val updated : t -> Id.t list
513
-
val destroyed : t -> Id.t list
514
-
end
515
-
516
-
(** {1 JSONABLE Interface} *)
517
-
518
-
(** Module type for types that can be serialized to/from JSON bytes. *)
519
-
module type JSONABLE = sig
520
-
type t
521
-
522
-
val of_string : string -> (t, Error.t) result
523
-
val to_string : t -> (string, Error.t) result
524
-
end
525
-
526
-
(** {1 Request Chaining} *)
527
-
528
-
(** JMAP method chaining with automatic result references.
529
-
530
-
This module provides a monadic interface for building JMAP requests
531
-
where method calls can reference results from previous calls. *)
532
-
module Chain = Chain
-361
lib/core/jmap_types.ml
-361
lib/core/jmap_types.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Internal types for the unified Jmap interface *)
7
-
8
-
(** {1 Error Types} *)
9
-
10
-
module Error = struct
11
-
(** Request-level error (RFC 7807 Problem Details) *)
12
-
type request = {
13
-
type_ : string;
14
-
status : int option;
15
-
title : string option;
16
-
detail : string option;
17
-
limit : string option;
18
-
}
19
-
20
-
(** Method-level error *)
21
-
type method_ = {
22
-
type_ : string;
23
-
description : string option;
24
-
}
25
-
26
-
(** Set operation error for a specific object *)
27
-
type set = {
28
-
type_ : string;
29
-
description : string option;
30
-
properties : string list option;
31
-
}
32
-
33
-
(** Unified error type *)
34
-
type t = [
35
-
| `Request of request
36
-
| `Method of method_
37
-
| `Set of string * set
38
-
| `Json of string
39
-
| `Http of int * string
40
-
| `Connection of string
41
-
| `Session of string
42
-
]
43
-
44
-
let pp_request ppf (r : request) =
45
-
Format.fprintf ppf "Request error: %s" r.type_;
46
-
Option.iter (Format.fprintf ppf " (status %d)") r.status;
47
-
Option.iter (Format.fprintf ppf ": %s") r.detail
48
-
49
-
let pp_method ppf (m : method_) =
50
-
Format.fprintf ppf "Method error: %s" m.type_;
51
-
Option.iter (Format.fprintf ppf ": %s") m.description
52
-
53
-
let pp_set ppf (id, (s : set)) =
54
-
Format.fprintf ppf "Set error for %s: %s" id s.type_;
55
-
Option.iter (Format.fprintf ppf ": %s") s.description
56
-
57
-
let pp ppf = function
58
-
| `Request r -> pp_request ppf r
59
-
| `Method m -> pp_method ppf m
60
-
| `Set (id, s) -> pp_set ppf (id, s)
61
-
| `Json msg -> Format.fprintf ppf "JSON error: %s" msg
62
-
| `Http (code, msg) -> Format.fprintf ppf "HTTP error %d: %s" code msg
63
-
| `Connection msg -> Format.fprintf ppf "Connection error: %s" msg
64
-
| `Session msg -> Format.fprintf ppf "Session error: %s" msg
65
-
66
-
let to_string e = Format.asprintf "%a" pp e
67
-
end
68
-
69
-
(** {1 Identifier Type} *)
70
-
71
-
module Id = struct
72
-
type t = Jmap_proto.Id.t
73
-
74
-
let of_string s = Jmap_proto.Id.of_string s
75
-
let of_string_exn s = Jmap_proto.Id.of_string_exn s
76
-
let to_string = Jmap_proto.Id.to_string
77
-
let compare = Jmap_proto.Id.compare
78
-
let equal = Jmap_proto.Id.equal
79
-
let pp = Jmap_proto.Id.pp
80
-
end
81
-
82
-
(** {1 Keyword Type} *)
83
-
84
-
module Keyword = struct
85
-
(** RFC 8621 standard keywords *)
86
-
type standard = [
87
-
| `Seen
88
-
| `Flagged
89
-
| `Answered
90
-
| `Draft
91
-
| `Forwarded
92
-
| `Phishing
93
-
| `Junk
94
-
| `NotJunk
95
-
]
96
-
97
-
(** draft-ietf-mailmaint extended keywords *)
98
-
type extended = [
99
-
| `Notify
100
-
| `Muted
101
-
| `Followed
102
-
| `Memo
103
-
| `HasMemo
104
-
| `HasAttachment
105
-
| `HasNoAttachment
106
-
| `AutoSent
107
-
| `Unsubscribed
108
-
| `CanUnsubscribe
109
-
| `Imported
110
-
| `IsTrusted
111
-
| `MaskedEmail
112
-
| `New
113
-
]
114
-
115
-
(** Apple Mail flag color keywords *)
116
-
type flag_bits = [
117
-
| `MailFlagBit0
118
-
| `MailFlagBit1
119
-
| `MailFlagBit2
120
-
]
121
-
122
-
type t = [
123
-
| standard
124
-
| extended
125
-
| flag_bits
126
-
| `Custom of string
127
-
]
128
-
129
-
let of_string = function
130
-
(* RFC 8621 standard keywords *)
131
-
| "$seen" -> `Seen
132
-
| "$flagged" -> `Flagged
133
-
| "$answered" -> `Answered
134
-
| "$draft" -> `Draft
135
-
| "$forwarded" -> `Forwarded
136
-
| "$phishing" -> `Phishing
137
-
| "$junk" -> `Junk
138
-
| "$notjunk" -> `NotJunk
139
-
(* draft-ietf-mailmaint extended keywords *)
140
-
| "$notify" -> `Notify
141
-
| "$muted" -> `Muted
142
-
| "$followed" -> `Followed
143
-
| "$memo" -> `Memo
144
-
| "$hasmemo" -> `HasMemo
145
-
| "$hasattachment" -> `HasAttachment
146
-
| "$hasnoattachment" -> `HasNoAttachment
147
-
| "$autosent" -> `AutoSent
148
-
| "$unsubscribed" -> `Unsubscribed
149
-
| "$canunsubscribe" -> `CanUnsubscribe
150
-
| "$imported" -> `Imported
151
-
| "$istrusted" -> `IsTrusted
152
-
| "$maskedemail" -> `MaskedEmail
153
-
| "$new" -> `New
154
-
(* Apple Mail flag color keywords *)
155
-
| "$MailFlagBit0" -> `MailFlagBit0
156
-
| "$MailFlagBit1" -> `MailFlagBit1
157
-
| "$MailFlagBit2" -> `MailFlagBit2
158
-
| s -> `Custom s
159
-
160
-
let to_string = function
161
-
(* RFC 8621 standard keywords *)
162
-
| `Seen -> "$seen"
163
-
| `Flagged -> "$flagged"
164
-
| `Answered -> "$answered"
165
-
| `Draft -> "$draft"
166
-
| `Forwarded -> "$forwarded"
167
-
| `Phishing -> "$phishing"
168
-
| `Junk -> "$junk"
169
-
| `NotJunk -> "$notjunk"
170
-
(* draft-ietf-mailmaint extended keywords *)
171
-
| `Notify -> "$notify"
172
-
| `Muted -> "$muted"
173
-
| `Followed -> "$followed"
174
-
| `Memo -> "$memo"
175
-
| `HasMemo -> "$hasmemo"
176
-
| `HasAttachment -> "$hasattachment"
177
-
| `HasNoAttachment -> "$hasnoattachment"
178
-
| `AutoSent -> "$autosent"
179
-
| `Unsubscribed -> "$unsubscribed"
180
-
| `CanUnsubscribe -> "$canunsubscribe"
181
-
| `Imported -> "$imported"
182
-
| `IsTrusted -> "$istrusted"
183
-
| `MaskedEmail -> "$maskedemail"
184
-
| `New -> "$new"
185
-
(* Apple Mail flag color keywords *)
186
-
| `MailFlagBit0 -> "$MailFlagBit0"
187
-
| `MailFlagBit1 -> "$MailFlagBit1"
188
-
| `MailFlagBit2 -> "$MailFlagBit2"
189
-
| `Custom s -> s
190
-
191
-
let pp ppf k = Format.pp_print_string ppf (to_string k)
192
-
193
-
(** Apple Mail flag colors *)
194
-
type flag_color = [
195
-
| `Red
196
-
| `Orange
197
-
| `Yellow
198
-
| `Green
199
-
| `Blue
200
-
| `Purple
201
-
| `Gray
202
-
]
203
-
204
-
let flag_color_of_keywords (keywords : t list) : flag_color option =
205
-
let has k = List.mem k keywords in
206
-
let bit0 = has `MailFlagBit0 in
207
-
let bit1 = has `MailFlagBit1 in
208
-
let bit2 = has `MailFlagBit2 in
209
-
match (bit0, bit1, bit2) with
210
-
| (false, false, false) -> Some `Red
211
-
| (true, false, false) -> Some `Orange
212
-
| (false, true, false) -> Some `Yellow
213
-
| (true, true, true) -> Some `Green
214
-
| (false, false, true) -> Some `Blue
215
-
| (true, false, true) -> Some `Purple
216
-
| (false, true, true) -> Some `Gray
217
-
| (true, true, false) -> None
218
-
219
-
let flag_color_to_keywords : flag_color -> t list = function
220
-
| `Red -> []
221
-
| `Orange -> [`MailFlagBit0]
222
-
| `Yellow -> [`MailFlagBit1]
223
-
| `Green -> [`MailFlagBit0; `MailFlagBit1; `MailFlagBit2]
224
-
| `Blue -> [`MailFlagBit2]
225
-
| `Purple -> [`MailFlagBit0; `MailFlagBit2]
226
-
| `Gray -> [`MailFlagBit1; `MailFlagBit2]
227
-
end
228
-
229
-
(** {1 Mailbox Role Type} *)
230
-
231
-
module Role = struct
232
-
(** RFC 8621 standard roles *)
233
-
type standard = [
234
-
| `Inbox
235
-
| `Sent
236
-
| `Drafts
237
-
| `Trash
238
-
| `Junk
239
-
| `Archive
240
-
| `Flagged
241
-
| `Important
242
-
| `All
243
-
| `Subscribed
244
-
]
245
-
246
-
(** draft-ietf-mailmaint extended roles *)
247
-
type extended = [
248
-
| `Snoozed
249
-
| `Scheduled
250
-
| `Memos
251
-
]
252
-
253
-
type t = [
254
-
| standard
255
-
| extended
256
-
| `Custom of string
257
-
]
258
-
259
-
let of_string = function
260
-
(* RFC 8621 standard roles *)
261
-
| "inbox" -> `Inbox
262
-
| "sent" -> `Sent
263
-
| "drafts" -> `Drafts
264
-
| "trash" -> `Trash
265
-
| "junk" -> `Junk
266
-
| "archive" -> `Archive
267
-
| "flagged" -> `Flagged
268
-
| "important" -> `Important
269
-
| "all" -> `All
270
-
| "subscribed" -> `Subscribed
271
-
(* draft-ietf-mailmaint extended roles *)
272
-
| "snoozed" -> `Snoozed
273
-
| "scheduled" -> `Scheduled
274
-
| "memos" -> `Memos
275
-
| s -> `Custom s
276
-
277
-
let to_string = function
278
-
(* RFC 8621 standard roles *)
279
-
| `Inbox -> "inbox"
280
-
| `Sent -> "sent"
281
-
| `Drafts -> "drafts"
282
-
| `Trash -> "trash"
283
-
| `Junk -> "junk"
284
-
| `Archive -> "archive"
285
-
| `Flagged -> "flagged"
286
-
| `Important -> "important"
287
-
| `All -> "all"
288
-
| `Subscribed -> "subscribed"
289
-
(* draft-ietf-mailmaint extended roles *)
290
-
| `Snoozed -> "snoozed"
291
-
| `Scheduled -> "scheduled"
292
-
| `Memos -> "memos"
293
-
| `Custom s -> s
294
-
295
-
let pp ppf r = Format.pp_print_string ppf (to_string r)
296
-
end
297
-
298
-
(** {1 Capability Type} *)
299
-
300
-
module Capability = struct
301
-
type t = [
302
-
| `Core
303
-
| `Mail
304
-
| `Submission
305
-
| `VacationResponse
306
-
| `Custom of string
307
-
]
308
-
309
-
let core_uri = "urn:ietf:params:jmap:core"
310
-
let mail_uri = "urn:ietf:params:jmap:mail"
311
-
let submission_uri = "urn:ietf:params:jmap:submission"
312
-
let vacation_uri = "urn:ietf:params:jmap:vacationresponse"
313
-
314
-
let of_string = function
315
-
| s when s = core_uri -> `Core
316
-
| s when s = mail_uri -> `Mail
317
-
| s when s = submission_uri -> `Submission
318
-
| s when s = vacation_uri -> `VacationResponse
319
-
| s -> `Custom s
320
-
321
-
let to_string = function
322
-
| `Core -> core_uri
323
-
| `Mail -> mail_uri
324
-
| `Submission -> submission_uri
325
-
| `VacationResponse -> vacation_uri
326
-
| `Custom s -> s
327
-
328
-
let pp ppf c = Format.pp_print_string ppf (to_string c)
329
-
end
330
-
331
-
(** {1 Abstract Type Wrappers} *)
332
-
333
-
(** Wrapped session type *)
334
-
type session = Jmap_proto.Session.t
335
-
336
-
(** Wrapped account type *)
337
-
type account = Jmap_proto.Session.Account.t
338
-
339
-
(** Wrapped mailbox type *)
340
-
type mailbox = Jmap_proto.Mailbox.t
341
-
342
-
(** Wrapped email type *)
343
-
type email = Jmap_proto.Email.t
344
-
345
-
(** Wrapped thread type *)
346
-
type thread = Jmap_proto.Thread.t
347
-
348
-
(** Wrapped identity type *)
349
-
type identity = Jmap_proto.Identity.t
350
-
351
-
(** Wrapped email submission type *)
352
-
type submission = Jmap_proto.Submission.t
353
-
354
-
(** Wrapped vacation response type *)
355
-
type vacation = Jmap_proto.Vacation.t
356
-
357
-
(** Wrapped email address type *)
358
-
type email_address = Jmap_proto.Email_address.t
359
-
360
-
(** Wrapped search snippet type *)
361
-
type search_snippet = Jmap_proto.Search_snippet.t
-41
lib/dune
-41
lib/dune
···
1
-
(include_subdirs unqualified)
2
-
3
-
(library
4
-
(name jmap)
5
-
(public_name jmap)
6
-
(libraries jsont json-pointer ptime)
7
-
(modules
8
-
; Core unified interface
9
-
jmap
10
-
jmap_types
11
-
chain
12
-
; Protocol layer wrapper (combines core + mail)
13
-
jmap_proto
14
-
; Core protocol modules
15
-
proto_id
16
-
proto_int53
17
-
proto_date
18
-
proto_json_map
19
-
proto_unknown
20
-
proto_error
21
-
proto_capability
22
-
proto_filter
23
-
proto_method
24
-
proto_invocation
25
-
proto_request
26
-
proto_response
27
-
proto_session
28
-
proto_push
29
-
proto_blob
30
-
; Mail modules
31
-
mail_address
32
-
mail_header
33
-
mail_body
34
-
mail_mailbox
35
-
mail_thread
36
-
mail_email
37
-
mail_snippet
38
-
mail_identity
39
-
mail_submission
40
-
mail_vacation
41
-
mail_filter))
-8
lib/js/dune
-8
lib/js/dune
-174
lib/js/jmap_brr.ml
-174
lib/js/jmap_brr.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
open Brr
7
-
open Fut.Syntax
8
-
9
-
type connection = {
10
-
session : Jmap.Proto.Session.t;
11
-
api_url : Jstr.t;
12
-
token : Jstr.t;
13
-
}
14
-
15
-
let session conn = conn.session
16
-
let api_url conn = conn.api_url
17
-
18
-
(* JSON logging callbacks *)
19
-
let on_request : (string -> string -> unit) option ref = ref None
20
-
let on_response : (string -> string -> unit) option ref = ref None
21
-
22
-
let set_request_logger f = on_request := Some f
23
-
let set_response_logger f = on_response := Some f
24
-
25
-
let log_request label json =
26
-
match !on_request with
27
-
| Some f -> f label json
28
-
| None -> ()
29
-
30
-
let log_response label json =
31
-
match !on_response with
32
-
| Some f -> f label json
33
-
| None -> ()
34
-
35
-
(* JSON encoding/decoding using jsont.brr *)
36
-
37
-
let encode_request req =
38
-
Jsont_brr.encode Jmap.Proto.Request.jsont req
39
-
40
-
let encode_response resp =
41
-
Jsont_brr.encode Jmap.Proto.Response.jsont resp
42
-
43
-
let encode_session session =
44
-
Jsont_brr.encode Jmap.Proto.Session.jsont session
45
-
46
-
let decode_json s =
47
-
match Brr.Json.decode s with
48
-
| Ok jv -> Ok (Obj.magic jv : Jsont.json) (* Jv.t and Jsont.json are compatible *)
49
-
| Error e -> Error e
50
-
51
-
let encode_json json =
52
-
Ok (Brr.Json.encode (Obj.magic json : Jv.t))
53
-
54
-
let pp_json ppf json =
55
-
match encode_json json with
56
-
| Ok s -> Format.pp_print_string ppf (Jstr.to_string s)
57
-
| Error _ -> Format.pp_print_string ppf "<json encoding error>"
58
-
59
-
(* HTTP helpers *)
60
-
61
-
let make_headers token =
62
-
Brr_io.Fetch.Headers.of_assoc [
63
-
Jstr.v "Authorization", Jstr.(v "Bearer " + token);
64
-
Jstr.v "Content-Type", Jstr.v "application/json";
65
-
Jstr.v "Accept", Jstr.v "application/json";
66
-
]
67
-
68
-
let fetch_json ~url ~meth ~headers ?body () =
69
-
Console.(log [str ">>> Request:"; str (Jstr.to_string meth); str (Jstr.to_string url)]);
70
-
(match body with
71
-
| Some b -> Console.(log [str ">>> Body:"; b])
72
-
| None -> Console.(log [str ">>> No body"]));
73
-
let init = Brr_io.Fetch.Request.init
74
-
~method':meth
75
-
~headers
76
-
?body
77
-
()
78
-
in
79
-
let req = Brr_io.Fetch.Request.v ~init url in
80
-
let* response = Brr_io.Fetch.request req in
81
-
match response with
82
-
| Error e ->
83
-
Console.(error [str "<<< Fetch error:"; e]);
84
-
Fut.return (Error e)
85
-
| Ok resp ->
86
-
let status = Brr_io.Fetch.Response.status resp in
87
-
Console.(log [str "<<< Response status:"; str (Jstr.of_int status)]);
88
-
if not (Brr_io.Fetch.Response.ok resp) then begin
89
-
let msg = Jstr.(v "HTTP error: " + of_int status) in
90
-
(* Try to get response body for error details *)
91
-
let body = Brr_io.Fetch.Response.as_body resp in
92
-
let* text = Brr_io.Fetch.Body.text body in
93
-
(match text with
94
-
| Ok t -> Console.(error [str "<<< Error body:"; str (Jstr.to_string t)])
95
-
| Error _ -> ());
96
-
Fut.return (Error (Jv.Error.v msg))
97
-
end else begin
98
-
let body = Brr_io.Fetch.Response.as_body resp in
99
-
let* text = Brr_io.Fetch.Body.text body in
100
-
match text with
101
-
| Error e ->
102
-
Console.(error [str "<<< Body read error:"; e]);
103
-
Fut.return (Error e)
104
-
| Ok text ->
105
-
Console.(log [str "<<< Response body:"; str (Jstr.to_string text)]);
106
-
Fut.return (Ok text)
107
-
end
108
-
109
-
(* Session establishment *)
110
-
111
-
let get_session ~url ~token =
112
-
Console.(log [str "get_session: token length ="; str (Jstr.of_int (Jstr.length token))]);
113
-
log_request "GET Session" (Printf.sprintf "{\"url\": \"%s\"}" (Jstr.to_string url));
114
-
let headers = make_headers token in
115
-
let* result = fetch_json ~url ~meth:(Jstr.v "GET") ~headers () in
116
-
match result with
117
-
| Error e -> Fut.return (Error e)
118
-
| Ok text ->
119
-
log_response "Session" (Jstr.to_string text);
120
-
match Jsont_brr.decode Jmap.Proto.Session.jsont text with
121
-
| Error e -> Fut.return (Error e)
122
-
| Ok session ->
123
-
let api_url = Jstr.v (Jmap.Proto.Session.api_url session) in
124
-
Fut.return (Ok { session; api_url; token })
125
-
126
-
(* Making requests *)
127
-
128
-
let request conn req =
129
-
let headers = make_headers conn.token in
130
-
match Jsont_brr.encode Jmap.Proto.Request.jsont req with
131
-
| Error e -> Fut.return (Error e)
132
-
| Ok body_str ->
133
-
log_request "JMAP Request" (Jstr.to_string body_str);
134
-
let body = Brr_io.Fetch.Body.of_jstr body_str in
135
-
let* result = fetch_json
136
-
~url:conn.api_url
137
-
~meth:(Jstr.v "POST")
138
-
~headers
139
-
~body
140
-
()
141
-
in
142
-
match result with
143
-
| Error e -> Fut.return (Error e)
144
-
| Ok text ->
145
-
log_response "JMAP Response" (Jstr.to_string text);
146
-
match Jsont_brr.decode Jmap.Proto.Response.jsont text with
147
-
| Error e -> Fut.return (Error e)
148
-
| Ok response -> Fut.return (Ok response)
149
-
150
-
let request_json conn json =
151
-
let headers = make_headers conn.token in
152
-
match encode_json json with
153
-
| Error e -> Fut.return (Error e)
154
-
| Ok body_str ->
155
-
let body = Brr_io.Fetch.Body.of_jstr body_str in
156
-
let* result = fetch_json
157
-
~url:conn.api_url
158
-
~meth:(Jstr.v "POST")
159
-
~headers
160
-
~body
161
-
()
162
-
in
163
-
match result with
164
-
| Error e -> Fut.return (Error e)
165
-
| Ok text ->
166
-
match decode_json text with
167
-
| Error e -> Fut.return (Error e)
168
-
| Ok json -> Fut.return (Ok json)
169
-
170
-
(* Toplevel support *)
171
-
172
-
let install_printers () =
173
-
(* In browser context, printers are registered via the OCaml console *)
174
-
Console.(log [str "JMAP printers installed"])
-107
lib/js/jmap_brr.mli
-107
lib/js/jmap_brr.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP client for browsers using Brr.
7
-
8
-
This module provides a JMAP client that runs in web browsers using
9
-
the Fetch API. It can be used with js_of_ocaml to build browser-based
10
-
email clients.
11
-
12
-
{2 Example}
13
-
14
-
{[
15
-
open Fut.Syntax
16
-
17
-
let main () =
18
-
let* session = Jmap_brr.get_session
19
-
~url:(Jstr.v "https://api.fastmail.com/jmap/session")
20
-
~token:(Jstr.v "your-api-token")
21
-
in
22
-
match session with
23
-
| Error e -> Brr.Console.(error [str "Session error:"; e]); Fut.return ()
24
-
| Ok session ->
25
-
Brr.Console.(log [str "Connected as:"; str (Jmap.Session.username session)]);
26
-
Fut.return ()
27
-
28
-
let () = ignore (main ())
29
-
]} *)
30
-
31
-
(** {1 Connection} *)
32
-
33
-
type connection
34
-
(** A JMAP connection to a server. *)
35
-
36
-
val session : connection -> Jmap.Proto.Session.t
37
-
(** [session conn] returns the session information. *)
38
-
39
-
val api_url : connection -> Jstr.t
40
-
(** [api_url conn] returns the API URL for requests. *)
41
-
42
-
(** {1 Session Establishment} *)
43
-
44
-
val get_session :
45
-
url:Jstr.t ->
46
-
token:Jstr.t ->
47
-
(connection, Jv.Error.t) result Fut.t
48
-
(** [get_session ~url ~token] establishes a JMAP session.
49
-
50
-
[url] is the session URL (e.g., ["https://api.fastmail.com/jmap/session"]).
51
-
[token] is the Bearer authentication token. *)
52
-
53
-
(** {1 Making Requests} *)
54
-
55
-
val request :
56
-
connection ->
57
-
Jmap.Proto.Request.t ->
58
-
(Jmap.Proto.Response.t, Jv.Error.t) result Fut.t
59
-
(** [request conn req] sends a JMAP request and returns the response. *)
60
-
61
-
val request_json :
62
-
connection ->
63
-
Jsont.json ->
64
-
(Jsont.json, Jv.Error.t) result Fut.t
65
-
(** [request_json conn json] sends a raw JSON request and returns the
66
-
JSON response. Useful for debugging or custom requests. *)
67
-
68
-
(** {1 JSON Encoding Utilities}
69
-
70
-
These functions help visualize how OCaml types map to JMAP JSON,
71
-
useful for the tutorial and debugging. *)
72
-
73
-
val encode_request : Jmap.Proto.Request.t -> (Jstr.t, Jv.Error.t) result
74
-
(** [encode_request req] encodes a request to JSON string. *)
75
-
76
-
val encode_response : Jmap.Proto.Response.t -> (Jstr.t, Jv.Error.t) result
77
-
(** [encode_response resp] encodes a response to JSON string. *)
78
-
79
-
val encode_session : Jmap.Proto.Session.t -> (Jstr.t, Jv.Error.t) result
80
-
(** [encode_session session] encodes a session to JSON string. *)
81
-
82
-
val decode_json : Jstr.t -> (Jsont.json, Jv.Error.t) result
83
-
(** [decode_json s] parses a JSON string to a Jsont.json value. *)
84
-
85
-
val encode_json : Jsont.json -> (Jstr.t, Jv.Error.t) result
86
-
(** [encode_json json] encodes a Jsont.json value to a string. *)
87
-
88
-
val pp_json : Format.formatter -> Jsont.json -> unit
89
-
(** [pp_json ppf json] pretty-prints JSON. For toplevel use. *)
90
-
91
-
(** {1 Protocol Logging} *)
92
-
93
-
val set_request_logger : (string -> string -> unit) -> unit
94
-
(** [set_request_logger f] registers a callback [f label json] that will be
95
-
called with each outgoing JMAP request. Useful for debugging and
96
-
educational displays. *)
97
-
98
-
val set_response_logger : (string -> string -> unit) -> unit
99
-
(** [set_response_logger f] registers a callback [f label json] that will be
100
-
called with each incoming JMAP response. Useful for debugging and
101
-
educational displays. *)
102
-
103
-
(** {1 Toplevel Support} *)
104
-
105
-
val install_printers : unit -> unit
106
-
(** [install_printers ()] installs toplevel pretty printers for JMAP types.
107
-
This is useful when using the OCaml console in the browser. *)
-56
lib/mail/mail_address.ml
-56
lib/mail/mail_address.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = {
7
-
name : string option;
8
-
email : string;
9
-
}
10
-
11
-
let create ?name email = { name; email }
12
-
13
-
let name t = t.name
14
-
let email t = t.email
15
-
16
-
let equal a b = a.email = b.email
17
-
18
-
let pp ppf t =
19
-
match t.name with
20
-
| Some name -> Format.fprintf ppf "%s <%s>" name t.email
21
-
| None -> Format.pp_print_string ppf t.email
22
-
23
-
let make name email = { name; email }
24
-
25
-
let jsont =
26
-
let kind = "EmailAddress" in
27
-
(* name can be absent, null, or a string - all map to string option *)
28
-
(* Jsont.option maps null -> None and string -> Some string *)
29
-
Jsont.Object.map ~kind make
30
-
|> Jsont.Object.mem "name" Jsont.(option string)
31
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:name
32
-
|> Jsont.Object.mem "email" Jsont.string ~enc:email
33
-
|> Jsont.Object.finish
34
-
35
-
module Group = struct
36
-
type address = t
37
-
38
-
type t = {
39
-
name : string option;
40
-
addresses : address list;
41
-
}
42
-
43
-
let create ?name addresses = { name; addresses }
44
-
45
-
let name t = t.name
46
-
let addresses t = t.addresses
47
-
48
-
let make name addresses = { name; addresses }
49
-
50
-
let jsont =
51
-
let kind = "EmailAddressGroup" in
52
-
Jsont.Object.map ~kind make
53
-
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:name
54
-
|> Jsont.Object.mem "addresses" (Jsont.list jsont) ~enc:addresses
55
-
|> Jsont.Object.finish
56
-
end
-51
lib/mail/mail_address.mli
-51
lib/mail/mail_address.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Email address types as defined in RFC 8621 Section 4.1.2.3
7
-
8
-
@canonical Jmap.Proto.Email_address *)
9
-
10
-
(** {1 Email Address} *)
11
-
12
-
(** An email address with optional display name. *)
13
-
type t = {
14
-
name : string option;
15
-
(** The display name (from the phrase in RFC 5322). *)
16
-
email : string;
17
-
(** The email address (addr-spec in RFC 5322). *)
18
-
}
19
-
20
-
val create : ?name:string -> string -> t
21
-
(** [create ?name email] creates an email address. *)
22
-
23
-
val name : t -> string option
24
-
val email : t -> string
25
-
26
-
val equal : t -> t -> bool
27
-
val pp : Format.formatter -> t -> unit
28
-
29
-
val jsont : t Jsont.t
30
-
(** JSON codec for email addresses. *)
31
-
32
-
(** {1 Address Groups} *)
33
-
34
-
(** A group of email addresses with an optional group name. *)
35
-
module Group : sig
36
-
type address = t
37
-
38
-
type t = {
39
-
name : string option;
40
-
(** The group name, or [None] for ungrouped addresses. *)
41
-
addresses : address list;
42
-
(** The addresses in this group. *)
43
-
}
44
-
45
-
val create : ?name:string -> address list -> t
46
-
47
-
val name : t -> string option
48
-
val addresses : t -> address list
49
-
50
-
val jsont : t Jsont.t
51
-
end
-95
lib/mail/mail_body.ml
-95
lib/mail/mail_body.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
module Value = struct
7
-
type t = {
8
-
value : string;
9
-
is_encoding_problem : bool;
10
-
is_truncated : bool;
11
-
}
12
-
13
-
let value t = t.value
14
-
let is_encoding_problem t = t.is_encoding_problem
15
-
let is_truncated t = t.is_truncated
16
-
17
-
let make value is_encoding_problem is_truncated =
18
-
{ value; is_encoding_problem; is_truncated }
19
-
20
-
let jsont =
21
-
let kind = "EmailBodyValue" in
22
-
Jsont.Object.map ~kind make
23
-
|> Jsont.Object.mem "value" Jsont.string ~enc:value
24
-
|> Jsont.Object.mem "isEncodingProblem" Jsont.bool ~dec_absent:false
25
-
~enc:is_encoding_problem ~enc_omit:(fun b -> not b)
26
-
|> Jsont.Object.mem "isTruncated" Jsont.bool ~dec_absent:false
27
-
~enc:is_truncated ~enc_omit:(fun b -> not b)
28
-
|> Jsont.Object.finish
29
-
end
30
-
31
-
module Part = struct
32
-
type t = {
33
-
part_id : string option;
34
-
blob_id : Proto_id.t option;
35
-
size : int64 option;
36
-
headers : Mail_header.t list option;
37
-
name : string option;
38
-
type_ : string;
39
-
charset : string option;
40
-
disposition : string option;
41
-
cid : string option;
42
-
language : string list option;
43
-
location : string option;
44
-
sub_parts : t list option;
45
-
}
46
-
47
-
let part_id t = t.part_id
48
-
let blob_id t = t.blob_id
49
-
let size t = t.size
50
-
let headers t = t.headers
51
-
let name t = t.name
52
-
let type_ t = t.type_
53
-
let charset t = t.charset
54
-
let disposition t = t.disposition
55
-
let cid t = t.cid
56
-
let language t = t.language
57
-
let location t = t.location
58
-
let sub_parts t = t.sub_parts
59
-
60
-
let rec jsont =
61
-
let kind = "EmailBodyPart" in
62
-
let make part_id blob_id size headers name type_ charset disposition
63
-
cid language location sub_parts =
64
-
{ part_id; blob_id; size; headers; name; type_; charset; disposition;
65
-
cid; language; location; sub_parts }
66
-
in
67
-
(* Many fields can be null per RFC 8621 Section 4.1.4 *)
68
-
let nullable_string = Jsont.(option string) in
69
-
let nullable_id = Jsont.(option Proto_id.jsont) in
70
-
lazy (
71
-
Jsont.Object.map ~kind make
72
-
|> Jsont.Object.mem "partId" nullable_string
73
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:part_id
74
-
|> Jsont.Object.mem "blobId" nullable_id
75
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:blob_id
76
-
|> Jsont.Object.opt_mem "size" Proto_int53.Unsigned.jsont ~enc:size
77
-
|> Jsont.Object.opt_mem "headers" (Jsont.list Mail_header.jsont) ~enc:headers
78
-
|> Jsont.Object.mem "name" nullable_string
79
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:name
80
-
|> Jsont.Object.mem "type" Jsont.string ~enc:type_
81
-
|> Jsont.Object.mem "charset" nullable_string
82
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:charset
83
-
|> Jsont.Object.mem "disposition" nullable_string
84
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:disposition
85
-
|> Jsont.Object.mem "cid" nullable_string
86
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:cid
87
-
|> Jsont.Object.opt_mem "language" (Jsont.list Jsont.string) ~enc:language
88
-
|> Jsont.Object.mem "location" nullable_string
89
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:location
90
-
|> Jsont.Object.opt_mem "subParts" (Jsont.list (Jsont.rec' jsont)) ~enc:sub_parts
91
-
|> Jsont.Object.finish
92
-
)
93
-
94
-
let jsont = Lazy.force jsont
95
-
end
-75
lib/mail/mail_body.mli
-75
lib/mail/mail_body.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Email body types as defined in RFC 8621 Section 4.1.4
7
-
8
-
@canonical Jmap.Proto.Email_body *)
9
-
10
-
(** {1 Body Value} *)
11
-
12
-
(** Fetched body part content. *)
13
-
module Value : sig
14
-
type t = {
15
-
value : string;
16
-
(** The body part content. *)
17
-
is_encoding_problem : bool;
18
-
(** True if there was a problem decoding the content transfer encoding. *)
19
-
is_truncated : bool;
20
-
(** True if the value was truncated. *)
21
-
}
22
-
23
-
val value : t -> string
24
-
val is_encoding_problem : t -> bool
25
-
val is_truncated : t -> bool
26
-
27
-
val jsont : t Jsont.t
28
-
end
29
-
30
-
(** {1 Body Part} *)
31
-
32
-
(** An email body part structure. *)
33
-
module Part : sig
34
-
type t = {
35
-
part_id : string option;
36
-
(** Identifier for this part, used to fetch content. *)
37
-
blob_id : Proto_id.t option;
38
-
(** Blob id if the part can be fetched as a blob. *)
39
-
size : int64 option;
40
-
(** Size in octets. *)
41
-
headers : Mail_header.t list option;
42
-
(** Headers specific to this part. *)
43
-
name : string option;
44
-
(** Suggested filename from Content-Disposition. *)
45
-
type_ : string;
46
-
(** MIME type (e.g., "text/plain"). *)
47
-
charset : string option;
48
-
(** Character set parameter. *)
49
-
disposition : string option;
50
-
(** Content-Disposition value. *)
51
-
cid : string option;
52
-
(** Content-ID value. *)
53
-
language : string list option;
54
-
(** Content-Language values. *)
55
-
location : string option;
56
-
(** Content-Location value. *)
57
-
sub_parts : t list option;
58
-
(** Nested parts for multipart types. *)
59
-
}
60
-
61
-
val part_id : t -> string option
62
-
val blob_id : t -> Proto_id.t option
63
-
val size : t -> int64 option
64
-
val headers : t -> Mail_header.t list option
65
-
val name : t -> string option
66
-
val type_ : t -> string
67
-
val charset : t -> string option
68
-
val disposition : t -> string option
69
-
val cid : t -> string option
70
-
val language : t -> string list option
71
-
val location : t -> string option
72
-
val sub_parts : t -> t list option
73
-
74
-
val jsont : t Jsont.t
75
-
end
-533
lib/mail/mail_email.ml
-533
lib/mail/mail_email.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
module Keyword = struct
7
-
(* RFC 8621 Standard Keywords *)
8
-
let draft = "$draft"
9
-
let seen = "$seen"
10
-
let flagged = "$flagged"
11
-
let answered = "$answered"
12
-
let forwarded = "$forwarded"
13
-
let phishing = "$phishing"
14
-
let junk = "$junk"
15
-
let not_junk = "$notjunk"
16
-
17
-
(* draft-ietf-mailmaint Extended Keywords *)
18
-
let notify = "$notify"
19
-
let muted = "$muted"
20
-
let followed = "$followed"
21
-
let memo = "$memo"
22
-
let has_memo = "$hasmemo"
23
-
let has_attachment = "$hasattachment"
24
-
let has_no_attachment = "$hasnoattachment"
25
-
let auto_sent = "$autosent"
26
-
let unsubscribed = "$unsubscribed"
27
-
let can_unsubscribe = "$canunsubscribe"
28
-
let imported = "$imported"
29
-
let is_trusted = "$istrusted"
30
-
let masked_email = "$maskedemail"
31
-
let new_ = "$new"
32
-
33
-
(* Apple Mail Flag Color Keywords *)
34
-
let mail_flag_bit0 = "$MailFlagBit0"
35
-
let mail_flag_bit1 = "$MailFlagBit1"
36
-
let mail_flag_bit2 = "$MailFlagBit2"
37
-
38
-
type flag_color = [
39
-
| `Red
40
-
| `Orange
41
-
| `Yellow
42
-
| `Green
43
-
| `Blue
44
-
| `Purple
45
-
| `Gray
46
-
]
47
-
48
-
let flag_color_to_keywords = function
49
-
| `Red -> []
50
-
| `Orange -> [mail_flag_bit0]
51
-
| `Yellow -> [mail_flag_bit1]
52
-
| `Green -> [mail_flag_bit0; mail_flag_bit1; mail_flag_bit2]
53
-
| `Blue -> [mail_flag_bit2]
54
-
| `Purple -> [mail_flag_bit0; mail_flag_bit2]
55
-
| `Gray -> [mail_flag_bit1; mail_flag_bit2]
56
-
57
-
let flag_color_of_keywords keywords =
58
-
let has k = List.mem k keywords in
59
-
let bit0 = has mail_flag_bit0 in
60
-
let bit1 = has mail_flag_bit1 in
61
-
let bit2 = has mail_flag_bit2 in
62
-
match (bit0, bit1, bit2) with
63
-
| (false, false, false) -> Some `Red
64
-
| (true, false, false) -> Some `Orange
65
-
| (false, true, false) -> Some `Yellow
66
-
| (true, true, true) -> Some `Green
67
-
| (false, false, true) -> Some `Blue
68
-
| (true, false, true) -> Some `Purple
69
-
| (false, true, true) -> Some `Gray
70
-
| (true, true, false) -> None
71
-
end
72
-
73
-
(* Email property types *)
74
-
75
-
type metadata_property = [
76
-
| `Id
77
-
| `Blob_id
78
-
| `Thread_id
79
-
| `Mailbox_ids
80
-
| `Keywords
81
-
| `Size
82
-
| `Received_at
83
-
]
84
-
85
-
type header_convenience_property = [
86
-
| `Message_id
87
-
| `In_reply_to
88
-
| `References
89
-
| `Sender
90
-
| `From
91
-
| `To
92
-
| `Cc
93
-
| `Bcc
94
-
| `Reply_to
95
-
| `Subject
96
-
| `Sent_at
97
-
| `Headers
98
-
]
99
-
100
-
type body_property = [
101
-
| `Body_structure
102
-
| `Body_values
103
-
| `Text_body
104
-
| `Html_body
105
-
| `Attachments
106
-
| `Has_attachment
107
-
| `Preview
108
-
]
109
-
110
-
type standard_property = [
111
-
| metadata_property
112
-
| header_convenience_property
113
-
| body_property
114
-
]
115
-
116
-
type header_property = [ `Header of Mail_header.header_property ]
117
-
118
-
type property = [ standard_property | header_property ]
119
-
120
-
let standard_property_to_string : [< standard_property ] -> string = function
121
-
| `Id -> "id"
122
-
| `Blob_id -> "blobId"
123
-
| `Thread_id -> "threadId"
124
-
| `Mailbox_ids -> "mailboxIds"
125
-
| `Keywords -> "keywords"
126
-
| `Size -> "size"
127
-
| `Received_at -> "receivedAt"
128
-
| `Message_id -> "messageId"
129
-
| `In_reply_to -> "inReplyTo"
130
-
| `References -> "references"
131
-
| `Sender -> "sender"
132
-
| `From -> "from"
133
-
| `To -> "to"
134
-
| `Cc -> "cc"
135
-
| `Bcc -> "bcc"
136
-
| `Reply_to -> "replyTo"
137
-
| `Subject -> "subject"
138
-
| `Sent_at -> "sentAt"
139
-
| `Headers -> "headers"
140
-
| `Body_structure -> "bodyStructure"
141
-
| `Body_values -> "bodyValues"
142
-
| `Text_body -> "textBody"
143
-
| `Html_body -> "htmlBody"
144
-
| `Attachments -> "attachments"
145
-
| `Has_attachment -> "hasAttachment"
146
-
| `Preview -> "preview"
147
-
148
-
let property_to_string : [< property ] -> string = function
149
-
| `Header hp -> Mail_header.header_property_to_string hp
150
-
| #standard_property as p -> standard_property_to_string p
151
-
152
-
let standard_property_of_string s : standard_property option =
153
-
match s with
154
-
| "id" -> Some `Id
155
-
| "blobId" -> Some `Blob_id
156
-
| "threadId" -> Some `Thread_id
157
-
| "mailboxIds" -> Some `Mailbox_ids
158
-
| "keywords" -> Some `Keywords
159
-
| "size" -> Some `Size
160
-
| "receivedAt" -> Some `Received_at
161
-
| "messageId" -> Some `Message_id
162
-
| "inReplyTo" -> Some `In_reply_to
163
-
| "references" -> Some `References
164
-
| "sender" -> Some `Sender
165
-
| "from" -> Some `From
166
-
| "to" -> Some `To
167
-
| "cc" -> Some `Cc
168
-
| "bcc" -> Some `Bcc
169
-
| "replyTo" -> Some `Reply_to
170
-
| "subject" -> Some `Subject
171
-
| "sentAt" -> Some `Sent_at
172
-
| "headers" -> Some `Headers
173
-
| "bodyStructure" -> Some `Body_structure
174
-
| "bodyValues" -> Some `Body_values
175
-
| "textBody" -> Some `Text_body
176
-
| "htmlBody" -> Some `Html_body
177
-
| "attachments" -> Some `Attachments
178
-
| "hasAttachment" -> Some `Has_attachment
179
-
| "preview" -> Some `Preview
180
-
| _ -> None
181
-
182
-
let property_of_string s : property option =
183
-
match standard_property_of_string s with
184
-
| Some p -> Some (p :> property)
185
-
| None ->
186
-
match Mail_header.header_property_of_string s with
187
-
| Some hp -> Some (`Header hp)
188
-
| None -> None
189
-
190
-
(* Body part properties *)
191
-
192
-
type body_part_property = [
193
-
| `Part_id
194
-
| `Blob_id
195
-
| `Size
196
-
| `Part_headers
197
-
| `Name
198
-
| `Type
199
-
| `Charset
200
-
| `Disposition
201
-
| `Cid
202
-
| `Language
203
-
| `Location
204
-
| `Sub_parts
205
-
]
206
-
207
-
let body_part_property_to_string : [< body_part_property ] -> string = function
208
-
| `Part_id -> "partId"
209
-
| `Blob_id -> "blobId"
210
-
| `Size -> "size"
211
-
| `Part_headers -> "headers"
212
-
| `Name -> "name"
213
-
| `Type -> "type"
214
-
| `Charset -> "charset"
215
-
| `Disposition -> "disposition"
216
-
| `Cid -> "cid"
217
-
| `Language -> "language"
218
-
| `Location -> "location"
219
-
| `Sub_parts -> "subParts"
220
-
221
-
let body_part_property_of_string s : body_part_property option =
222
-
match s with
223
-
| "partId" -> Some `Part_id
224
-
| "blobId" -> Some `Blob_id
225
-
| "size" -> Some `Size
226
-
| "headers" -> Some `Part_headers
227
-
| "name" -> Some `Name
228
-
| "type" -> Some `Type
229
-
| "charset" -> Some `Charset
230
-
| "disposition" -> Some `Disposition
231
-
| "cid" -> Some `Cid
232
-
| "language" -> Some `Language
233
-
| "location" -> Some `Location
234
-
| "subParts" -> Some `Sub_parts
235
-
| _ -> None
236
-
237
-
(* Email type with optional fields *)
238
-
239
-
type t = {
240
-
id : Proto_id.t option;
241
-
blob_id : Proto_id.t option;
242
-
thread_id : Proto_id.t option;
243
-
size : int64 option;
244
-
received_at : Ptime.t option;
245
-
mailbox_ids : (Proto_id.t * bool) list option;
246
-
keywords : (string * bool) list option;
247
-
message_id : string list option;
248
-
in_reply_to : string list option;
249
-
references : string list option;
250
-
sender : Mail_address.t list option;
251
-
from : Mail_address.t list option;
252
-
to_ : Mail_address.t list option;
253
-
cc : Mail_address.t list option;
254
-
bcc : Mail_address.t list option;
255
-
reply_to : Mail_address.t list option;
256
-
subject : string option;
257
-
sent_at : Ptime.t option;
258
-
headers : Mail_header.t list option;
259
-
body_structure : Mail_body.Part.t option;
260
-
body_values : (string * Mail_body.Value.t) list option;
261
-
text_body : Mail_body.Part.t list option;
262
-
html_body : Mail_body.Part.t list option;
263
-
attachments : Mail_body.Part.t list option;
264
-
has_attachment : bool option;
265
-
preview : string option;
266
-
dynamic_headers : (string * Jsont.json) list;
267
-
}
268
-
269
-
let id t = t.id
270
-
let blob_id t = t.blob_id
271
-
let thread_id t = t.thread_id
272
-
let size t = t.size
273
-
let received_at t = t.received_at
274
-
let mailbox_ids t = t.mailbox_ids
275
-
let keywords t = t.keywords
276
-
let message_id t = t.message_id
277
-
let in_reply_to t = t.in_reply_to
278
-
let references t = t.references
279
-
let sender t = t.sender
280
-
let from t = t.from
281
-
let to_ t = t.to_
282
-
let cc t = t.cc
283
-
let bcc t = t.bcc
284
-
let reply_to t = t.reply_to
285
-
let subject t = t.subject
286
-
let sent_at t = t.sent_at
287
-
let headers t = t.headers
288
-
let body_structure t = t.body_structure
289
-
let body_values t = t.body_values
290
-
let text_body t = t.text_body
291
-
let html_body t = t.html_body
292
-
let attachments t = t.attachments
293
-
let has_attachment t = t.has_attachment
294
-
let preview t = t.preview
295
-
let dynamic_headers_raw t = t.dynamic_headers
296
-
297
-
(* Parse header property name to determine form and :all flag *)
298
-
let parse_header_prop name =
299
-
if not (String.length name > 7 && String.sub name 0 7 = "header:") then
300
-
None
301
-
else
302
-
let rest = String.sub name 7 (String.length name - 7) in
303
-
let parts = String.split_on_char ':' rest in
304
-
match parts with
305
-
| [] -> None
306
-
| [_name] -> Some (`Raw, false)
307
-
| [_name; second] ->
308
-
if second = "all" then Some (`Raw, true)
309
-
else (
310
-
match Mail_header.form_of_string second with
311
-
| Some form -> Some (form, false)
312
-
| None -> None
313
-
)
314
-
| [_name; form_str; "all"] ->
315
-
(match Mail_header.form_of_string form_str with
316
-
| Some form -> Some (form, true)
317
-
| None -> None)
318
-
| _ -> None
319
-
320
-
(* Decode a raw JSON header value into typed header_value *)
321
-
let decode_header_value prop_name json =
322
-
match parse_header_prop prop_name with
323
-
| None -> None
324
-
| Some (form, all) ->
325
-
let jsont = Mail_header.header_value_jsont ~form ~all in
326
-
match Jsont.Json.decode' jsont json with
327
-
| Ok v -> Some v
328
-
| Error _ -> None
329
-
330
-
let get_header t key =
331
-
match List.assoc_opt key t.dynamic_headers with
332
-
| None -> None
333
-
| Some json -> decode_header_value key json
334
-
335
-
let get_header_string t key =
336
-
match get_header t key with
337
-
| Some (Mail_header.String_single s) -> s
338
-
| _ -> None
339
-
340
-
let get_header_addresses t key =
341
-
match get_header t key with
342
-
| Some (Mail_header.Addresses_single addrs) -> addrs
343
-
| _ -> None
344
-
345
-
let make id blob_id thread_id size received_at mailbox_ids keywords
346
-
message_id in_reply_to references sender from to_ cc bcc reply_to
347
-
subject sent_at headers body_structure body_values text_body html_body
348
-
attachments has_attachment preview dynamic_headers =
349
-
{ id; blob_id; thread_id; size; received_at; mailbox_ids; keywords;
350
-
message_id; in_reply_to; references; sender; from; to_; cc; bcc;
351
-
reply_to; subject; sent_at; headers; body_structure; body_values;
352
-
text_body; html_body; attachments; has_attachment; preview; dynamic_headers }
353
-
354
-
(* Helper: null-safe list decoder - treats null as empty list.
355
-
This allows fields that may be null or array to decode successfully. *)
356
-
let null_safe_list inner_jsont =
357
-
Jsont.map
358
-
~dec:(function None -> [] | Some l -> l)
359
-
~enc:(fun l -> Some l)
360
-
(Jsont.option (Jsont.list inner_jsont))
361
-
362
-
module String_map = Map.Make(String)
363
-
364
-
(* Filter unknown members to only keep header:* properties *)
365
-
let filter_header_props (unknown : Jsont.json String_map.t) : (string * Jsont.json) list =
366
-
String_map.to_seq unknown
367
-
|> Seq.filter (fun (k, _) -> String.length k > 7 && String.sub k 0 7 = "header:")
368
-
|> List.of_seq
369
-
370
-
let jsont =
371
-
let kind = "Email" in
372
-
let body_values_jsont = Proto_json_map.of_string Mail_body.Value.jsont in
373
-
(* Use null_safe_list for address fields that can be null *)
374
-
let addr_list = null_safe_list Mail_address.jsont in
375
-
let str_list = null_safe_list Jsont.string in
376
-
let part_list = null_safe_list Mail_body.Part.jsont in
377
-
let hdr_list = null_safe_list Mail_header.jsont in
378
-
Jsont.Object.map ~kind (fun id blob_id thread_id size received_at mailbox_ids keywords
379
-
message_id in_reply_to references sender from to_ cc bcc reply_to
380
-
subject sent_at headers body_structure body_values text_body html_body
381
-
attachments has_attachment preview unknown ->
382
-
let dynamic_headers = filter_header_props unknown in
383
-
make id blob_id thread_id size received_at mailbox_ids keywords
384
-
message_id in_reply_to references sender from to_ cc bcc reply_to
385
-
subject sent_at headers body_structure body_values text_body html_body
386
-
attachments has_attachment preview dynamic_headers)
387
-
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
388
-
|> Jsont.Object.opt_mem "blobId" Proto_id.jsont ~enc:blob_id
389
-
|> Jsont.Object.opt_mem "threadId" Proto_id.jsont ~enc:thread_id
390
-
|> Jsont.Object.opt_mem "size" Proto_int53.Unsigned.jsont ~enc:size
391
-
|> Jsont.Object.opt_mem "receivedAt" Proto_date.Utc.jsont ~enc:received_at
392
-
|> Jsont.Object.opt_mem "mailboxIds" Proto_json_map.id_to_bool ~enc:mailbox_ids
393
-
|> Jsont.Object.opt_mem "keywords" Proto_json_map.string_to_bool ~enc:keywords
394
-
|> Jsont.Object.opt_mem "messageId" str_list ~enc:message_id
395
-
|> Jsont.Object.opt_mem "inReplyTo" str_list ~enc:in_reply_to
396
-
|> Jsont.Object.opt_mem "references" str_list ~enc:references
397
-
|> Jsont.Object.opt_mem "sender" addr_list ~enc:sender
398
-
|> Jsont.Object.opt_mem "from" addr_list ~enc:from
399
-
|> Jsont.Object.opt_mem "to" addr_list ~enc:to_
400
-
|> Jsont.Object.opt_mem "cc" addr_list ~enc:cc
401
-
|> Jsont.Object.opt_mem "bcc" addr_list ~enc:bcc
402
-
|> Jsont.Object.opt_mem "replyTo" addr_list ~enc:reply_to
403
-
|> Jsont.Object.opt_mem "subject" Jsont.string ~enc:subject
404
-
|> Jsont.Object.opt_mem "sentAt" Proto_date.Rfc3339.jsont ~enc:sent_at
405
-
|> Jsont.Object.opt_mem "headers" hdr_list ~enc:headers
406
-
|> Jsont.Object.opt_mem "bodyStructure" Mail_body.Part.jsont ~enc:body_structure
407
-
|> Jsont.Object.opt_mem "bodyValues" body_values_jsont ~enc:body_values
408
-
|> Jsont.Object.opt_mem "textBody" part_list ~enc:text_body
409
-
|> Jsont.Object.opt_mem "htmlBody" part_list ~enc:html_body
410
-
|> Jsont.Object.opt_mem "attachments" part_list ~enc:attachments
411
-
|> Jsont.Object.opt_mem "hasAttachment" Jsont.bool ~enc:has_attachment
412
-
|> Jsont.Object.opt_mem "preview" Jsont.string ~enc:preview
413
-
|> Jsont.Object.keep_unknown
414
-
(Jsont.Object.Mems.string_map Jsont.json)
415
-
~enc:(fun t -> String_map.of_list t.dynamic_headers)
416
-
|> Jsont.Object.finish
417
-
418
-
module Filter_condition = struct
419
-
type t = {
420
-
in_mailbox : Proto_id.t option;
421
-
in_mailbox_other_than : Proto_id.t list option;
422
-
before : Ptime.t option;
423
-
after : Ptime.t option;
424
-
min_size : int64 option;
425
-
max_size : int64 option;
426
-
all_in_thread_have_keyword : string option;
427
-
some_in_thread_have_keyword : string option;
428
-
none_in_thread_have_keyword : string option;
429
-
has_keyword : string option;
430
-
not_keyword : string option;
431
-
has_attachment : bool option;
432
-
text : string option;
433
-
from : string option;
434
-
to_ : string option;
435
-
cc : string option;
436
-
bcc : string option;
437
-
subject : string option;
438
-
body : string option;
439
-
header : (string * string option) option;
440
-
}
441
-
442
-
let make in_mailbox in_mailbox_other_than before after min_size max_size
443
-
all_in_thread_have_keyword some_in_thread_have_keyword
444
-
none_in_thread_have_keyword has_keyword not_keyword has_attachment
445
-
text from to_ cc bcc subject body header =
446
-
{ in_mailbox; in_mailbox_other_than; before; after; min_size; max_size;
447
-
all_in_thread_have_keyword; some_in_thread_have_keyword;
448
-
none_in_thread_have_keyword; has_keyword; not_keyword; has_attachment;
449
-
text; from; to_; cc; bcc; subject; body; header }
450
-
451
-
let header_jsont =
452
-
let kind = "HeaderFilter" in
453
-
let dec json =
454
-
match json with
455
-
| Jsont.Array ([Jsont.String (name, _)], _) ->
456
-
(name, None)
457
-
| Jsont.Array ([Jsont.String (name, _); Jsont.String (value, _)], _) ->
458
-
(name, Some value)
459
-
| _ ->
460
-
Jsont.Error.msgf Jsont.Meta.none "%s: expected [name] or [name, value]" kind
461
-
in
462
-
let enc (name, value) =
463
-
match value with
464
-
| None -> Jsont.Array ([Jsont.String (name, Jsont.Meta.none)], Jsont.Meta.none)
465
-
| Some v -> Jsont.Array ([Jsont.String (name, Jsont.Meta.none); Jsont.String (v, Jsont.Meta.none)], Jsont.Meta.none)
466
-
in
467
-
Jsont.map ~kind ~dec ~enc Jsont.json
468
-
469
-
let jsont =
470
-
let kind = "EmailFilterCondition" in
471
-
Jsont.Object.map ~kind make
472
-
|> Jsont.Object.opt_mem "inMailbox" Proto_id.jsont ~enc:(fun f -> f.in_mailbox)
473
-
|> Jsont.Object.opt_mem "inMailboxOtherThan" (Jsont.list Proto_id.jsont) ~enc:(fun f -> f.in_mailbox_other_than)
474
-
|> Jsont.Object.opt_mem "before" Proto_date.Utc.jsont ~enc:(fun f -> f.before)
475
-
|> Jsont.Object.opt_mem "after" Proto_date.Utc.jsont ~enc:(fun f -> f.after)
476
-
|> Jsont.Object.opt_mem "minSize" Proto_int53.Unsigned.jsont ~enc:(fun f -> f.min_size)
477
-
|> Jsont.Object.opt_mem "maxSize" Proto_int53.Unsigned.jsont ~enc:(fun f -> f.max_size)
478
-
|> Jsont.Object.opt_mem "allInThreadHaveKeyword" Jsont.string ~enc:(fun f -> f.all_in_thread_have_keyword)
479
-
|> Jsont.Object.opt_mem "someInThreadHaveKeyword" Jsont.string ~enc:(fun f -> f.some_in_thread_have_keyword)
480
-
|> Jsont.Object.opt_mem "noneInThreadHaveKeyword" Jsont.string ~enc:(fun f -> f.none_in_thread_have_keyword)
481
-
|> Jsont.Object.opt_mem "hasKeyword" Jsont.string ~enc:(fun f -> f.has_keyword)
482
-
|> Jsont.Object.opt_mem "notKeyword" Jsont.string ~enc:(fun f -> f.not_keyword)
483
-
|> Jsont.Object.opt_mem "hasAttachment" Jsont.bool ~enc:(fun f -> f.has_attachment)
484
-
|> Jsont.Object.opt_mem "text" Jsont.string ~enc:(fun f -> f.text)
485
-
|> Jsont.Object.opt_mem "from" Jsont.string ~enc:(fun f -> f.from)
486
-
|> Jsont.Object.opt_mem "to" Jsont.string ~enc:(fun f -> f.to_)
487
-
|> Jsont.Object.opt_mem "cc" Jsont.string ~enc:(fun f -> f.cc)
488
-
|> Jsont.Object.opt_mem "bcc" Jsont.string ~enc:(fun f -> f.bcc)
489
-
|> Jsont.Object.opt_mem "subject" Jsont.string ~enc:(fun f -> f.subject)
490
-
|> Jsont.Object.opt_mem "body" Jsont.string ~enc:(fun f -> f.body)
491
-
|> Jsont.Object.opt_mem "header" header_jsont ~enc:(fun f -> f.header)
492
-
|> Jsont.Object.finish
493
-
end
494
-
495
-
type get_args_extra = {
496
-
body_properties : body_part_property list option;
497
-
fetch_text_body_values : bool;
498
-
fetch_html_body_values : bool;
499
-
fetch_all_body_values : bool;
500
-
max_body_value_bytes : int64 option;
501
-
}
502
-
503
-
let get_args_extra ?body_properties ?(fetch_text_body_values=false)
504
-
?(fetch_html_body_values=false) ?(fetch_all_body_values=false)
505
-
?max_body_value_bytes () =
506
-
{ body_properties; fetch_text_body_values; fetch_html_body_values;
507
-
fetch_all_body_values; max_body_value_bytes }
508
-
509
-
let body_part_property_list_jsont =
510
-
Jsont.list (Jsont.map ~kind:"body_part_property"
511
-
~dec:(fun s -> match body_part_property_of_string s with
512
-
| Some p -> p
513
-
| None -> Jsont.Error.msgf Jsont.Meta.none "Unknown body property: %s" s)
514
-
~enc:body_part_property_to_string
515
-
Jsont.string)
516
-
517
-
let get_args_extra_jsont =
518
-
let kind = "Email/get extra args" in
519
-
Jsont.Object.map ~kind (fun body_properties fetch_text_body_values
520
-
fetch_html_body_values fetch_all_body_values max_body_value_bytes ->
521
-
{ body_properties; fetch_text_body_values; fetch_html_body_values;
522
-
fetch_all_body_values; max_body_value_bytes })
523
-
|> Jsont.Object.opt_mem "bodyProperties" body_part_property_list_jsont
524
-
~enc:(fun a -> a.body_properties)
525
-
|> Jsont.Object.mem "fetchTextBodyValues" Jsont.bool ~dec_absent:false
526
-
~enc:(fun a -> a.fetch_text_body_values) ~enc_omit:(fun b -> not b)
527
-
|> Jsont.Object.mem "fetchHTMLBodyValues" Jsont.bool ~dec_absent:false
528
-
~enc:(fun a -> a.fetch_html_body_values) ~enc_omit:(fun b -> not b)
529
-
|> Jsont.Object.mem "fetchAllBodyValues" Jsont.bool ~dec_absent:false
530
-
~enc:(fun a -> a.fetch_all_body_values) ~enc_omit:(fun b -> not b)
531
-
|> Jsont.Object.opt_mem "maxBodyValueBytes" Proto_int53.Unsigned.jsont
532
-
~enc:(fun a -> a.max_body_value_bytes)
533
-
|> Jsont.Object.finish
-401
lib/mail/mail_email.mli
-401
lib/mail/mail_email.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Email type as defined in RFC 8621 Section 4
7
-
8
-
@canonical Jmap.Proto.Email *)
9
-
10
-
(** {1 Standard Keywords} *)
11
-
12
-
(** Standard email keywords per RFC 8621 and draft-ietf-mailmaint.
13
-
14
-
Keywords are stored as strings in JMAP, but these constants provide
15
-
type-safe access to standard keywords. *)
16
-
module Keyword : sig
17
-
18
-
(** {2 RFC 8621 Standard Keywords} *)
19
-
20
-
val draft : string
21
-
(** ["$draft"] - The Email is a draft the user is composing. *)
22
-
23
-
val seen : string
24
-
(** ["$seen"] - The Email has been read. *)
25
-
26
-
val flagged : string
27
-
(** ["$flagged"] - The Email has been flagged for urgent/special attention. *)
28
-
29
-
val answered : string
30
-
(** ["$answered"] - The Email has been replied to. *)
31
-
32
-
val forwarded : string
33
-
(** ["$forwarded"] - The Email has been forwarded. *)
34
-
35
-
val phishing : string
36
-
(** ["$phishing"] - The Email is highly likely to be phishing. *)
37
-
38
-
val junk : string
39
-
(** ["$junk"] - The Email is definitely spam. *)
40
-
41
-
val not_junk : string
42
-
(** ["$notjunk"] - The Email is definitely not spam. *)
43
-
44
-
(** {2 draft-ietf-mailmaint Extended Keywords} *)
45
-
46
-
val notify : string
47
-
(** ["$notify"] - A notification should be shown for this message. *)
48
-
49
-
val muted : string
50
-
(** ["$muted"] - The user is not interested in future replies to this thread. *)
51
-
52
-
val followed : string
53
-
(** ["$followed"] - The user is particularly interested in future replies
54
-
to this thread. Mutually exclusive with muted. *)
55
-
56
-
val memo : string
57
-
(** ["$memo"] - The message is a note-to-self regarding another message
58
-
in the same thread. *)
59
-
60
-
val has_memo : string
61
-
(** ["$hasmemo"] - The message has an associated memo with the $memo keyword. *)
62
-
63
-
val has_attachment : string
64
-
(** ["$hasattachment"] - The message has an attachment (server-set). *)
65
-
66
-
val has_no_attachment : string
67
-
(** ["$hasnoattachment"] - The message does not have an attachment (server-set). *)
68
-
69
-
val auto_sent : string
70
-
(** ["$autosent"] - The message was sent automatically as a response
71
-
due to a user rule or setting (e.g., vacation response). *)
72
-
73
-
val unsubscribed : string
74
-
(** ["$unsubscribed"] - The client has unsubscribed from this mailing list. *)
75
-
76
-
val can_unsubscribe : string
77
-
(** ["$canunsubscribe"] - The message has an RFC8058-compliant
78
-
List-Unsubscribe header. *)
79
-
80
-
val imported : string
81
-
(** ["$imported"] - The message was imported from another mailbox. *)
82
-
83
-
val is_trusted : string
84
-
(** ["$istrusted"] - The authenticity of the from name and email address
85
-
have been verified with complete confidence by the server. *)
86
-
87
-
val masked_email : string
88
-
(** ["$maskedemail"] - The message was received via an alias created for
89
-
an individual sender to hide the user's real email address. *)
90
-
91
-
val new_ : string
92
-
(** ["$new"] - The message should be made more prominent to the user
93
-
due to a recent action (e.g., awakening from snooze). *)
94
-
95
-
(** {2 Apple Mail Flag Color Keywords}
96
-
97
-
These 3 keywords form a 3-bit bitmask defining the flag color:
98
-
- 000 = red, 100 = orange, 010 = yellow, 111 = green
99
-
- 001 = blue, 101 = purple, 011 = gray
100
-
101
-
These are only meaningful when the message has the $flagged keyword set. *)
102
-
103
-
val mail_flag_bit0 : string
104
-
(** ["$MailFlagBit0"] - Bit 0 of the flag color bitmask. *)
105
-
106
-
val mail_flag_bit1 : string
107
-
(** ["$MailFlagBit1"] - Bit 1 of the flag color bitmask. *)
108
-
109
-
val mail_flag_bit2 : string
110
-
(** ["$MailFlagBit2"] - Bit 2 of the flag color bitmask. *)
111
-
112
-
(** {2 Flag Color Type}
113
-
114
-
High-level type for working with Apple Mail flag colors. *)
115
-
116
-
type flag_color = [
117
-
| `Red (** Bits: 000 *)
118
-
| `Orange (** Bits: 100 *)
119
-
| `Yellow (** Bits: 010 *)
120
-
| `Green (** Bits: 111 *)
121
-
| `Blue (** Bits: 001 *)
122
-
| `Purple (** Bits: 101 *)
123
-
| `Gray (** Bits: 011 *)
124
-
]
125
-
126
-
val flag_color_to_keywords : flag_color -> string list
127
-
(** [flag_color_to_keywords color] returns the list of $MailFlagBit keywords
128
-
that should be set for the given color. *)
129
-
130
-
val flag_color_of_keywords : string list -> flag_color option
131
-
(** [flag_color_of_keywords keywords] extracts the flag color from a list
132
-
of keywords, if the $MailFlagBit keywords are present. Returns [None]
133
-
if no color bits are set (defaults to red when $flagged is set). *)
134
-
end
135
-
136
-
(** {1 Email Properties}
137
-
138
-
Polymorphic variants for type-safe property selection in Email/get requests.
139
-
These correspond to the properties defined in RFC 8621 Section 4.1. *)
140
-
141
-
(** Metadata properties (RFC 8621 Section 4.1.1).
142
-
These represent data about the message in the mail store. *)
143
-
type metadata_property = [
144
-
| `Id
145
-
| `Blob_id
146
-
| `Thread_id
147
-
| `Mailbox_ids
148
-
| `Keywords
149
-
| `Size
150
-
| `Received_at
151
-
]
152
-
153
-
(** Convenience header properties (RFC 8621 Section 4.1.3).
154
-
These are shortcuts for specific header:*:form properties. *)
155
-
type header_convenience_property = [
156
-
| `Message_id (** = header:Message-ID:asMessageIds *)
157
-
| `In_reply_to (** = header:In-Reply-To:asMessageIds *)
158
-
| `References (** = header:References:asMessageIds *)
159
-
| `Sender (** = header:Sender:asAddresses *)
160
-
| `From (** = header:From:asAddresses *)
161
-
| `To (** = header:To:asAddresses *)
162
-
| `Cc (** = header:Cc:asAddresses *)
163
-
| `Bcc (** = header:Bcc:asAddresses *)
164
-
| `Reply_to (** = header:Reply-To:asAddresses *)
165
-
| `Subject (** = header:Subject:asText *)
166
-
| `Sent_at (** = header:Date:asDate *)
167
-
| `Headers (** All headers in raw form *)
168
-
]
169
-
170
-
(** Body properties (RFC 8621 Section 4.1.4).
171
-
These represent the message body structure and content. *)
172
-
type body_property = [
173
-
| `Body_structure
174
-
| `Body_values
175
-
| `Text_body
176
-
| `Html_body
177
-
| `Attachments
178
-
| `Has_attachment
179
-
| `Preview
180
-
]
181
-
182
-
(** All standard Email properties. *)
183
-
type standard_property = [
184
-
| metadata_property
185
-
| header_convenience_property
186
-
| body_property
187
-
]
188
-
189
-
(** A dynamic header property request.
190
-
Use {!Mail_header.header_property} for type-safe construction. *)
191
-
type header_property = [ `Header of Mail_header.header_property ]
192
-
193
-
(** Any Email property - standard or dynamic header. *)
194
-
type property = [ standard_property | header_property ]
195
-
196
-
val property_to_string : [< property ] -> string
197
-
(** Convert a property to its wire name (e.g., [`From] -> "from"). *)
198
-
199
-
val property_of_string : string -> property option
200
-
(** Parse a property name. Returns [None] for unrecognized properties.
201
-
Handles both standard properties and header:* properties. *)
202
-
203
-
val standard_property_of_string : string -> standard_property option
204
-
(** Parse only standard property names (not header:* properties). *)
205
-
206
-
(** {1 Body Part Properties}
207
-
208
-
Properties that can be requested for EmailBodyPart objects
209
-
via the [bodyProperties] argument. *)
210
-
211
-
type body_part_property = [
212
-
| `Part_id
213
-
| `Blob_id
214
-
| `Size
215
-
| `Part_headers (** Named [headers] in the wire format *)
216
-
| `Name
217
-
| `Type
218
-
| `Charset
219
-
| `Disposition
220
-
| `Cid
221
-
| `Language
222
-
| `Location
223
-
| `Sub_parts
224
-
]
225
-
226
-
val body_part_property_to_string : [< body_part_property ] -> string
227
-
(** Convert a body part property to its wire name. *)
228
-
229
-
val body_part_property_of_string : string -> body_part_property option
230
-
(** Parse a body part property name. *)
231
-
232
-
(** {1 Email Object} *)
233
-
234
-
type t = {
235
-
(* Metadata - server-set, immutable *)
236
-
id : Proto_id.t option;
237
-
blob_id : Proto_id.t option;
238
-
thread_id : Proto_id.t option;
239
-
size : int64 option;
240
-
received_at : Ptime.t option;
241
-
242
-
(* Metadata - mutable *)
243
-
mailbox_ids : (Proto_id.t * bool) list option;
244
-
keywords : (string * bool) list option;
245
-
246
-
(* Parsed headers *)
247
-
message_id : string list option;
248
-
in_reply_to : string list option;
249
-
references : string list option;
250
-
sender : Mail_address.t list option;
251
-
from : Mail_address.t list option;
252
-
to_ : Mail_address.t list option;
253
-
cc : Mail_address.t list option;
254
-
bcc : Mail_address.t list option;
255
-
reply_to : Mail_address.t list option;
256
-
subject : string option;
257
-
sent_at : Ptime.t option;
258
-
259
-
(* Raw headers *)
260
-
headers : Mail_header.t list option;
261
-
262
-
(* Body structure *)
263
-
body_structure : Mail_body.Part.t option;
264
-
body_values : (string * Mail_body.Value.t) list option;
265
-
text_body : Mail_body.Part.t list option;
266
-
html_body : Mail_body.Part.t list option;
267
-
attachments : Mail_body.Part.t list option;
268
-
has_attachment : bool option;
269
-
preview : string option;
270
-
271
-
(* Dynamic header properties - stored as raw JSON for lazy decoding *)
272
-
dynamic_headers : (string * Jsont.json) list;
273
-
(** Raw header values from [header:*] property requests.
274
-
The key is the full property name (e.g., "header:X-Custom:asText").
275
-
Use {!decode_header_value} to parse into typed values. *)
276
-
}
277
-
278
-
(** {2 Accessors}
279
-
280
-
All accessors return [option] types since the response only includes
281
-
properties that were requested. *)
282
-
283
-
val id : t -> Proto_id.t option
284
-
val blob_id : t -> Proto_id.t option
285
-
val thread_id : t -> Proto_id.t option
286
-
val size : t -> int64 option
287
-
val received_at : t -> Ptime.t option
288
-
val mailbox_ids : t -> (Proto_id.t * bool) list option
289
-
val keywords : t -> (string * bool) list option
290
-
val message_id : t -> string list option
291
-
val in_reply_to : t -> string list option
292
-
val references : t -> string list option
293
-
val sender : t -> Mail_address.t list option
294
-
val from : t -> Mail_address.t list option
295
-
val to_ : t -> Mail_address.t list option
296
-
val cc : t -> Mail_address.t list option
297
-
val bcc : t -> Mail_address.t list option
298
-
val reply_to : t -> Mail_address.t list option
299
-
val subject : t -> string option
300
-
val sent_at : t -> Ptime.t option
301
-
val headers : t -> Mail_header.t list option
302
-
val body_structure : t -> Mail_body.Part.t option
303
-
val body_values : t -> (string * Mail_body.Value.t) list option
304
-
val text_body : t -> Mail_body.Part.t list option
305
-
val html_body : t -> Mail_body.Part.t list option
306
-
val attachments : t -> Mail_body.Part.t list option
307
-
val has_attachment : t -> bool option
308
-
val preview : t -> string option
309
-
val dynamic_headers_raw : t -> (string * Jsont.json) list
310
-
(** Get raw dynamic headers. Use {!decode_header_value} to parse them. *)
311
-
312
-
(** {2 Dynamic Header Decoding} *)
313
-
314
-
val decode_header_value : string -> Jsont.json -> Mail_header.header_value option
315
-
(** [decode_header_value prop_name json] decodes a raw JSON value into a typed
316
-
header value based on the property name. The property name determines the form:
317
-
- [header:Name] or [header:Name:all] -> Raw/Text (String_single/String_all)
318
-
- [header:Name:asText] -> Text (String_single)
319
-
- [header:Name:asAddresses] -> Addresses (Addresses_single)
320
-
- [header:Name:asGroupedAddresses] -> Grouped (Grouped_single)
321
-
- [header:Name:asMessageIds] -> MessageIds (Strings_single)
322
-
- [header:Name:asDate] -> Date (Date_single)
323
-
- [header:Name:asURLs] -> URLs (Strings_single)
324
-
Returns [None] if the property name is invalid or decoding fails. *)
325
-
326
-
val get_header : t -> string -> Mail_header.header_value option
327
-
(** [get_header email key] looks up and decodes a dynamic header by its full
328
-
property name. E.g., [get_header email "header:X-Custom:asText"]. *)
329
-
330
-
val get_header_string : t -> string -> string option
331
-
(** [get_header_string email key] looks up a string header value.
332
-
Returns [None] if not found or if the value is not a string type. *)
333
-
334
-
val get_header_addresses : t -> string -> Mail_address.t list option
335
-
(** [get_header_addresses email key] looks up an addresses header value.
336
-
Returns [None] if not found or if the value is not an addresses type. *)
337
-
338
-
val jsont : t Jsont.t
339
-
(** Permissive JSON codec that handles any subset of properties.
340
-
Unknown [header:*] properties are decoded into {!dynamic_headers}. *)
341
-
342
-
(** {1 Email Filter Conditions} *)
343
-
344
-
module Filter_condition : sig
345
-
type t = {
346
-
in_mailbox : Proto_id.t option;
347
-
in_mailbox_other_than : Proto_id.t list option;
348
-
before : Ptime.t option;
349
-
after : Ptime.t option;
350
-
min_size : int64 option;
351
-
max_size : int64 option;
352
-
all_in_thread_have_keyword : string option;
353
-
some_in_thread_have_keyword : string option;
354
-
none_in_thread_have_keyword : string option;
355
-
has_keyword : string option;
356
-
not_keyword : string option;
357
-
has_attachment : bool option;
358
-
text : string option;
359
-
from : string option;
360
-
to_ : string option;
361
-
cc : string option;
362
-
bcc : string option;
363
-
subject : string option;
364
-
body : string option;
365
-
header : (string * string option) option;
366
-
}
367
-
368
-
val jsont : t Jsont.t
369
-
end
370
-
371
-
(** {1 Email/get Arguments} *)
372
-
373
-
(** Extra arguments for Email/get beyond standard /get.
374
-
375
-
Note: The standard [properties] argument from {!Proto_method.get_args}
376
-
should use {!property} variants converted via {!property_to_string}. *)
377
-
type get_args_extra = {
378
-
body_properties : body_part_property list option;
379
-
(** Properties to fetch for each EmailBodyPart.
380
-
If omitted, defaults to all properties. *)
381
-
fetch_text_body_values : bool;
382
-
(** If [true], fetch body values for text/* parts in textBody. *)
383
-
fetch_html_body_values : bool;
384
-
(** If [true], fetch body values for text/* parts in htmlBody. *)
385
-
fetch_all_body_values : bool;
386
-
(** If [true], fetch body values for all text/* parts. *)
387
-
max_body_value_bytes : int64 option;
388
-
(** Maximum size of body values to return. Larger values are truncated. *)
389
-
}
390
-
391
-
val get_args_extra :
392
-
?body_properties:body_part_property list ->
393
-
?fetch_text_body_values:bool ->
394
-
?fetch_html_body_values:bool ->
395
-
?fetch_all_body_values:bool ->
396
-
?max_body_value_bytes:int64 ->
397
-
unit ->
398
-
get_args_extra
399
-
(** Convenience constructor with sensible defaults. *)
400
-
401
-
val get_args_extra_jsont : get_args_extra Jsont.t
-16
lib/mail/mail_filter.ml
-16
lib/mail/mail_filter.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type email_filter = Mail_email.Filter_condition.t Proto_filter.filter
7
-
8
-
let email_filter_jsont = Proto_filter.filter_jsont Mail_email.Filter_condition.jsont
9
-
10
-
type mailbox_filter = Mail_mailbox.Filter_condition.t Proto_filter.filter
11
-
12
-
let mailbox_filter_jsont = Proto_filter.filter_jsont Mail_mailbox.Filter_condition.jsont
13
-
14
-
type submission_filter = Mail_submission.Filter_condition.t Proto_filter.filter
15
-
16
-
let submission_filter_jsont = Proto_filter.filter_jsont Mail_submission.Filter_condition.jsont
-23
lib/mail/mail_filter.mli
-23
lib/mail/mail_filter.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Mail-specific filter types
7
-
8
-
@canonical Jmap.Proto.Mail_filter *)
9
-
10
-
(** Email filter with Email-specific conditions. *)
11
-
type email_filter = Mail_email.Filter_condition.t Proto_filter.filter
12
-
13
-
val email_filter_jsont : email_filter Jsont.t
14
-
15
-
(** Mailbox filter with Mailbox-specific conditions. *)
16
-
type mailbox_filter = Mail_mailbox.Filter_condition.t Proto_filter.filter
17
-
18
-
val mailbox_filter_jsont : mailbox_filter Jsont.t
19
-
20
-
(** EmailSubmission filter with Submission-specific conditions. *)
21
-
type submission_filter = Mail_submission.Filter_condition.t Proto_filter.filter
22
-
23
-
val submission_filter_jsont : submission_filter Jsont.t
-370
lib/mail/mail_header.ml
-370
lib/mail/mail_header.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = {
7
-
name : string;
8
-
value : string;
9
-
}
10
-
11
-
let create ~name ~value = { name; value }
12
-
13
-
let name t = t.name
14
-
let value t = t.value
15
-
16
-
let make name value = { name; value }
17
-
18
-
let jsont =
19
-
let kind = "EmailHeader" in
20
-
Jsont.Object.map ~kind make
21
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
22
-
|> Jsont.Object.mem "value" Jsont.string ~enc:value
23
-
|> Jsont.Object.finish
24
-
25
-
(* Header categories *)
26
-
27
-
type address_header = [
28
-
| `From
29
-
| `Sender
30
-
| `Reply_to
31
-
| `To
32
-
| `Cc
33
-
| `Bcc
34
-
| `Resent_from
35
-
| `Resent_sender
36
-
| `Resent_reply_to
37
-
| `Resent_to
38
-
| `Resent_cc
39
-
| `Resent_bcc
40
-
]
41
-
42
-
type message_id_header = [
43
-
| `Message_id
44
-
| `In_reply_to
45
-
| `References
46
-
| `Resent_message_id
47
-
]
48
-
49
-
type date_header = [
50
-
| `Date
51
-
| `Resent_date
52
-
]
53
-
54
-
type url_header = [
55
-
| `List_help
56
-
| `List_unsubscribe
57
-
| `List_subscribe
58
-
| `List_post
59
-
| `List_owner
60
-
| `List_archive
61
-
]
62
-
63
-
type text_header = [
64
-
| `Subject
65
-
| `Comments
66
-
| `Keywords
67
-
| `List_id
68
-
]
69
-
70
-
type standard_header = [
71
-
| address_header
72
-
| message_id_header
73
-
| date_header
74
-
| url_header
75
-
| text_header
76
-
]
77
-
78
-
type custom_header = [ `Custom of string ]
79
-
80
-
type any_header = [ standard_header | custom_header ]
81
-
82
-
let standard_header_to_string : [< standard_header ] -> string = function
83
-
| `From -> "From"
84
-
| `Sender -> "Sender"
85
-
| `Reply_to -> "Reply-To"
86
-
| `To -> "To"
87
-
| `Cc -> "Cc"
88
-
| `Bcc -> "Bcc"
89
-
| `Resent_from -> "Resent-From"
90
-
| `Resent_sender -> "Resent-Sender"
91
-
| `Resent_reply_to -> "Resent-Reply-To"
92
-
| `Resent_to -> "Resent-To"
93
-
| `Resent_cc -> "Resent-Cc"
94
-
| `Resent_bcc -> "Resent-Bcc"
95
-
| `Message_id -> "Message-ID"
96
-
| `In_reply_to -> "In-Reply-To"
97
-
| `References -> "References"
98
-
| `Resent_message_id -> "Resent-Message-ID"
99
-
| `Date -> "Date"
100
-
| `Resent_date -> "Resent-Date"
101
-
| `List_help -> "List-Help"
102
-
| `List_unsubscribe -> "List-Unsubscribe"
103
-
| `List_subscribe -> "List-Subscribe"
104
-
| `List_post -> "List-Post"
105
-
| `List_owner -> "List-Owner"
106
-
| `List_archive -> "List-Archive"
107
-
| `Subject -> "Subject"
108
-
| `Comments -> "Comments"
109
-
| `Keywords -> "Keywords"
110
-
| `List_id -> "List-Id"
111
-
112
-
let standard_header_of_string s : standard_header option =
113
-
match String.lowercase_ascii s with
114
-
| "from" -> Some `From
115
-
| "sender" -> Some `Sender
116
-
| "reply-to" -> Some `Reply_to
117
-
| "to" -> Some `To
118
-
| "cc" -> Some `Cc
119
-
| "bcc" -> Some `Bcc
120
-
| "resent-from" -> Some `Resent_from
121
-
| "resent-sender" -> Some `Resent_sender
122
-
| "resent-reply-to" -> Some `Resent_reply_to
123
-
| "resent-to" -> Some `Resent_to
124
-
| "resent-cc" -> Some `Resent_cc
125
-
| "resent-bcc" -> Some `Resent_bcc
126
-
| "message-id" -> Some `Message_id
127
-
| "in-reply-to" -> Some `In_reply_to
128
-
| "references" -> Some `References
129
-
| "resent-message-id" -> Some `Resent_message_id
130
-
| "date" -> Some `Date
131
-
| "resent-date" -> Some `Resent_date
132
-
| "list-help" -> Some `List_help
133
-
| "list-unsubscribe" -> Some `List_unsubscribe
134
-
| "list-subscribe" -> Some `List_subscribe
135
-
| "list-post" -> Some `List_post
136
-
| "list-owner" -> Some `List_owner
137
-
| "list-archive" -> Some `List_archive
138
-
| "subject" -> Some `Subject
139
-
| "comments" -> Some `Comments
140
-
| "keywords" -> Some `Keywords
141
-
| "list-id" -> Some `List_id
142
-
| _ -> None
143
-
144
-
let any_header_to_string : [< any_header ] -> string = function
145
-
| `Custom s -> s
146
-
| #standard_header as h -> standard_header_to_string h
147
-
148
-
(* Header parsed forms *)
149
-
150
-
type form = [
151
-
| `Raw
152
-
| `Text
153
-
| `Addresses
154
-
| `Grouped_addresses
155
-
| `Message_ids
156
-
| `Date
157
-
| `Urls
158
-
]
159
-
160
-
let form_to_string : [< form ] -> string = function
161
-
| `Raw -> ""
162
-
| `Text -> "asText"
163
-
| `Addresses -> "asAddresses"
164
-
| `Grouped_addresses -> "asGroupedAddresses"
165
-
| `Message_ids -> "asMessageIds"
166
-
| `Date -> "asDate"
167
-
| `Urls -> "asURLs"
168
-
169
-
let form_of_string s : form option =
170
-
match s with
171
-
| "" -> Some `Raw
172
-
| "asText" -> Some `Text
173
-
| "asAddresses" -> Some `Addresses
174
-
| "asGroupedAddresses" -> Some `Grouped_addresses
175
-
| "asMessageIds" -> Some `Message_ids
176
-
| "asDate" -> Some `Date
177
-
| "asURLs" -> Some `Urls
178
-
| _ -> None
179
-
180
-
(* Header property requests *)
181
-
182
-
type header_property =
183
-
| Raw of { name : string; all : bool }
184
-
| Text of { header : [ text_header | custom_header ]; all : bool }
185
-
| Addresses of { header : [ address_header | custom_header ]; all : bool }
186
-
| Grouped_addresses of { header : [ address_header | custom_header ]; all : bool }
187
-
| Message_ids of { header : [ message_id_header | custom_header ]; all : bool }
188
-
| Date of { header : [ date_header | custom_header ]; all : bool }
189
-
| Urls of { header : [ url_header | custom_header ]; all : bool }
190
-
191
-
let header_name_of_property : header_property -> string = function
192
-
| Raw { name; _ } -> name
193
-
| Text { header; _ } -> any_header_to_string (header :> any_header)
194
-
| Addresses { header; _ } -> any_header_to_string (header :> any_header)
195
-
| Grouped_addresses { header; _ } -> any_header_to_string (header :> any_header)
196
-
| Message_ids { header; _ } -> any_header_to_string (header :> any_header)
197
-
| Date { header; _ } -> any_header_to_string (header :> any_header)
198
-
| Urls { header; _ } -> any_header_to_string (header :> any_header)
199
-
200
-
let header_property_all : header_property -> bool = function
201
-
| Raw { all; _ } -> all
202
-
| Text { all; _ } -> all
203
-
| Addresses { all; _ } -> all
204
-
| Grouped_addresses { all; _ } -> all
205
-
| Message_ids { all; _ } -> all
206
-
| Date { all; _ } -> all
207
-
| Urls { all; _ } -> all
208
-
209
-
let header_property_form : header_property -> form = function
210
-
| Raw _ -> `Raw
211
-
| Text _ -> `Text
212
-
| Addresses _ -> `Addresses
213
-
| Grouped_addresses _ -> `Grouped_addresses
214
-
| Message_ids _ -> `Message_ids
215
-
| Date _ -> `Date
216
-
| Urls _ -> `Urls
217
-
218
-
let header_property_to_string prop =
219
-
let name = header_name_of_property prop in
220
-
let form = form_to_string (header_property_form prop) in
221
-
let all_suffix = if header_property_all prop then ":all" else "" in
222
-
let form_suffix = if form = "" then "" else ":" ^ form in
223
-
"header:" ^ name ^ form_suffix ^ all_suffix
224
-
225
-
let header_property_of_string s : header_property option =
226
-
if not (String.length s > 7 && String.sub s 0 7 = "header:") then
227
-
None
228
-
else
229
-
let rest = String.sub s 7 (String.length s - 7) in
230
-
(* Parse the parts: name[:form][:all] *)
231
-
let parts = String.split_on_char ':' rest in
232
-
match parts with
233
-
| [] -> None
234
-
| [name] ->
235
-
Some (Raw { name; all = false })
236
-
| [name; second] ->
237
-
if second = "all" then
238
-
Some (Raw { name; all = true })
239
-
else begin
240
-
match form_of_string second with
241
-
| None -> None
242
-
| Some `Raw -> Some (Raw { name; all = false })
243
-
| Some `Text -> Some (Text { header = `Custom name; all = false })
244
-
| Some `Addresses -> Some (Addresses { header = `Custom name; all = false })
245
-
| Some `Grouped_addresses -> Some (Grouped_addresses { header = `Custom name; all = false })
246
-
| Some `Message_ids -> Some (Message_ids { header = `Custom name; all = false })
247
-
| Some `Date -> Some (Date { header = `Custom name; all = false })
248
-
| Some `Urls -> Some (Urls { header = `Custom name; all = false })
249
-
end
250
-
| [name; form_str; "all"] ->
251
-
begin match form_of_string form_str with
252
-
| None -> None
253
-
| Some `Raw -> Some (Raw { name; all = true })
254
-
| Some `Text -> Some (Text { header = `Custom name; all = true })
255
-
| Some `Addresses -> Some (Addresses { header = `Custom name; all = true })
256
-
| Some `Grouped_addresses -> Some (Grouped_addresses { header = `Custom name; all = true })
257
-
| Some `Message_ids -> Some (Message_ids { header = `Custom name; all = true })
258
-
| Some `Date -> Some (Date { header = `Custom name; all = true })
259
-
| Some `Urls -> Some (Urls { header = `Custom name; all = true })
260
-
end
261
-
| _ -> None
262
-
263
-
(* Convenience constructors *)
264
-
265
-
let raw ?(all=false) name = Raw { name; all }
266
-
267
-
let text ?(all=false) header = Text { header; all }
268
-
269
-
let addresses ?(all=false) header = Addresses { header; all }
270
-
271
-
let grouped_addresses ?(all=false) header = Grouped_addresses { header; all }
272
-
273
-
let message_ids ?(all=false) header = Message_ids { header; all }
274
-
275
-
let date ?(all=false) header = Date { header; all }
276
-
277
-
let urls ?(all=false) header = Urls { header; all }
278
-
279
-
(* Header values in responses *)
280
-
281
-
type header_value =
282
-
| String_single of string option
283
-
| String_all of string list
284
-
| Addresses_single of Mail_address.t list option
285
-
| Addresses_all of Mail_address.t list list
286
-
| Grouped_single of Mail_address.Group.t list option
287
-
| Grouped_all of Mail_address.Group.t list list
288
-
| Date_single of Ptime.t option
289
-
| Date_all of Ptime.t option list
290
-
| Strings_single of string list option
291
-
| Strings_all of string list option list
292
-
293
-
let header_value_jsont ~form ~all : header_value Jsont.t =
294
-
match form, all with
295
-
| (`Raw | `Text), false ->
296
-
Jsont.map
297
-
~dec:(fun s -> String_single s)
298
-
~enc:(function String_single s -> s | _ -> None)
299
-
(Jsont.option Jsont.string)
300
-
| (`Raw | `Text), true ->
301
-
Jsont.map
302
-
~dec:(fun l -> String_all l)
303
-
~enc:(function String_all l -> l | _ -> [])
304
-
(Jsont.list Jsont.string)
305
-
| `Addresses, false ->
306
-
Jsont.map
307
-
~dec:(fun l -> Addresses_single l)
308
-
~enc:(function Addresses_single l -> l | _ -> None)
309
-
(Jsont.option (Jsont.list Mail_address.jsont))
310
-
| `Addresses, true ->
311
-
Jsont.map
312
-
~dec:(fun l -> Addresses_all l)
313
-
~enc:(function Addresses_all l -> l | _ -> [])
314
-
(Jsont.list (Jsont.list Mail_address.jsont))
315
-
| `Grouped_addresses, false ->
316
-
Jsont.map
317
-
~dec:(fun l -> Grouped_single l)
318
-
~enc:(function Grouped_single l -> l | _ -> None)
319
-
(Jsont.option (Jsont.list Mail_address.Group.jsont))
320
-
| `Grouped_addresses, true ->
321
-
Jsont.map
322
-
~dec:(fun l -> Grouped_all l)
323
-
~enc:(function Grouped_all l -> l | _ -> [])
324
-
(Jsont.list (Jsont.list Mail_address.Group.jsont))
325
-
| `Message_ids, false ->
326
-
Jsont.map
327
-
~dec:(fun l -> Strings_single l)
328
-
~enc:(function Strings_single l -> l | _ -> None)
329
-
(Jsont.option (Jsont.list Jsont.string))
330
-
| `Message_ids, true ->
331
-
Jsont.map
332
-
~dec:(fun l -> Strings_all l)
333
-
~enc:(function Strings_all l -> l | _ -> [])
334
-
(Jsont.list (Jsont.option (Jsont.list Jsont.string)))
335
-
| `Date, false ->
336
-
Jsont.map
337
-
~dec:(fun t -> Date_single t)
338
-
~enc:(function Date_single t -> t | _ -> None)
339
-
(Jsont.option Proto_date.Rfc3339.jsont)
340
-
| `Date, true ->
341
-
Jsont.map
342
-
~dec:(fun l -> Date_all l)
343
-
~enc:(function Date_all l -> l | _ -> [])
344
-
(Jsont.list (Jsont.option Proto_date.Rfc3339.jsont))
345
-
| `Urls, false ->
346
-
Jsont.map
347
-
~dec:(fun l -> Strings_single l)
348
-
~enc:(function Strings_single l -> l | _ -> None)
349
-
(Jsont.option (Jsont.list Jsont.string))
350
-
| `Urls, true ->
351
-
Jsont.map
352
-
~dec:(fun l -> Strings_all l)
353
-
~enc:(function Strings_all l -> l | _ -> [])
354
-
(Jsont.list (Jsont.option (Jsont.list Jsont.string)))
355
-
356
-
(* Low-level JSON codecs *)
357
-
358
-
let raw_jsont = Jsont.string
359
-
360
-
let text_jsont = Jsont.string
361
-
362
-
let addresses_jsont = Jsont.list Mail_address.jsont
363
-
364
-
let grouped_addresses_jsont = Jsont.list Mail_address.Group.jsont
365
-
366
-
let message_ids_jsont = Jsont.list Jsont.string
367
-
368
-
let date_jsont = Proto_date.Rfc3339.jsont
369
-
370
-
let urls_jsont = Jsont.list Jsont.string
-283
lib/mail/mail_header.mli
-283
lib/mail/mail_header.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Email header types as defined in RFC 8621 Section 4.1.2
7
-
8
-
@canonical Jmap.Proto.Email_header *)
9
-
10
-
(** {1 Raw Headers} *)
11
-
12
-
(** A raw email header name-value pair. *)
13
-
type t = {
14
-
name : string;
15
-
(** The header field name. *)
16
-
value : string;
17
-
(** The raw header field value. *)
18
-
}
19
-
20
-
val create : name:string -> value:string -> t
21
-
22
-
val name : t -> string
23
-
val value : t -> string
24
-
25
-
val jsont : t Jsont.t
26
-
27
-
(** {1 Header Categories}
28
-
29
-
RFC 8621 Section 4.1.2 restricts which parsed forms can be used with
30
-
which headers. These polymorphic variant types encode those restrictions
31
-
at the type level.
32
-
33
-
Each category corresponds to headers that share the same allowed forms:
34
-
- Address headers: can use [Addresses] and [Grouped_addresses] forms
35
-
- Message-ID headers: can use [Message_ids] form
36
-
- Date headers: can use [Date] form
37
-
- URL headers: can use [Urls] form
38
-
- Text headers: can use [Text] form
39
-
- All headers can use [Raw] form
40
-
- Custom headers (not in RFC 5322/2369) can use any form *)
41
-
42
-
(** Headers that allow the [Addresses] and [Grouped_addresses] forms.
43
-
These are address-list headers per RFC 5322. *)
44
-
type address_header = [
45
-
| `From
46
-
| `Sender
47
-
| `Reply_to
48
-
| `To
49
-
| `Cc
50
-
| `Bcc
51
-
| `Resent_from
52
-
| `Resent_sender
53
-
| `Resent_reply_to
54
-
| `Resent_to
55
-
| `Resent_cc
56
-
| `Resent_bcc
57
-
]
58
-
59
-
(** Headers that allow the [Message_ids] form.
60
-
These contain msg-id values per RFC 5322. *)
61
-
type message_id_header = [
62
-
| `Message_id
63
-
| `In_reply_to
64
-
| `References
65
-
| `Resent_message_id
66
-
]
67
-
68
-
(** Headers that allow the [Date] form.
69
-
These contain date-time values per RFC 5322. *)
70
-
type date_header = [
71
-
| `Date
72
-
| `Resent_date
73
-
]
74
-
75
-
(** Headers that allow the [Urls] form.
76
-
These are list-* headers per RFC 2369. *)
77
-
type url_header = [
78
-
| `List_help
79
-
| `List_unsubscribe
80
-
| `List_subscribe
81
-
| `List_post
82
-
| `List_owner
83
-
| `List_archive
84
-
]
85
-
86
-
(** Headers that allow the [Text] form.
87
-
These contain unstructured or phrase content. *)
88
-
type text_header = [
89
-
| `Subject
90
-
| `Comments
91
-
| `Keywords
92
-
| `List_id
93
-
]
94
-
95
-
(** All standard headers defined in RFC 5322 and RFC 2369. *)
96
-
type standard_header = [
97
-
| address_header
98
-
| message_id_header
99
-
| date_header
100
-
| url_header
101
-
| text_header
102
-
]
103
-
104
-
(** A custom header not defined in RFC 5322 or RFC 2369.
105
-
Custom headers can use any parsed form. *)
106
-
type custom_header = [ `Custom of string ]
107
-
108
-
(** Any header - standard or custom. *)
109
-
type any_header = [ standard_header | custom_header ]
110
-
111
-
(** {2 Header Name Conversion} *)
112
-
113
-
val standard_header_to_string : [< standard_header ] -> string
114
-
(** Convert a standard header variant to its wire name (e.g., [`From] -> "From"). *)
115
-
116
-
val standard_header_of_string : string -> standard_header option
117
-
(** Parse a header name to a standard header variant, case-insensitive.
118
-
Returns [None] for non-standard headers. *)
119
-
120
-
val any_header_to_string : [< any_header ] -> string
121
-
(** Convert any header variant to its wire name. *)
122
-
123
-
(** {1 Header Parsed Forms}
124
-
125
-
RFC 8621 defines several parsed forms for headers.
126
-
These can be requested via the [header:Name:form] properties. *)
127
-
128
-
(** The parsed form to request for a header value. *)
129
-
type form = [
130
-
| `Raw (** Raw octets, available for all headers *)
131
-
| `Text (** Decoded text, for text headers or custom *)
132
-
| `Addresses (** Flat address list, for address headers or custom *)
133
-
| `Grouped_addresses (** Address list with groups, for address headers or custom *)
134
-
| `Message_ids (** List of message-id strings, for message-id headers or custom *)
135
-
| `Date (** Parsed date, for date headers or custom *)
136
-
| `Urls (** List of URLs, for url headers or custom *)
137
-
]
138
-
139
-
val form_to_string : [< form ] -> string
140
-
(** Convert form to wire suffix (e.g., [`Addresses] -> "asAddresses").
141
-
[`Raw] returns the empty string (raw is the default). *)
142
-
143
-
val form_of_string : string -> form option
144
-
(** Parse a form suffix (e.g., "asAddresses" -> [`Addresses]).
145
-
Empty string returns [`Raw]. *)
146
-
147
-
(** {1 Header Property Requests}
148
-
149
-
Type-safe construction of [header:Name:form:all] property strings.
150
-
The GADT ensures that only valid form/header combinations are allowed. *)
151
-
152
-
(** A header property request with type-safe form selection.
153
-
154
-
The type parameter encodes what forms are allowed:
155
-
- Address headers allow [Addresses] and [Grouped_addresses]
156
-
- Message-ID headers allow [Message_ids]
157
-
- Date headers allow [Date]
158
-
- URL headers allow [Urls]
159
-
- Text headers allow [Text]
160
-
- All headers allow [Raw]
161
-
- Custom headers allow any form *)
162
-
type header_property =
163
-
| Raw of { name : string; all : bool }
164
-
(** Raw form, available for any header. *)
165
-
166
-
| Text of { header : [ text_header | custom_header ]; all : bool }
167
-
(** Text form, for text headers or custom. *)
168
-
169
-
| Addresses of { header : [ address_header | custom_header ]; all : bool }
170
-
(** Addresses form, for address headers or custom. *)
171
-
172
-
| Grouped_addresses of { header : [ address_header | custom_header ]; all : bool }
173
-
(** GroupedAddresses form, for address headers or custom. *)
174
-
175
-
| Message_ids of { header : [ message_id_header | custom_header ]; all : bool }
176
-
(** MessageIds form, for message-id headers or custom. *)
177
-
178
-
| Date of { header : [ date_header | custom_header ]; all : bool }
179
-
(** Date form, for date headers or custom. *)
180
-
181
-
| Urls of { header : [ url_header | custom_header ]; all : bool }
182
-
(** URLs form, for URL headers or custom. *)
183
-
184
-
val header_property_to_string : header_property -> string
185
-
(** Convert a header property request to wire format.
186
-
E.g., [Addresses { header = `From; all = true }] -> "header:From:asAddresses:all" *)
187
-
188
-
val header_property_of_string : string -> header_property option
189
-
(** Parse a header property string.
190
-
Returns [None] if the string doesn't match [header:*] format. *)
191
-
192
-
(** {2 Convenience Constructors} *)
193
-
194
-
val raw : ?all:bool -> string -> header_property
195
-
(** [raw ?all name] creates a raw header property request. *)
196
-
197
-
val text : ?all:bool -> [ text_header | custom_header ] -> header_property
198
-
(** [text ?all header] creates a text header property request. *)
199
-
200
-
val addresses : ?all:bool -> [ address_header | custom_header ] -> header_property
201
-
(** [addresses ?all header] creates an addresses header property request. *)
202
-
203
-
val grouped_addresses : ?all:bool -> [ address_header | custom_header ] -> header_property
204
-
(** [grouped_addresses ?all header] creates a grouped addresses header property request. *)
205
-
206
-
val message_ids : ?all:bool -> [ message_id_header | custom_header ] -> header_property
207
-
(** [message_ids ?all header] creates a message-ids header property request. *)
208
-
209
-
val date : ?all:bool -> [ date_header | custom_header ] -> header_property
210
-
(** [date ?all header] creates a date header property request. *)
211
-
212
-
val urls : ?all:bool -> [ url_header | custom_header ] -> header_property
213
-
(** [urls ?all header] creates a URLs header property request. *)
214
-
215
-
(** {1 Header Values in Responses}
216
-
217
-
When fetching dynamic headers, the response value type depends on the
218
-
requested form. This type captures all possible response shapes. *)
219
-
220
-
(** A header value from the response.
221
-
222
-
The variant encodes both the form and whether [:all] was requested:
223
-
- [*_single] variants: value of the last header instance, or [None] if absent
224
-
- [*_all] variants: list of values for all instances, empty if absent *)
225
-
type header_value =
226
-
| String_single of string option
227
-
(** Raw or Text form, single instance. *)
228
-
229
-
| String_all of string list
230
-
(** Raw or Text form, all instances. *)
231
-
232
-
| Addresses_single of Mail_address.t list option
233
-
(** Addresses form, single instance. *)
234
-
235
-
| Addresses_all of Mail_address.t list list
236
-
(** Addresses form, all instances. *)
237
-
238
-
| Grouped_single of Mail_address.Group.t list option
239
-
(** GroupedAddresses form, single instance. *)
240
-
241
-
| Grouped_all of Mail_address.Group.t list list
242
-
(** GroupedAddresses form, all instances. *)
243
-
244
-
| Date_single of Ptime.t option
245
-
(** Date form, single instance. *)
246
-
247
-
| Date_all of Ptime.t option list
248
-
(** Date form, all instances. *)
249
-
250
-
| Strings_single of string list option
251
-
(** MessageIds or URLs form, single instance. *)
252
-
253
-
| Strings_all of string list option list
254
-
(** MessageIds or URLs form, all instances. *)
255
-
256
-
val header_value_jsont : form:form -> all:bool -> header_value Jsont.t
257
-
(** [header_value_jsont ~form ~all] returns a JSON codec for header values
258
-
with the given form and multiplicity. *)
259
-
260
-
(** {1 Low-level JSON Codecs}
261
-
262
-
These codecs are used internally and for custom header processing. *)
263
-
264
-
(** The raw form - header value as-is. *)
265
-
val raw_jsont : string Jsont.t
266
-
267
-
(** The text form - decoded and unfolded value. *)
268
-
val text_jsont : string Jsont.t
269
-
270
-
(** The addresses form - list of email addresses. *)
271
-
val addresses_jsont : Mail_address.t list Jsont.t
272
-
273
-
(** The grouped addresses form - addresses with group info. *)
274
-
val grouped_addresses_jsont : Mail_address.Group.t list Jsont.t
275
-
276
-
(** The message IDs form - list of message-id strings. *)
277
-
val message_ids_jsont : string list Jsont.t
278
-
279
-
(** The date form - parsed RFC 3339 date. *)
280
-
val date_jsont : Ptime.t Jsont.t
281
-
282
-
(** The URLs form - list of URL strings. *)
283
-
val urls_jsont : string list Jsont.t
-77
lib/mail/mail_identity.ml
-77
lib/mail/mail_identity.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(* Identity properties *)
7
-
8
-
type property = [
9
-
| `Id
10
-
| `Name
11
-
| `Email
12
-
| `Reply_to
13
-
| `Bcc
14
-
| `Text_signature
15
-
| `Html_signature
16
-
| `May_delete
17
-
]
18
-
19
-
let property_to_string : [< property ] -> string = function
20
-
| `Id -> "id"
21
-
| `Name -> "name"
22
-
| `Email -> "email"
23
-
| `Reply_to -> "replyTo"
24
-
| `Bcc -> "bcc"
25
-
| `Text_signature -> "textSignature"
26
-
| `Html_signature -> "htmlSignature"
27
-
| `May_delete -> "mayDelete"
28
-
29
-
let property_of_string s : property option =
30
-
match s with
31
-
| "id" -> Some `Id
32
-
| "name" -> Some `Name
33
-
| "email" -> Some `Email
34
-
| "replyTo" -> Some `Reply_to
35
-
| "bcc" -> Some `Bcc
36
-
| "textSignature" -> Some `Text_signature
37
-
| "htmlSignature" -> Some `Html_signature
38
-
| "mayDelete" -> Some `May_delete
39
-
| _ -> None
40
-
41
-
(* Identity type *)
42
-
43
-
type t = {
44
-
id : Proto_id.t option;
45
-
name : string option;
46
-
email : string option;
47
-
reply_to : Mail_address.t list option;
48
-
bcc : Mail_address.t list option;
49
-
text_signature : string option;
50
-
html_signature : string option;
51
-
may_delete : bool option;
52
-
}
53
-
54
-
let id t = t.id
55
-
let name t = t.name
56
-
let email t = t.email
57
-
let reply_to t = t.reply_to
58
-
let bcc t = t.bcc
59
-
let text_signature t = t.text_signature
60
-
let html_signature t = t.html_signature
61
-
let may_delete t = t.may_delete
62
-
63
-
let make id name email reply_to bcc text_signature html_signature may_delete =
64
-
{ id; name; email; reply_to; bcc; text_signature; html_signature; may_delete }
65
-
66
-
let jsont =
67
-
let kind = "Identity" in
68
-
Jsont.Object.map ~kind make
69
-
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
70
-
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:name
71
-
|> Jsont.Object.opt_mem "email" Jsont.string ~enc:email
72
-
|> Jsont.Object.opt_mem "replyTo" (Jsont.list Mail_address.jsont) ~enc:reply_to
73
-
|> Jsont.Object.opt_mem "bcc" (Jsont.list Mail_address.jsont) ~enc:bcc
74
-
|> Jsont.Object.opt_mem "textSignature" Jsont.string ~enc:text_signature
75
-
|> Jsont.Object.opt_mem "htmlSignature" Jsont.string ~enc:html_signature
76
-
|> Jsont.Object.opt_mem "mayDelete" Jsont.bool ~enc:may_delete
77
-
|> Jsont.Object.finish
-63
lib/mail/mail_identity.mli
-63
lib/mail/mail_identity.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Identity type as defined in RFC 8621 Section 6
7
-
8
-
@canonical Jmap.Proto.Identity *)
9
-
10
-
(** {1 Identity Properties}
11
-
12
-
Polymorphic variants for type-safe property selection in Identity/get requests.
13
-
These correspond to the properties defined in RFC 8621 Section 6. *)
14
-
15
-
(** All Identity properties that can be requested. *)
16
-
type property = [
17
-
| `Id
18
-
| `Name
19
-
| `Email
20
-
| `Reply_to
21
-
| `Bcc
22
-
| `Text_signature
23
-
| `Html_signature
24
-
| `May_delete
25
-
]
26
-
27
-
val property_to_string : [< property ] -> string
28
-
(** Convert a property to its wire name (e.g., [`Text_signature] -> "textSignature"). *)
29
-
30
-
val property_of_string : string -> property option
31
-
(** Parse a property name, case-sensitive. *)
32
-
33
-
(** {1 Identity Object} *)
34
-
35
-
type t = {
36
-
id : Proto_id.t option;
37
-
(** Server-assigned identity id. *)
38
-
name : string option;
39
-
(** Display name for sent emails. *)
40
-
email : string option;
41
-
(** The email address to use. *)
42
-
reply_to : Mail_address.t list option;
43
-
(** Default Reply-To addresses. *)
44
-
bcc : Mail_address.t list option;
45
-
(** Default BCC addresses. *)
46
-
text_signature : string option;
47
-
(** Plain text signature. *)
48
-
html_signature : string option;
49
-
(** HTML signature. *)
50
-
may_delete : bool option;
51
-
(** Whether the user may delete this identity. *)
52
-
}
53
-
54
-
val id : t -> Proto_id.t option
55
-
val name : t -> string option
56
-
val email : t -> string option
57
-
val reply_to : t -> Mail_address.t list option
58
-
val bcc : t -> Mail_address.t list option
59
-
val text_signature : t -> string option
60
-
val html_signature : t -> string option
61
-
val may_delete : t -> bool option
62
-
63
-
val jsont : t Jsont.t
-225
lib/mail/mail_mailbox.ml
-225
lib/mail/mail_mailbox.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(* Mailbox properties *)
7
-
8
-
type property = [
9
-
| `Id
10
-
| `Name
11
-
| `Parent_id
12
-
| `Role
13
-
| `Sort_order
14
-
| `Total_emails
15
-
| `Unread_emails
16
-
| `Total_threads
17
-
| `Unread_threads
18
-
| `My_rights
19
-
| `Is_subscribed
20
-
]
21
-
22
-
let property_to_string : [< property ] -> string = function
23
-
| `Id -> "id"
24
-
| `Name -> "name"
25
-
| `Parent_id -> "parentId"
26
-
| `Role -> "role"
27
-
| `Sort_order -> "sortOrder"
28
-
| `Total_emails -> "totalEmails"
29
-
| `Unread_emails -> "unreadEmails"
30
-
| `Total_threads -> "totalThreads"
31
-
| `Unread_threads -> "unreadThreads"
32
-
| `My_rights -> "myRights"
33
-
| `Is_subscribed -> "isSubscribed"
34
-
35
-
let property_of_string s : property option =
36
-
match s with
37
-
| "id" -> Some `Id
38
-
| "name" -> Some `Name
39
-
| "parentId" -> Some `Parent_id
40
-
| "role" -> Some `Role
41
-
| "sortOrder" -> Some `Sort_order
42
-
| "totalEmails" -> Some `Total_emails
43
-
| "unreadEmails" -> Some `Unread_emails
44
-
| "totalThreads" -> Some `Total_threads
45
-
| "unreadThreads" -> Some `Unread_threads
46
-
| "myRights" -> Some `My_rights
47
-
| "isSubscribed" -> Some `Is_subscribed
48
-
| _ -> None
49
-
50
-
module Rights = struct
51
-
type t = {
52
-
may_read_items : bool;
53
-
may_add_items : bool;
54
-
may_remove_items : bool;
55
-
may_set_seen : bool;
56
-
may_set_keywords : bool;
57
-
may_create_child : bool;
58
-
may_rename : bool;
59
-
may_delete : bool;
60
-
may_submit : bool;
61
-
}
62
-
63
-
let may_read_items t = t.may_read_items
64
-
let may_add_items t = t.may_add_items
65
-
let may_remove_items t = t.may_remove_items
66
-
let may_set_seen t = t.may_set_seen
67
-
let may_set_keywords t = t.may_set_keywords
68
-
let may_create_child t = t.may_create_child
69
-
let may_rename t = t.may_rename
70
-
let may_delete t = t.may_delete
71
-
let may_submit t = t.may_submit
72
-
73
-
let make may_read_items may_add_items may_remove_items may_set_seen
74
-
may_set_keywords may_create_child may_rename may_delete may_submit =
75
-
{ may_read_items; may_add_items; may_remove_items; may_set_seen;
76
-
may_set_keywords; may_create_child; may_rename; may_delete; may_submit }
77
-
78
-
let jsont =
79
-
let kind = "MailboxRights" in
80
-
Jsont.Object.map ~kind make
81
-
|> Jsont.Object.mem "mayReadItems" Jsont.bool ~enc:may_read_items
82
-
|> Jsont.Object.mem "mayAddItems" Jsont.bool ~enc:may_add_items
83
-
|> Jsont.Object.mem "mayRemoveItems" Jsont.bool ~enc:may_remove_items
84
-
|> Jsont.Object.mem "maySetSeen" Jsont.bool ~enc:may_set_seen
85
-
|> Jsont.Object.mem "maySetKeywords" Jsont.bool ~enc:may_set_keywords
86
-
|> Jsont.Object.mem "mayCreateChild" Jsont.bool ~enc:may_create_child
87
-
|> Jsont.Object.mem "mayRename" Jsont.bool ~enc:may_rename
88
-
|> Jsont.Object.mem "mayDelete" Jsont.bool ~enc:may_delete
89
-
|> Jsont.Object.mem "maySubmit" Jsont.bool ~enc:may_submit
90
-
|> Jsont.Object.finish
91
-
end
92
-
93
-
type role = [
94
-
| `All
95
-
| `Archive
96
-
| `Drafts
97
-
| `Flagged
98
-
| `Important
99
-
| `Inbox
100
-
| `Junk
101
-
| `Sent
102
-
| `Subscribed
103
-
| `Trash
104
-
| `Snoozed
105
-
| `Scheduled
106
-
| `Memos
107
-
| `Other of string
108
-
]
109
-
110
-
let role_to_string = function
111
-
| `All -> "all"
112
-
| `Archive -> "archive"
113
-
| `Drafts -> "drafts"
114
-
| `Flagged -> "flagged"
115
-
| `Important -> "important"
116
-
| `Inbox -> "inbox"
117
-
| `Junk -> "junk"
118
-
| `Sent -> "sent"
119
-
| `Subscribed -> "subscribed"
120
-
| `Trash -> "trash"
121
-
| `Snoozed -> "snoozed"
122
-
| `Scheduled -> "scheduled"
123
-
| `Memos -> "memos"
124
-
| `Other s -> s
125
-
126
-
let role_of_string = function
127
-
| "all" -> `All
128
-
| "archive" -> `Archive
129
-
| "drafts" -> `Drafts
130
-
| "flagged" -> `Flagged
131
-
| "important" -> `Important
132
-
| "inbox" -> `Inbox
133
-
| "junk" -> `Junk
134
-
| "sent" -> `Sent
135
-
| "subscribed" -> `Subscribed
136
-
| "trash" -> `Trash
137
-
| "snoozed" -> `Snoozed
138
-
| "scheduled" -> `Scheduled
139
-
| "memos" -> `Memos
140
-
| s -> `Other s
141
-
142
-
let role_jsont =
143
-
Jsont.map ~kind:"MailboxRole"
144
-
~dec:(fun s -> role_of_string s)
145
-
~enc:role_to_string
146
-
Jsont.string
147
-
148
-
type t = {
149
-
id : Proto_id.t option;
150
-
name : string option;
151
-
parent_id : Proto_id.t option;
152
-
role : role option;
153
-
sort_order : int64 option;
154
-
total_emails : int64 option;
155
-
unread_emails : int64 option;
156
-
total_threads : int64 option;
157
-
unread_threads : int64 option;
158
-
my_rights : Rights.t option;
159
-
is_subscribed : bool option;
160
-
}
161
-
162
-
let id t = t.id
163
-
let name t = t.name
164
-
let parent_id t = t.parent_id
165
-
let role t = t.role
166
-
let sort_order t = t.sort_order
167
-
let total_emails t = t.total_emails
168
-
let unread_emails t = t.unread_emails
169
-
let total_threads t = t.total_threads
170
-
let unread_threads t = t.unread_threads
171
-
let my_rights t = t.my_rights
172
-
let is_subscribed t = t.is_subscribed
173
-
174
-
let make id name parent_id role sort_order total_emails unread_emails
175
-
total_threads unread_threads my_rights is_subscribed =
176
-
{ id; name; parent_id; role; sort_order; total_emails; unread_emails;
177
-
total_threads; unread_threads; my_rights; is_subscribed }
178
-
179
-
let jsont =
180
-
let kind = "Mailbox" in
181
-
Jsont.Object.map ~kind make
182
-
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
183
-
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:name
184
-
(* parentId can be null meaning top-level, or absent if not requested *)
185
-
|> Jsont.Object.opt_mem "parentId" Proto_id.jsont ~enc:parent_id
186
-
(* role can be null meaning no role, or absent if not requested *)
187
-
|> Jsont.Object.opt_mem "role" role_jsont ~enc:role
188
-
|> Jsont.Object.opt_mem "sortOrder" Proto_int53.Unsigned.jsont ~enc:sort_order
189
-
|> Jsont.Object.opt_mem "totalEmails" Proto_int53.Unsigned.jsont ~enc:total_emails
190
-
|> Jsont.Object.opt_mem "unreadEmails" Proto_int53.Unsigned.jsont ~enc:unread_emails
191
-
|> Jsont.Object.opt_mem "totalThreads" Proto_int53.Unsigned.jsont ~enc:total_threads
192
-
|> Jsont.Object.opt_mem "unreadThreads" Proto_int53.Unsigned.jsont ~enc:unread_threads
193
-
|> Jsont.Object.opt_mem "myRights" Rights.jsont ~enc:my_rights
194
-
|> Jsont.Object.opt_mem "isSubscribed" Jsont.bool ~enc:is_subscribed
195
-
|> Jsont.Object.finish
196
-
197
-
module Filter_condition = struct
198
-
type t = {
199
-
parent_id : Proto_id.t option option;
200
-
name : string option;
201
-
role : role option option;
202
-
has_any_role : bool option;
203
-
is_subscribed : bool option;
204
-
}
205
-
206
-
let make parent_id name role has_any_role is_subscribed =
207
-
{ parent_id; name; role; has_any_role; is_subscribed }
208
-
209
-
let jsont =
210
-
let kind = "MailboxFilterCondition" in
211
-
(* parentId and role can be absent, null, or have a value - RFC 8621 Section 2.1 *)
212
-
(* Use opt_mem with Jsont.option to get option option type:
213
-
- None = field absent (don't filter)
214
-
- Some None = field present with null (filter for no parent/role)
215
-
- Some (Some x) = field present with value (filter for specific value) *)
216
-
let nullable_id = Jsont.(option Proto_id.jsont) in
217
-
let nullable_role = Jsont.(option role_jsont) in
218
-
Jsont.Object.map ~kind make
219
-
|> Jsont.Object.opt_mem "parentId" nullable_id ~enc:(fun f -> f.parent_id)
220
-
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:(fun f -> f.name)
221
-
|> Jsont.Object.opt_mem "role" nullable_role ~enc:(fun f -> f.role)
222
-
|> Jsont.Object.opt_mem "hasAnyRole" Jsont.bool ~enc:(fun f -> f.has_any_role)
223
-
|> Jsont.Object.opt_mem "isSubscribed" Jsont.bool ~enc:(fun f -> f.is_subscribed)
224
-
|> Jsont.Object.finish
225
-
end
-150
lib/mail/mail_mailbox.mli
-150
lib/mail/mail_mailbox.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Mailbox type as defined in RFC 8621 Section 2
7
-
8
-
@canonical Jmap.Proto.Mailbox *)
9
-
10
-
(** {1 Mailbox Properties}
11
-
12
-
Polymorphic variants for type-safe property selection in Mailbox/get requests.
13
-
These correspond to the properties defined in RFC 8621 Section 2. *)
14
-
15
-
(** All Mailbox properties that can be requested. *)
16
-
type property = [
17
-
| `Id
18
-
| `Name
19
-
| `Parent_id
20
-
| `Role
21
-
| `Sort_order
22
-
| `Total_emails
23
-
| `Unread_emails
24
-
| `Total_threads
25
-
| `Unread_threads
26
-
| `My_rights
27
-
| `Is_subscribed
28
-
]
29
-
30
-
val property_to_string : [< property ] -> string
31
-
(** Convert a property to its wire name (e.g., [`Parent_id] -> "parentId"). *)
32
-
33
-
val property_of_string : string -> property option
34
-
(** Parse a property name, case-sensitive. *)
35
-
36
-
(** {1 Mailbox Rights} *)
37
-
38
-
(** Rights the user has on a mailbox. *)
39
-
module Rights : sig
40
-
type t = {
41
-
may_read_items : bool;
42
-
may_add_items : bool;
43
-
may_remove_items : bool;
44
-
may_set_seen : bool;
45
-
may_set_keywords : bool;
46
-
may_create_child : bool;
47
-
may_rename : bool;
48
-
may_delete : bool;
49
-
may_submit : bool;
50
-
}
51
-
52
-
val may_read_items : t -> bool
53
-
val may_add_items : t -> bool
54
-
val may_remove_items : t -> bool
55
-
val may_set_seen : t -> bool
56
-
val may_set_keywords : t -> bool
57
-
val may_create_child : t -> bool
58
-
val may_rename : t -> bool
59
-
val may_delete : t -> bool
60
-
val may_submit : t -> bool
61
-
62
-
val jsont : t Jsont.t
63
-
end
64
-
65
-
(** {1 Standard Roles} *)
66
-
67
-
(** Standard mailbox roles per RFC 8621 Section 2 and draft-ietf-mailmaint. *)
68
-
type role = [
69
-
| `All
70
-
| `Archive
71
-
| `Drafts
72
-
| `Flagged
73
-
| `Important
74
-
| `Inbox
75
-
| `Junk
76
-
| `Sent
77
-
| `Subscribed
78
-
| `Trash
79
-
| `Snoozed (** draft-ietf-mailmaint: Messages snoozed until a later time. *)
80
-
| `Scheduled (** draft-ietf-mailmaint: Messages scheduled to send. *)
81
-
| `Memos (** draft-ietf-mailmaint: Messages with the $memo keyword. *)
82
-
| `Other of string
83
-
]
84
-
85
-
val role_to_string : role -> string
86
-
val role_of_string : string -> role
87
-
val role_jsont : role Jsont.t
88
-
89
-
(** {1 Mailbox} *)
90
-
91
-
type t = {
92
-
id : Proto_id.t option;
93
-
(** Server-assigned mailbox id. *)
94
-
name : string option;
95
-
(** User-visible name (UTF-8). *)
96
-
parent_id : Proto_id.t option;
97
-
(** Id of parent mailbox, or [None] for root. Note: [None] can mean
98
-
either "not requested" or "top-level mailbox". *)
99
-
role : role option;
100
-
(** Standard role, if any. Note: [None] can mean either "not requested"
101
-
or "no role assigned". *)
102
-
sort_order : int64 option;
103
-
(** Sort order hint (lower = displayed first). *)
104
-
total_emails : int64 option;
105
-
(** Total number of emails in mailbox. *)
106
-
unread_emails : int64 option;
107
-
(** Number of unread emails. *)
108
-
total_threads : int64 option;
109
-
(** Total number of threads. *)
110
-
unread_threads : int64 option;
111
-
(** Number of threads with unread emails. *)
112
-
my_rights : Rights.t option;
113
-
(** User's rights on this mailbox. *)
114
-
is_subscribed : bool option;
115
-
(** Whether user is subscribed to this mailbox. *)
116
-
}
117
-
118
-
val id : t -> Proto_id.t option
119
-
val name : t -> string option
120
-
val parent_id : t -> Proto_id.t option
121
-
val role : t -> role option
122
-
val sort_order : t -> int64 option
123
-
val total_emails : t -> int64 option
124
-
val unread_emails : t -> int64 option
125
-
val total_threads : t -> int64 option
126
-
val unread_threads : t -> int64 option
127
-
val my_rights : t -> Rights.t option
128
-
val is_subscribed : t -> bool option
129
-
130
-
val jsont : t Jsont.t
131
-
132
-
(** {1 Mailbox Filter Conditions} *)
133
-
134
-
(** Filter conditions for Mailbox/query. *)
135
-
module Filter_condition : sig
136
-
type t = {
137
-
parent_id : Proto_id.t option option;
138
-
(** Filter by parent. [Some None] = top-level only. *)
139
-
name : string option;
140
-
(** Filter by exact name match. *)
141
-
role : role option option;
142
-
(** Filter by role. [Some None] = no role. *)
143
-
has_any_role : bool option;
144
-
(** Filter by whether mailbox has any role. *)
145
-
is_subscribed : bool option;
146
-
(** Filter by subscription status. *)
147
-
}
148
-
149
-
val jsont : t Jsont.t
150
-
end
-28
lib/mail/mail_snippet.ml
-28
lib/mail/mail_snippet.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = {
7
-
email_id : Proto_id.t;
8
-
subject : string option;
9
-
preview : string option;
10
-
}
11
-
12
-
let email_id t = t.email_id
13
-
let subject t = t.subject
14
-
let preview t = t.preview
15
-
16
-
let make email_id subject preview = { email_id; subject; preview }
17
-
18
-
let jsont =
19
-
let kind = "SearchSnippet" in
20
-
(* subject and preview can be null per RFC 8621 Section 5 *)
21
-
let nullable_string = Jsont.(option string) in
22
-
Jsont.Object.map ~kind make
23
-
|> Jsont.Object.mem "emailId" Proto_id.jsont ~enc:email_id
24
-
|> Jsont.Object.mem "subject" nullable_string
25
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:subject
26
-
|> Jsont.Object.mem "preview" nullable_string
27
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:preview
28
-
|> Jsont.Object.finish
-23
lib/mail/mail_snippet.mli
-23
lib/mail/mail_snippet.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** SearchSnippet type as defined in RFC 8621 Section 5
7
-
8
-
@canonical Jmap.Proto.Search_snippet *)
9
-
10
-
type t = {
11
-
email_id : Proto_id.t;
12
-
(** The email this snippet is for. *)
13
-
subject : string option;
14
-
(** HTML snippet of matching subject text. *)
15
-
preview : string option;
16
-
(** HTML snippet of matching body text. *)
17
-
}
18
-
19
-
val email_id : t -> Proto_id.t
20
-
val subject : t -> string option
21
-
val preview : t -> string option
22
-
23
-
val jsont : t Jsont.t
-224
lib/mail/mail_submission.ml
-224
lib/mail/mail_submission.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(* EmailSubmission properties *)
7
-
8
-
type property = [
9
-
| `Id
10
-
| `Identity_id
11
-
| `Email_id
12
-
| `Thread_id
13
-
| `Envelope
14
-
| `Send_at
15
-
| `Undo_status
16
-
| `Delivery_status
17
-
| `Dsn_blob_ids
18
-
| `Mdn_blob_ids
19
-
]
20
-
21
-
let property_to_string : [< property ] -> string = function
22
-
| `Id -> "id"
23
-
| `Identity_id -> "identityId"
24
-
| `Email_id -> "emailId"
25
-
| `Thread_id -> "threadId"
26
-
| `Envelope -> "envelope"
27
-
| `Send_at -> "sendAt"
28
-
| `Undo_status -> "undoStatus"
29
-
| `Delivery_status -> "deliveryStatus"
30
-
| `Dsn_blob_ids -> "dsnBlobIds"
31
-
| `Mdn_blob_ids -> "mdnBlobIds"
32
-
33
-
let property_of_string s : property option =
34
-
match s with
35
-
| "id" -> Some `Id
36
-
| "identityId" -> Some `Identity_id
37
-
| "emailId" -> Some `Email_id
38
-
| "threadId" -> Some `Thread_id
39
-
| "envelope" -> Some `Envelope
40
-
| "sendAt" -> Some `Send_at
41
-
| "undoStatus" -> Some `Undo_status
42
-
| "deliveryStatus" -> Some `Delivery_status
43
-
| "dsnBlobIds" -> Some `Dsn_blob_ids
44
-
| "mdnBlobIds" -> Some `Mdn_blob_ids
45
-
| _ -> None
46
-
47
-
module Address = struct
48
-
type t = {
49
-
email : string;
50
-
parameters : (string * string) list option;
51
-
}
52
-
53
-
let email t = t.email
54
-
let parameters t = t.parameters
55
-
56
-
let make email parameters = { email; parameters }
57
-
58
-
let jsont =
59
-
let kind = "EmailSubmission Address" in
60
-
Jsont.Object.map ~kind make
61
-
|> Jsont.Object.mem "email" Jsont.string ~enc:email
62
-
|> Jsont.Object.opt_mem "parameters" (Proto_json_map.of_string Jsont.string) ~enc:parameters
63
-
|> Jsont.Object.finish
64
-
end
65
-
66
-
module Envelope = struct
67
-
type t = {
68
-
mail_from : Address.t;
69
-
rcpt_to : Address.t list;
70
-
}
71
-
72
-
let mail_from t = t.mail_from
73
-
let rcpt_to t = t.rcpt_to
74
-
75
-
let make mail_from rcpt_to = { mail_from; rcpt_to }
76
-
77
-
let jsont =
78
-
let kind = "Envelope" in
79
-
Jsont.Object.map ~kind make
80
-
|> Jsont.Object.mem "mailFrom" Address.jsont ~enc:mail_from
81
-
|> Jsont.Object.mem "rcptTo" (Jsont.list Address.jsont) ~enc:rcpt_to
82
-
|> Jsont.Object.finish
83
-
end
84
-
85
-
module Delivery_status = struct
86
-
type delivered = [ `Queued | `Yes | `No | `Unknown ]
87
-
88
-
let delivered_to_string = function
89
-
| `Queued -> "queued"
90
-
| `Yes -> "yes"
91
-
| `No -> "no"
92
-
| `Unknown -> "unknown"
93
-
94
-
let delivered_of_string = function
95
-
| "queued" -> `Queued
96
-
| "yes" -> `Yes
97
-
| "no" -> `No
98
-
| _ -> `Unknown
99
-
100
-
let delivered_jsont =
101
-
Jsont.map ~kind:"DeliveryStatus.delivered"
102
-
~dec:delivered_of_string ~enc:delivered_to_string Jsont.string
103
-
104
-
type displayed = [ `Unknown | `Yes ]
105
-
106
-
let displayed_to_string = function
107
-
| `Unknown -> "unknown"
108
-
| `Yes -> "yes"
109
-
110
-
let displayed_of_string = function
111
-
| "yes" -> `Yes
112
-
| _ -> `Unknown
113
-
114
-
let displayed_jsont =
115
-
Jsont.map ~kind:"DeliveryStatus.displayed"
116
-
~dec:displayed_of_string ~enc:displayed_to_string Jsont.string
117
-
118
-
type t = {
119
-
smtp_reply : string;
120
-
delivered : delivered;
121
-
displayed : displayed;
122
-
}
123
-
124
-
let smtp_reply t = t.smtp_reply
125
-
let delivered t = t.delivered
126
-
let displayed t = t.displayed
127
-
128
-
let make smtp_reply delivered displayed =
129
-
{ smtp_reply; delivered; displayed }
130
-
131
-
let jsont =
132
-
let kind = "DeliveryStatus" in
133
-
Jsont.Object.map ~kind make
134
-
|> Jsont.Object.mem "smtpReply" Jsont.string ~enc:smtp_reply
135
-
|> Jsont.Object.mem "delivered" delivered_jsont ~enc:delivered
136
-
|> Jsont.Object.mem "displayed" displayed_jsont ~enc:displayed
137
-
|> Jsont.Object.finish
138
-
end
139
-
140
-
type undo_status = [ `Pending | `Final | `Canceled ]
141
-
142
-
let undo_status_to_string = function
143
-
| `Pending -> "pending"
144
-
| `Final -> "final"
145
-
| `Canceled -> "canceled"
146
-
147
-
let undo_status_of_string = function
148
-
| "pending" -> `Pending
149
-
| "final" -> `Final
150
-
| "canceled" -> `Canceled
151
-
| s -> Jsont.Error.msgf Jsont.Meta.none "Unknown undo status: %s" s
152
-
153
-
let undo_status_jsont =
154
-
Jsont.map ~kind:"UndoStatus"
155
-
~dec:undo_status_of_string ~enc:undo_status_to_string Jsont.string
156
-
157
-
type t = {
158
-
id : Proto_id.t option;
159
-
identity_id : Proto_id.t option;
160
-
email_id : Proto_id.t option;
161
-
thread_id : Proto_id.t option;
162
-
envelope : Envelope.t option;
163
-
send_at : Ptime.t option;
164
-
undo_status : undo_status option;
165
-
delivery_status : (string * Delivery_status.t) list option;
166
-
dsn_blob_ids : Proto_id.t list option;
167
-
mdn_blob_ids : Proto_id.t list option;
168
-
}
169
-
170
-
let id t = t.id
171
-
let identity_id t = t.identity_id
172
-
let email_id t = t.email_id
173
-
let thread_id t = t.thread_id
174
-
let envelope t = t.envelope
175
-
let send_at t = t.send_at
176
-
let undo_status t = t.undo_status
177
-
let delivery_status t = t.delivery_status
178
-
let dsn_blob_ids t = t.dsn_blob_ids
179
-
let mdn_blob_ids t = t.mdn_blob_ids
180
-
181
-
let make id identity_id email_id thread_id envelope send_at undo_status
182
-
delivery_status dsn_blob_ids mdn_blob_ids =
183
-
{ id; identity_id; email_id; thread_id; envelope; send_at; undo_status;
184
-
delivery_status; dsn_blob_ids; mdn_blob_ids }
185
-
186
-
let jsont =
187
-
let kind = "EmailSubmission" in
188
-
Jsont.Object.map ~kind make
189
-
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
190
-
|> Jsont.Object.opt_mem "identityId" Proto_id.jsont ~enc:identity_id
191
-
|> Jsont.Object.opt_mem "emailId" Proto_id.jsont ~enc:email_id
192
-
|> Jsont.Object.opt_mem "threadId" Proto_id.jsont ~enc:thread_id
193
-
|> Jsont.Object.opt_mem "envelope" Envelope.jsont ~enc:envelope
194
-
|> Jsont.Object.opt_mem "sendAt" Proto_date.Utc.jsont ~enc:send_at
195
-
|> Jsont.Object.opt_mem "undoStatus" undo_status_jsont ~enc:undo_status
196
-
|> Jsont.Object.opt_mem "deliveryStatus" (Proto_json_map.of_string Delivery_status.jsont) ~enc:delivery_status
197
-
|> Jsont.Object.opt_mem "dsnBlobIds" (Jsont.list Proto_id.jsont) ~enc:dsn_blob_ids
198
-
|> Jsont.Object.opt_mem "mdnBlobIds" (Jsont.list Proto_id.jsont) ~enc:mdn_blob_ids
199
-
|> Jsont.Object.finish
200
-
201
-
module Filter_condition = struct
202
-
type t = {
203
-
identity_ids : Proto_id.t list option;
204
-
email_ids : Proto_id.t list option;
205
-
thread_ids : Proto_id.t list option;
206
-
undo_status : undo_status option;
207
-
before : Ptime.t option;
208
-
after : Ptime.t option;
209
-
}
210
-
211
-
let make identity_ids email_ids thread_ids undo_status before after =
212
-
{ identity_ids; email_ids; thread_ids; undo_status; before; after }
213
-
214
-
let jsont =
215
-
let kind = "EmailSubmissionFilterCondition" in
216
-
Jsont.Object.map ~kind make
217
-
|> Jsont.Object.opt_mem "identityIds" (Jsont.list Proto_id.jsont) ~enc:(fun f -> f.identity_ids)
218
-
|> Jsont.Object.opt_mem "emailIds" (Jsont.list Proto_id.jsont) ~enc:(fun f -> f.email_ids)
219
-
|> Jsont.Object.opt_mem "threadIds" (Jsont.list Proto_id.jsont) ~enc:(fun f -> f.thread_ids)
220
-
|> Jsont.Object.opt_mem "undoStatus" undo_status_jsont ~enc:(fun f -> f.undo_status)
221
-
|> Jsont.Object.opt_mem "before" Proto_date.Utc.jsont ~enc:(fun f -> f.before)
222
-
|> Jsont.Object.opt_mem "after" Proto_date.Utc.jsont ~enc:(fun f -> f.after)
223
-
|> Jsont.Object.finish
224
-
end
-162
lib/mail/mail_submission.mli
-162
lib/mail/mail_submission.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** EmailSubmission type as defined in RFC 8621 Section 7
7
-
8
-
@canonical Jmap.Proto.Submission *)
9
-
10
-
(** {1 EmailSubmission Properties}
11
-
12
-
Polymorphic variants for type-safe property selection in EmailSubmission/get requests.
13
-
These correspond to the properties defined in RFC 8621 Section 7. *)
14
-
15
-
(** All EmailSubmission properties that can be requested. *)
16
-
type property = [
17
-
| `Id
18
-
| `Identity_id
19
-
| `Email_id
20
-
| `Thread_id
21
-
| `Envelope
22
-
| `Send_at
23
-
| `Undo_status
24
-
| `Delivery_status
25
-
| `Dsn_blob_ids
26
-
| `Mdn_blob_ids
27
-
]
28
-
29
-
val property_to_string : [< property ] -> string
30
-
(** Convert a property to its wire name (e.g., [`Identity_id] -> "identityId"). *)
31
-
32
-
val property_of_string : string -> property option
33
-
(** Parse a property name, case-sensitive. *)
34
-
35
-
(** {1 Address} *)
36
-
37
-
(** An address with optional SMTP parameters. *)
38
-
module Address : sig
39
-
type t = {
40
-
email : string;
41
-
(** The email address. *)
42
-
parameters : (string * string) list option;
43
-
(** Optional SMTP parameters. *)
44
-
}
45
-
46
-
val email : t -> string
47
-
val parameters : t -> (string * string) list option
48
-
49
-
val jsont : t Jsont.t
50
-
end
51
-
52
-
(** {1 Envelope} *)
53
-
54
-
(** SMTP envelope. *)
55
-
module Envelope : sig
56
-
type t = {
57
-
mail_from : Address.t;
58
-
(** MAIL FROM address. *)
59
-
rcpt_to : Address.t list;
60
-
(** RCPT TO addresses. *)
61
-
}
62
-
63
-
val mail_from : t -> Address.t
64
-
val rcpt_to : t -> Address.t list
65
-
66
-
val jsont : t Jsont.t
67
-
end
68
-
69
-
(** {1 Delivery Status} *)
70
-
71
-
(** Status of delivery to a recipient. *)
72
-
module Delivery_status : sig
73
-
type delivered = [
74
-
| `Queued
75
-
| `Yes
76
-
| `No
77
-
| `Unknown
78
-
]
79
-
80
-
type displayed = [
81
-
| `Unknown
82
-
| `Yes
83
-
]
84
-
85
-
type t = {
86
-
smtp_reply : string;
87
-
(** The SMTP reply string. *)
88
-
delivered : delivered;
89
-
(** Delivery status. *)
90
-
displayed : displayed;
91
-
(** MDN display status. *)
92
-
}
93
-
94
-
val smtp_reply : t -> string
95
-
val delivered : t -> delivered
96
-
val displayed : t -> displayed
97
-
98
-
val jsont : t Jsont.t
99
-
end
100
-
101
-
(** {1 Undo Status} *)
102
-
103
-
type undo_status = [
104
-
| `Pending
105
-
| `Final
106
-
| `Canceled
107
-
]
108
-
109
-
val undo_status_jsont : undo_status Jsont.t
110
-
111
-
(** {1 EmailSubmission} *)
112
-
113
-
type t = {
114
-
id : Proto_id.t option;
115
-
(** Server-assigned submission id. *)
116
-
identity_id : Proto_id.t option;
117
-
(** The identity used to send. *)
118
-
email_id : Proto_id.t option;
119
-
(** The email that was submitted. *)
120
-
thread_id : Proto_id.t option;
121
-
(** The thread of the submitted email. *)
122
-
envelope : Envelope.t option;
123
-
(** The envelope used, if different from email headers. *)
124
-
send_at : Ptime.t option;
125
-
(** When the email was/will be sent. *)
126
-
undo_status : undo_status option;
127
-
(** Whether sending can be undone. *)
128
-
delivery_status : (string * Delivery_status.t) list option;
129
-
(** Delivery status per recipient. *)
130
-
dsn_blob_ids : Proto_id.t list option;
131
-
(** Blob ids of received DSN messages. *)
132
-
mdn_blob_ids : Proto_id.t list option;
133
-
(** Blob ids of received MDN messages. *)
134
-
}
135
-
136
-
val id : t -> Proto_id.t option
137
-
val identity_id : t -> Proto_id.t option
138
-
val email_id : t -> Proto_id.t option
139
-
val thread_id : t -> Proto_id.t option
140
-
val envelope : t -> Envelope.t option
141
-
val send_at : t -> Ptime.t option
142
-
val undo_status : t -> undo_status option
143
-
val delivery_status : t -> (string * Delivery_status.t) list option
144
-
val dsn_blob_ids : t -> Proto_id.t list option
145
-
val mdn_blob_ids : t -> Proto_id.t list option
146
-
147
-
val jsont : t Jsont.t
148
-
149
-
(** {1 Filter Conditions} *)
150
-
151
-
module Filter_condition : sig
152
-
type t = {
153
-
identity_ids : Proto_id.t list option;
154
-
email_ids : Proto_id.t list option;
155
-
thread_ids : Proto_id.t list option;
156
-
undo_status : undo_status option;
157
-
before : Ptime.t option;
158
-
after : Ptime.t option;
159
-
}
160
-
161
-
val jsont : t Jsont.t
162
-
end
-40
lib/mail/mail_thread.ml
-40
lib/mail/mail_thread.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(* Thread properties *)
7
-
8
-
type property = [
9
-
| `Id
10
-
| `Email_ids
11
-
]
12
-
13
-
let property_to_string : [< property ] -> string = function
14
-
| `Id -> "id"
15
-
| `Email_ids -> "emailIds"
16
-
17
-
let property_of_string s : property option =
18
-
match s with
19
-
| "id" -> Some `Id
20
-
| "emailIds" -> Some `Email_ids
21
-
| _ -> None
22
-
23
-
(* Thread type *)
24
-
25
-
type t = {
26
-
id : Proto_id.t option;
27
-
email_ids : Proto_id.t list option;
28
-
}
29
-
30
-
let id t = t.id
31
-
let email_ids t = t.email_ids
32
-
33
-
let make id email_ids = { id; email_ids }
34
-
35
-
let jsont =
36
-
let kind = "Thread" in
37
-
Jsont.Object.map ~kind make
38
-
|> Jsont.Object.opt_mem "id" Proto_id.jsont ~enc:id
39
-
|> Jsont.Object.opt_mem "emailIds" (Jsont.list Proto_id.jsont) ~enc:email_ids
40
-
|> Jsont.Object.finish
-39
lib/mail/mail_thread.mli
-39
lib/mail/mail_thread.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Thread type as defined in RFC 8621 Section 3
7
-
8
-
@canonical Jmap.Proto.Thread *)
9
-
10
-
(** {1 Thread Properties}
11
-
12
-
Polymorphic variants for type-safe property selection in Thread/get requests.
13
-
Threads have only two properties per RFC 8621 Section 3. *)
14
-
15
-
(** All Thread properties that can be requested. *)
16
-
type property = [
17
-
| `Id
18
-
| `Email_ids
19
-
]
20
-
21
-
val property_to_string : [< property ] -> string
22
-
(** Convert a property to its wire name (e.g., [`Email_ids] -> "emailIds"). *)
23
-
24
-
val property_of_string : string -> property option
25
-
(** Parse a property name, case-sensitive. *)
26
-
27
-
(** {1 Thread Object} *)
28
-
29
-
type t = {
30
-
id : Proto_id.t option;
31
-
(** Server-assigned thread id. *)
32
-
email_ids : Proto_id.t list option;
33
-
(** Ids of emails in this thread, in date order. *)
34
-
}
35
-
36
-
val id : t -> Proto_id.t option
37
-
val email_ids : t -> Proto_id.t list option
38
-
39
-
val jsont : t Jsont.t
-44
lib/mail/mail_vacation.ml
-44
lib/mail/mail_vacation.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = {
7
-
id : Proto_id.t;
8
-
is_enabled : bool;
9
-
from_date : Ptime.t option;
10
-
to_date : Ptime.t option;
11
-
subject : string option;
12
-
text_body : string option;
13
-
html_body : string option;
14
-
}
15
-
16
-
let id t = t.id
17
-
let is_enabled t = t.is_enabled
18
-
let from_date t = t.from_date
19
-
let to_date t = t.to_date
20
-
let subject t = t.subject
21
-
let text_body t = t.text_body
22
-
let html_body t = t.html_body
23
-
24
-
let singleton_id = Proto_id.of_string_exn "singleton"
25
-
26
-
let make id is_enabled from_date to_date subject text_body html_body =
27
-
{ id; is_enabled; from_date; to_date; subject; text_body; html_body }
28
-
29
-
let jsont =
30
-
let kind = "VacationResponse" in
31
-
(* subject, textBody, htmlBody can be null per RFC 8621 Section 8 *)
32
-
let nullable_string = Jsont.(option string) in
33
-
Jsont.Object.map ~kind make
34
-
|> Jsont.Object.mem "id" Proto_id.jsont ~enc:id
35
-
|> Jsont.Object.mem "isEnabled" Jsont.bool ~enc:is_enabled
36
-
|> Jsont.Object.opt_mem "fromDate" Proto_date.Utc.jsont ~enc:from_date
37
-
|> Jsont.Object.opt_mem "toDate" Proto_date.Utc.jsont ~enc:to_date
38
-
|> Jsont.Object.mem "subject" nullable_string
39
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:subject
40
-
|> Jsont.Object.mem "textBody" nullable_string
41
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:text_body
42
-
|> Jsont.Object.mem "htmlBody" nullable_string
43
-
~dec_absent:None ~enc_omit:Option.is_none ~enc:html_body
44
-
|> Jsont.Object.finish
-38
lib/mail/mail_vacation.mli
-38
lib/mail/mail_vacation.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** VacationResponse type as defined in RFC 8621 Section 8
7
-
8
-
@canonical Jmap.Proto.Vacation *)
9
-
10
-
type t = {
11
-
id : Proto_id.t;
12
-
(** Always "singleton" - there is only one vacation response. *)
13
-
is_enabled : bool;
14
-
(** Whether the vacation response is active. *)
15
-
from_date : Ptime.t option;
16
-
(** When to start sending responses. *)
17
-
to_date : Ptime.t option;
18
-
(** When to stop sending responses. *)
19
-
subject : string option;
20
-
(** Subject for the auto-reply. *)
21
-
text_body : string option;
22
-
(** Plain text body. *)
23
-
html_body : string option;
24
-
(** HTML body. *)
25
-
}
26
-
27
-
val id : t -> Proto_id.t
28
-
val is_enabled : t -> bool
29
-
val from_date : t -> Ptime.t option
30
-
val to_date : t -> Ptime.t option
31
-
val subject : t -> string option
32
-
val text_body : t -> string option
33
-
val html_body : t -> string option
34
-
35
-
val jsont : t Jsont.t
36
-
37
-
(** The singleton id for VacationResponse. *)
38
-
val singleton_id : Proto_id.t
-40
lib/proto/jmap_proto.ml
-40
lib/proto/jmap_proto.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP Protocol Types (RFC 8620/8621)
7
-
8
-
This module re-exports all JMAP core and mail protocol types. *)
9
-
10
-
(** {1 Core Protocol Types (RFC 8620)} *)
11
-
12
-
module Id = Proto_id
13
-
module Int53 = Proto_int53
14
-
module Date = Proto_date
15
-
module Json_map = Proto_json_map
16
-
module Unknown = Proto_unknown
17
-
module Error = Proto_error
18
-
module Capability = Proto_capability
19
-
module Filter = Proto_filter
20
-
module Method = Proto_method
21
-
module Invocation = Proto_invocation
22
-
module Request = Proto_request
23
-
module Response = Proto_response
24
-
module Session = Proto_session
25
-
module Push = Proto_push
26
-
module Blob = Proto_blob
27
-
28
-
(** {1 Mail Types (RFC 8621)} *)
29
-
30
-
module Email_address = Mail_address
31
-
module Email_header = Mail_header
32
-
module Email_body = Mail_body
33
-
module Mailbox = Mail_mailbox
34
-
module Thread = Mail_thread
35
-
module Email = Mail_email
36
-
module Search_snippet = Mail_snippet
37
-
module Identity = Mail_identity
38
-
module Submission = Mail_submission
39
-
module Vacation = Mail_vacation
40
-
module Mail_filter = Mail_filter
-105
lib/proto/proto_blob.ml
-105
lib/proto/proto_blob.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type upload_response = {
7
-
account_id : Proto_id.t;
8
-
blob_id : Proto_id.t;
9
-
type_ : string;
10
-
size : int64;
11
-
}
12
-
13
-
let upload_response_account_id t = t.account_id
14
-
let upload_response_blob_id t = t.blob_id
15
-
let upload_response_type t = t.type_
16
-
let upload_response_size t = t.size
17
-
18
-
let upload_response_make account_id blob_id type_ size =
19
-
{ account_id; blob_id; type_; size }
20
-
21
-
let upload_response_jsont =
22
-
let kind = "Upload response" in
23
-
Jsont.Object.map ~kind upload_response_make
24
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:upload_response_account_id
25
-
|> Jsont.Object.mem "blobId" Proto_id.jsont ~enc:upload_response_blob_id
26
-
|> Jsont.Object.mem "type" Jsont.string ~enc:upload_response_type
27
-
|> Jsont.Object.mem "size" Proto_int53.Unsigned.jsont ~enc:upload_response_size
28
-
|> Jsont.Object.finish
29
-
30
-
type download_vars = {
31
-
account_id : Proto_id.t;
32
-
blob_id : Proto_id.t;
33
-
type_ : string;
34
-
name : string;
35
-
}
36
-
37
-
let expand_download_url ~template vars =
38
-
let url_encode s =
39
-
(* Simple URL encoding *)
40
-
let buf = Buffer.create (String.length s * 3) in
41
-
String.iter (fun c ->
42
-
match c with
43
-
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '-' | '_' | '.' | '~' ->
44
-
Buffer.add_char buf c
45
-
| _ ->
46
-
Buffer.add_string buf (Printf.sprintf "%%%02X" (Char.code c))
47
-
) s;
48
-
Buffer.contents buf
49
-
in
50
-
template
51
-
|> String.split_on_char '{'
52
-
|> List.mapi (fun i part ->
53
-
if i = 0 then part
54
-
else
55
-
match String.index_opt part '}' with
56
-
| None -> "{" ^ part
57
-
| Some j ->
58
-
let var = String.sub part 0 j in
59
-
let rest = String.sub part (j + 1) (String.length part - j - 1) in
60
-
let value = match var with
61
-
| "accountId" -> url_encode (Proto_id.to_string vars.account_id)
62
-
| "blobId" -> url_encode (Proto_id.to_string vars.blob_id)
63
-
| "type" -> url_encode vars.type_
64
-
| "name" -> url_encode vars.name
65
-
| _ -> "{" ^ var ^ "}"
66
-
in
67
-
value ^ rest
68
-
)
69
-
|> String.concat ""
70
-
71
-
type copy_args = {
72
-
from_account_id : Proto_id.t;
73
-
account_id : Proto_id.t;
74
-
blob_ids : Proto_id.t list;
75
-
}
76
-
77
-
let copy_args_make from_account_id account_id blob_ids =
78
-
{ from_account_id; account_id; blob_ids }
79
-
80
-
let copy_args_jsont =
81
-
let kind = "Blob/copy args" in
82
-
Jsont.Object.map ~kind copy_args_make
83
-
|> Jsont.Object.mem "fromAccountId" Proto_id.jsont ~enc:(fun a -> a.from_account_id)
84
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
85
-
|> Jsont.Object.mem "blobIds" (Jsont.list Proto_id.jsont) ~enc:(fun a -> a.blob_ids)
86
-
|> Jsont.Object.finish
87
-
88
-
type copy_response = {
89
-
from_account_id : Proto_id.t;
90
-
account_id : Proto_id.t;
91
-
copied : (Proto_id.t * Proto_id.t) list option;
92
-
not_copied : (Proto_id.t * Proto_error.set_error) list option;
93
-
}
94
-
95
-
let copy_response_make from_account_id account_id copied not_copied =
96
-
{ from_account_id; account_id; copied; not_copied }
97
-
98
-
let copy_response_jsont =
99
-
let kind = "Blob/copy response" in
100
-
Jsont.Object.map ~kind copy_response_make
101
-
|> Jsont.Object.mem "fromAccountId" Proto_id.jsont ~enc:(fun r -> r.from_account_id)
102
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id)
103
-
|> Jsont.Object.opt_mem "copied" (Proto_json_map.of_id Proto_id.jsont) ~enc:(fun r -> r.copied)
104
-
|> Jsont.Object.opt_mem "notCopied" (Proto_json_map.of_id Proto_error.set_error_jsont) ~enc:(fun r -> r.not_copied)
105
-
|> Jsont.Object.finish
-67
lib/proto/proto_blob.mli
-67
lib/proto/proto_blob.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP blob upload/download types as defined in RFC 8620 Section 6
7
-
8
-
@canonical Jmap.Proto.Blob *)
9
-
10
-
(** {1 Upload Response} *)
11
-
12
-
(** Response from a blob upload. *)
13
-
type upload_response = {
14
-
account_id : Proto_id.t;
15
-
(** The account the blob was uploaded to. *)
16
-
blob_id : Proto_id.t;
17
-
(** The server-assigned blob id. *)
18
-
type_ : string;
19
-
(** The media type of the uploaded blob. *)
20
-
size : int64;
21
-
(** The size in octets. *)
22
-
}
23
-
24
-
val upload_response_account_id : upload_response -> Proto_id.t
25
-
val upload_response_blob_id : upload_response -> Proto_id.t
26
-
val upload_response_type : upload_response -> string
27
-
val upload_response_size : upload_response -> int64
28
-
29
-
val upload_response_jsont : upload_response Jsont.t
30
-
31
-
(** {1 Download URL Template} *)
32
-
33
-
(** Variables for the download URL template. *)
34
-
type download_vars = {
35
-
account_id : Proto_id.t;
36
-
blob_id : Proto_id.t;
37
-
type_ : string;
38
-
name : string;
39
-
}
40
-
41
-
val expand_download_url : template:string -> download_vars -> string
42
-
(** [expand_download_url ~template vars] expands the download URL template
43
-
with the given variables. Template uses {accountId}, {blobId},
44
-
{type}, and {name} placeholders. *)
45
-
46
-
(** {1 Blob/copy} *)
47
-
48
-
(** Arguments for Blob/copy. *)
49
-
type copy_args = {
50
-
from_account_id : Proto_id.t;
51
-
account_id : Proto_id.t;
52
-
blob_ids : Proto_id.t list;
53
-
}
54
-
55
-
val copy_args_jsont : copy_args Jsont.t
56
-
57
-
(** Response for Blob/copy. *)
58
-
type copy_response = {
59
-
from_account_id : Proto_id.t;
60
-
account_id : Proto_id.t;
61
-
copied : (Proto_id.t * Proto_id.t) list option;
62
-
(** Map of old blob id to new blob id. *)
63
-
not_copied : (Proto_id.t * Proto_error.set_error) list option;
64
-
(** Blobs that could not be copied. *)
65
-
}
66
-
67
-
val copy_response_jsont : copy_response Jsont.t
-171
lib/proto/proto_capability.ml
-171
lib/proto/proto_capability.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
let core = "urn:ietf:params:jmap:core"
7
-
let mail = "urn:ietf:params:jmap:mail"
8
-
let submission = "urn:ietf:params:jmap:submission"
9
-
let vacation_response = "urn:ietf:params:jmap:vacationresponse"
10
-
11
-
module Core = struct
12
-
type t = {
13
-
max_size_upload : int64;
14
-
max_concurrent_upload : int;
15
-
max_size_request : int64;
16
-
max_concurrent_requests : int;
17
-
max_calls_in_request : int;
18
-
max_objects_in_get : int;
19
-
max_objects_in_set : int;
20
-
collation_algorithms : string list;
21
-
}
22
-
23
-
let create ~max_size_upload ~max_concurrent_upload ~max_size_request
24
-
~max_concurrent_requests ~max_calls_in_request ~max_objects_in_get
25
-
~max_objects_in_set ~collation_algorithms =
26
-
{ max_size_upload; max_concurrent_upload; max_size_request;
27
-
max_concurrent_requests; max_calls_in_request; max_objects_in_get;
28
-
max_objects_in_set; collation_algorithms }
29
-
30
-
let max_size_upload t = t.max_size_upload
31
-
let max_concurrent_upload t = t.max_concurrent_upload
32
-
let max_size_request t = t.max_size_request
33
-
let max_concurrent_requests t = t.max_concurrent_requests
34
-
let max_calls_in_request t = t.max_calls_in_request
35
-
let max_objects_in_get t = t.max_objects_in_get
36
-
let max_objects_in_set t = t.max_objects_in_set
37
-
let collation_algorithms t = t.collation_algorithms
38
-
39
-
let make max_size_upload max_concurrent_upload max_size_request
40
-
max_concurrent_requests max_calls_in_request max_objects_in_get
41
-
max_objects_in_set collation_algorithms =
42
-
{ max_size_upload; max_concurrent_upload; max_size_request;
43
-
max_concurrent_requests; max_calls_in_request; max_objects_in_get;
44
-
max_objects_in_set; collation_algorithms }
45
-
46
-
let jsont =
47
-
let kind = "Core capability" in
48
-
Jsont.Object.map ~kind make
49
-
|> Jsont.Object.mem "maxSizeUpload" Proto_int53.Unsigned.jsont ~enc:max_size_upload
50
-
|> Jsont.Object.mem "maxConcurrentUpload" Jsont.int ~enc:max_concurrent_upload
51
-
|> Jsont.Object.mem "maxSizeRequest" Proto_int53.Unsigned.jsont ~enc:max_size_request
52
-
|> Jsont.Object.mem "maxConcurrentRequests" Jsont.int ~enc:max_concurrent_requests
53
-
|> Jsont.Object.mem "maxCallsInRequest" Jsont.int ~enc:max_calls_in_request
54
-
|> Jsont.Object.mem "maxObjectsInGet" Jsont.int ~enc:max_objects_in_get
55
-
|> Jsont.Object.mem "maxObjectsInSet" Jsont.int ~enc:max_objects_in_set
56
-
|> Jsont.Object.mem "collationAlgorithms" (Jsont.list Jsont.string) ~enc:collation_algorithms
57
-
|> Jsont.Object.finish
58
-
end
59
-
60
-
module Mail = struct
61
-
type t = {
62
-
max_mailboxes_per_email : int64 option;
63
-
max_mailbox_depth : int64 option;
64
-
max_size_mailbox_name : int64;
65
-
max_size_attachments_per_email : int64;
66
-
email_query_sort_options : string list;
67
-
may_create_top_level_mailbox : bool;
68
-
}
69
-
70
-
let create ?max_mailboxes_per_email ?max_mailbox_depth ~max_size_mailbox_name
71
-
~max_size_attachments_per_email ~email_query_sort_options
72
-
~may_create_top_level_mailbox () =
73
-
{ max_mailboxes_per_email; max_mailbox_depth; max_size_mailbox_name;
74
-
max_size_attachments_per_email; email_query_sort_options;
75
-
may_create_top_level_mailbox }
76
-
77
-
let max_mailboxes_per_email t = t.max_mailboxes_per_email
78
-
let max_mailbox_depth t = t.max_mailbox_depth
79
-
let max_size_mailbox_name t = t.max_size_mailbox_name
80
-
let max_size_attachments_per_email t = t.max_size_attachments_per_email
81
-
let email_query_sort_options t = t.email_query_sort_options
82
-
let may_create_top_level_mailbox t = t.may_create_top_level_mailbox
83
-
84
-
let make max_mailboxes_per_email max_mailbox_depth max_size_mailbox_name
85
-
max_size_attachments_per_email email_query_sort_options
86
-
may_create_top_level_mailbox =
87
-
{ max_mailboxes_per_email; max_mailbox_depth; max_size_mailbox_name;
88
-
max_size_attachments_per_email; email_query_sort_options;
89
-
may_create_top_level_mailbox }
90
-
91
-
let jsont =
92
-
let kind = "Mail capability" in
93
-
Jsont.Object.map ~kind make
94
-
|> Jsont.Object.opt_mem "maxMailboxesPerEmail" Proto_int53.Unsigned.jsont ~enc:max_mailboxes_per_email
95
-
|> Jsont.Object.opt_mem "maxMailboxDepth" Proto_int53.Unsigned.jsont ~enc:max_mailbox_depth
96
-
|> Jsont.Object.mem "maxSizeMailboxName" Proto_int53.Unsigned.jsont ~enc:max_size_mailbox_name
97
-
|> Jsont.Object.mem "maxSizeAttachmentsPerEmail" Proto_int53.Unsigned.jsont ~enc:max_size_attachments_per_email
98
-
|> Jsont.Object.mem "emailQuerySortOptions" (Jsont.list Jsont.string) ~enc:email_query_sort_options
99
-
|> Jsont.Object.mem "mayCreateTopLevelMailbox" Jsont.bool ~enc:may_create_top_level_mailbox
100
-
|> Jsont.Object.finish
101
-
end
102
-
103
-
module Submission = struct
104
-
type t = {
105
-
max_delayed_send : int64;
106
-
submission_extensions : (string * string list) list;
107
-
}
108
-
109
-
let create ~max_delayed_send ~submission_extensions =
110
-
{ max_delayed_send; submission_extensions }
111
-
112
-
let max_delayed_send t = t.max_delayed_send
113
-
let submission_extensions t = t.submission_extensions
114
-
115
-
let make max_delayed_send submission_extensions =
116
-
{ max_delayed_send; submission_extensions }
117
-
118
-
let submission_extensions_jsont =
119
-
Proto_json_map.of_string (Jsont.list Jsont.string)
120
-
121
-
let jsont =
122
-
let kind = "Submission capability" in
123
-
Jsont.Object.map ~kind make
124
-
|> Jsont.Object.mem "maxDelayedSend" Proto_int53.Unsigned.jsont ~enc:max_delayed_send
125
-
|> Jsont.Object.mem "submissionExtensions" submission_extensions_jsont ~enc:submission_extensions
126
-
|> Jsont.Object.finish
127
-
end
128
-
129
-
type capability =
130
-
| Core of Core.t
131
-
| Mail of Mail.t
132
-
| Submission of Submission.t
133
-
| Vacation_response
134
-
| Unknown of Jsont.json
135
-
136
-
let capability_of_json uri json =
137
-
match uri with
138
-
| u when u = core ->
139
-
(match Jsont.Json.decode' Core.jsont json with
140
-
| Ok c -> Core c
141
-
| Error _ -> Unknown json)
142
-
| u when u = mail ->
143
-
(match Jsont.Json.decode' Mail.jsont json with
144
-
| Ok m -> Mail m
145
-
| Error _ -> Unknown json)
146
-
| u when u = submission ->
147
-
(match Jsont.Json.decode' Submission.jsont json with
148
-
| Ok s -> Submission s
149
-
| Error _ -> Unknown json)
150
-
| u when u = vacation_response ->
151
-
Vacation_response
152
-
| _ ->
153
-
Unknown json
154
-
155
-
let capability_to_json (uri, cap) =
156
-
let encode jsont v =
157
-
match Jsont.Json.encode' jsont v with
158
-
| Ok json -> json
159
-
| Error _ -> Jsont.Object ([], Jsont.Meta.none)
160
-
in
161
-
match cap with
162
-
| Core c ->
163
-
(uri, encode Core.jsont c)
164
-
| Mail m ->
165
-
(uri, encode Mail.jsont m)
166
-
| Submission s ->
167
-
(uri, encode Submission.jsont s)
168
-
| Vacation_response ->
169
-
(uri, Jsont.Object ([], Jsont.Meta.none))
170
-
| Unknown json ->
171
-
(uri, json)
-145
lib/proto/proto_capability.mli
-145
lib/proto/proto_capability.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP capability types as defined in RFC 8620 Section 2
7
-
8
-
@canonical Jmap.Proto.Capability *)
9
-
10
-
(** {1 Standard Capability URIs} *)
11
-
12
-
val core : string
13
-
(** [urn:ietf:params:jmap:core] - Core JMAP capability (RFC 8620) *)
14
-
15
-
val mail : string
16
-
(** [urn:ietf:params:jmap:mail] - Mail capability (RFC 8621) *)
17
-
18
-
val submission : string
19
-
(** [urn:ietf:params:jmap:submission] - Email submission capability (RFC 8621) *)
20
-
21
-
val vacation_response : string
22
-
(** [urn:ietf:params:jmap:vacationresponse] - Vacation response capability (RFC 8621) *)
23
-
24
-
(** {1 Core Capability Object} *)
25
-
26
-
(** Core capability limits and configuration per RFC 8620 Section 2. *)
27
-
module Core : sig
28
-
type t = {
29
-
max_size_upload : int64;
30
-
(** Maximum size in octets for a single blob upload. *)
31
-
max_concurrent_upload : int;
32
-
(** Maximum number of concurrent upload requests. *)
33
-
max_size_request : int64;
34
-
(** Maximum size in octets of a single request. *)
35
-
max_concurrent_requests : int;
36
-
(** Maximum number of concurrent requests. *)
37
-
max_calls_in_request : int;
38
-
(** Maximum number of method calls in a single request. *)
39
-
max_objects_in_get : int;
40
-
(** Maximum number of objects in a single /get request. *)
41
-
max_objects_in_set : int;
42
-
(** Maximum number of objects in a single /set request. *)
43
-
collation_algorithms : string list;
44
-
(** Supported collation algorithms for sorting. *)
45
-
}
46
-
47
-
val create :
48
-
max_size_upload:int64 ->
49
-
max_concurrent_upload:int ->
50
-
max_size_request:int64 ->
51
-
max_concurrent_requests:int ->
52
-
max_calls_in_request:int ->
53
-
max_objects_in_get:int ->
54
-
max_objects_in_set:int ->
55
-
collation_algorithms:string list ->
56
-
t
57
-
58
-
val max_size_upload : t -> int64
59
-
val max_concurrent_upload : t -> int
60
-
val max_size_request : t -> int64
61
-
val max_concurrent_requests : t -> int
62
-
val max_calls_in_request : t -> int
63
-
val max_objects_in_get : t -> int
64
-
val max_objects_in_set : t -> int
65
-
val collation_algorithms : t -> string list
66
-
67
-
val jsont : t Jsont.t
68
-
(** JSON codec for core capability. *)
69
-
end
70
-
71
-
(** {1 Mail Capability Object} *)
72
-
73
-
(** Mail capability configuration per RFC 8621. *)
74
-
module Mail : sig
75
-
type t = {
76
-
max_mailboxes_per_email : int64 option;
77
-
(** Maximum number of mailboxes an email can belong to. *)
78
-
max_mailbox_depth : int64 option;
79
-
(** Maximum depth of mailbox hierarchy. *)
80
-
max_size_mailbox_name : int64;
81
-
(** Maximum size of a mailbox name in octets. *)
82
-
max_size_attachments_per_email : int64;
83
-
(** Maximum total size of attachments per email. *)
84
-
email_query_sort_options : string list;
85
-
(** Supported sort options for Email/query. *)
86
-
may_create_top_level_mailbox : bool;
87
-
(** Whether the user may create top-level mailboxes. *)
88
-
}
89
-
90
-
val create :
91
-
?max_mailboxes_per_email:int64 ->
92
-
?max_mailbox_depth:int64 ->
93
-
max_size_mailbox_name:int64 ->
94
-
max_size_attachments_per_email:int64 ->
95
-
email_query_sort_options:string list ->
96
-
may_create_top_level_mailbox:bool ->
97
-
unit ->
98
-
t
99
-
100
-
val max_mailboxes_per_email : t -> int64 option
101
-
val max_mailbox_depth : t -> int64 option
102
-
val max_size_mailbox_name : t -> int64
103
-
val max_size_attachments_per_email : t -> int64
104
-
val email_query_sort_options : t -> string list
105
-
val may_create_top_level_mailbox : t -> bool
106
-
107
-
val jsont : t Jsont.t
108
-
end
109
-
110
-
(** {1 Submission Capability Object} *)
111
-
112
-
module Submission : sig
113
-
type t = {
114
-
max_delayed_send : int64;
115
-
(** Maximum delay in seconds for delayed sending (0 = not supported). *)
116
-
submission_extensions : (string * string list) list;
117
-
(** SMTP extensions supported. *)
118
-
}
119
-
120
-
val create :
121
-
max_delayed_send:int64 ->
122
-
submission_extensions:(string * string list) list ->
123
-
t
124
-
125
-
val max_delayed_send : t -> int64
126
-
val submission_extensions : t -> (string * string list) list
127
-
128
-
val jsont : t Jsont.t
129
-
end
130
-
131
-
(** {1 Generic Capability Handling} *)
132
-
133
-
(** A capability value that can be either a known type or unknown JSON. *)
134
-
type capability =
135
-
| Core of Core.t
136
-
| Mail of Mail.t
137
-
| Submission of Submission.t
138
-
| Vacation_response (* No configuration *)
139
-
| Unknown of Jsont.json
140
-
141
-
val capability_of_json : string -> Jsont.json -> capability
142
-
(** [capability_of_json uri json] parses a capability from its URI and JSON value. *)
143
-
144
-
val capability_to_json : string * capability -> string * Jsont.json
145
-
(** [capability_to_json (uri, cap)] encodes a capability to URI and JSON. *)
-64
lib/proto/proto_date.ml
-64
lib/proto/proto_date.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Date and time types for JMAP.
7
-
8
-
JMAP uses RFC 3339 formatted date-time strings. *)
9
-
10
-
(** RFC 3339 date-time with any timezone offset *)
11
-
module Rfc3339 = struct
12
-
type t = Ptime.t
13
-
14
-
let of_string s =
15
-
match Ptime.of_rfc3339 s with
16
-
| Ok (t, _, _) -> Ok t
17
-
| Error _ -> Error (Printf.sprintf "Invalid RFC 3339 date: %s" s)
18
-
19
-
let to_string t =
20
-
(* Format with 'T' separator and timezone offset *)
21
-
Ptime.to_rfc3339 ~tz_offset_s:0 t
22
-
23
-
let jsont =
24
-
let kind = "Date" in
25
-
let dec s =
26
-
match of_string s with
27
-
| Ok t -> t
28
-
| Error msg -> Jsont.Error.msgf Jsont.Meta.none "%s: %s" kind msg
29
-
in
30
-
let enc = to_string in
31
-
Jsont.map ~kind ~dec ~enc Jsont.string
32
-
end
33
-
34
-
(** UTC date-time (must use 'Z' timezone suffix) *)
35
-
module Utc = struct
36
-
type t = Ptime.t
37
-
38
-
let of_string s =
39
-
(* Must end with 'Z' for UTC *)
40
-
let len = String.length s in
41
-
if len > 0 && s.[len - 1] <> 'Z' then
42
-
Error "UTCDate must use 'Z' timezone suffix"
43
-
else
44
-
match Ptime.of_rfc3339 s with
45
-
| Ok (t, _, _) -> Ok t
46
-
| Error _ -> Error (Printf.sprintf "Invalid RFC 3339 UTC date: %s" s)
47
-
48
-
let to_string t =
49
-
(* Always format with 'Z' suffix *)
50
-
Ptime.to_rfc3339 ~tz_offset_s:0 t
51
-
52
-
let of_ptime t = t
53
-
let to_ptime t = t
54
-
55
-
let jsont =
56
-
let kind = "UTCDate" in
57
-
let dec s =
58
-
match of_string s with
59
-
| Ok t -> t
60
-
| Error msg -> Jsont.Error.msgf Jsont.Meta.none "%s: %s" kind msg
61
-
in
62
-
let enc = to_string in
63
-
Jsont.map ~kind ~dec ~enc Jsont.string
64
-
end
-53
lib/proto/proto_date.mli
-53
lib/proto/proto_date.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Date and time types for JMAP.
7
-
8
-
JMAP uses RFC 3339 formatted date-time strings.
9
-
10
-
See {{:https://datatracker.ietf.org/doc/html/rfc8620#section-1.4} RFC 8620 Section 1.4}.
11
-
12
-
@canonical Jmap.Proto.Date *)
13
-
14
-
(** RFC 3339 date-time.
15
-
16
-
A date-time string with uppercase 'T' separator. May have any timezone. *)
17
-
module Rfc3339 : sig
18
-
type t = Ptime.t
19
-
(** The type of dates. *)
20
-
21
-
val of_string : string -> (t, string) result
22
-
(** [of_string s] parses an RFC 3339 date-time string. *)
23
-
24
-
val to_string : t -> string
25
-
(** [to_string d] formats [d] as an RFC 3339 string. *)
26
-
27
-
val jsont : t Jsont.t
28
-
(** JSON codec for RFC 3339 dates. *)
29
-
end
30
-
31
-
(** UTC date-time.
32
-
33
-
A date-time string that MUST have 'Z' as the timezone (UTC only). *)
34
-
module Utc : sig
35
-
type t = Ptime.t
36
-
(** The type of UTC dates. *)
37
-
38
-
val of_string : string -> (t, string) result
39
-
(** [of_string s] parses an RFC 3339 UTC date-time string.
40
-
Returns error if timezone is not 'Z'. *)
41
-
42
-
val to_string : t -> string
43
-
(** [to_string d] formats [d] as an RFC 3339 UTC string with 'Z'. *)
44
-
45
-
val of_ptime : Ptime.t -> t
46
-
(** [of_ptime p] creates a UTC date from a Ptime value. *)
47
-
48
-
val to_ptime : t -> Ptime.t
49
-
(** [to_ptime d] returns the underlying Ptime value. *)
50
-
51
-
val jsont : t Jsont.t
52
-
(** JSON codec for UTC dates. *)
53
-
end
-202
lib/proto/proto_error.ml
-202
lib/proto/proto_error.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
module Request_error = struct
7
-
type urn = [
8
-
| `Unknown_capability
9
-
| `Not_json
10
-
| `Not_request
11
-
| `Limit
12
-
| `Other of string
13
-
]
14
-
15
-
let urn_to_string = function
16
-
| `Unknown_capability -> "urn:ietf:params:jmap:error:unknownCapability"
17
-
| `Not_json -> "urn:ietf:params:jmap:error:notJSON"
18
-
| `Not_request -> "urn:ietf:params:jmap:error:notRequest"
19
-
| `Limit -> "urn:ietf:params:jmap:error:limit"
20
-
| `Other s -> s
21
-
22
-
let urn_of_string = function
23
-
| "urn:ietf:params:jmap:error:unknownCapability" -> `Unknown_capability
24
-
| "urn:ietf:params:jmap:error:notJSON" -> `Not_json
25
-
| "urn:ietf:params:jmap:error:notRequest" -> `Not_request
26
-
| "urn:ietf:params:jmap:error:limit" -> `Limit
27
-
| s -> `Other s
28
-
29
-
let urn_jsont =
30
-
let kind = "Request error URN" in
31
-
Jsont.map ~kind
32
-
~dec:(fun s -> urn_of_string s)
33
-
~enc:urn_to_string
34
-
Jsont.string
35
-
36
-
type t = {
37
-
type_ : urn;
38
-
status : int;
39
-
title : string option;
40
-
detail : string option;
41
-
limit : string option;
42
-
}
43
-
44
-
let make type_ status title detail limit =
45
-
{ type_; status; title; detail; limit }
46
-
47
-
let type_ t = t.type_
48
-
let status t = t.status
49
-
let title t = t.title
50
-
let detail t = t.detail
51
-
let limit t = t.limit
52
-
53
-
let jsont =
54
-
let kind = "Request error" in
55
-
Jsont.Object.map ~kind make
56
-
|> Jsont.Object.mem "type" urn_jsont ~enc:type_
57
-
|> Jsont.Object.mem "status" Jsont.int ~enc:status
58
-
|> Jsont.Object.opt_mem "title" Jsont.string ~enc:title
59
-
|> Jsont.Object.opt_mem "detail" Jsont.string ~enc:detail
60
-
|> Jsont.Object.opt_mem "limit" Jsont.string ~enc:limit
61
-
|> Jsont.Object.finish
62
-
end
63
-
64
-
type method_error_type = [
65
-
| `Server_unavailable
66
-
| `Server_fail
67
-
| `Server_partial_fail
68
-
| `Unknown_method
69
-
| `Invalid_arguments
70
-
| `Invalid_result_reference
71
-
| `Forbidden
72
-
| `Account_not_found
73
-
| `Account_not_supported_by_method
74
-
| `Account_read_only
75
-
| `Other of string
76
-
]
77
-
78
-
let method_error_type_to_string = function
79
-
| `Server_unavailable -> "serverUnavailable"
80
-
| `Server_fail -> "serverFail"
81
-
| `Server_partial_fail -> "serverPartialFail"
82
-
| `Unknown_method -> "unknownMethod"
83
-
| `Invalid_arguments -> "invalidArguments"
84
-
| `Invalid_result_reference -> "invalidResultReference"
85
-
| `Forbidden -> "forbidden"
86
-
| `Account_not_found -> "accountNotFound"
87
-
| `Account_not_supported_by_method -> "accountNotSupportedByMethod"
88
-
| `Account_read_only -> "accountReadOnly"
89
-
| `Other s -> s
90
-
91
-
let method_error_type_of_string = function
92
-
| "serverUnavailable" -> `Server_unavailable
93
-
| "serverFail" -> `Server_fail
94
-
| "serverPartialFail" -> `Server_partial_fail
95
-
| "unknownMethod" -> `Unknown_method
96
-
| "invalidArguments" -> `Invalid_arguments
97
-
| "invalidResultReference" -> `Invalid_result_reference
98
-
| "forbidden" -> `Forbidden
99
-
| "accountNotFound" -> `Account_not_found
100
-
| "accountNotSupportedByMethod" -> `Account_not_supported_by_method
101
-
| "accountReadOnly" -> `Account_read_only
102
-
| s -> `Other s
103
-
104
-
let method_error_type_jsont =
105
-
let kind = "Method error type" in
106
-
Jsont.map ~kind
107
-
~dec:(fun s -> method_error_type_of_string s)
108
-
~enc:method_error_type_to_string
109
-
Jsont.string
110
-
111
-
type method_error = {
112
-
type_ : method_error_type;
113
-
description : string option;
114
-
}
115
-
116
-
let method_error_make type_ description = { type_; description }
117
-
let method_error_type_ t = t.type_
118
-
let method_error_description t = t.description
119
-
120
-
let method_error_jsont =
121
-
let kind = "Method error" in
122
-
Jsont.Object.map ~kind method_error_make
123
-
|> Jsont.Object.mem "type" method_error_type_jsont ~enc:method_error_type_
124
-
|> Jsont.Object.opt_mem "description" Jsont.string ~enc:method_error_description
125
-
|> Jsont.Object.finish
126
-
127
-
type set_error_type = [
128
-
| `Forbidden
129
-
| `Over_quota
130
-
| `Too_large
131
-
| `Rate_limit
132
-
| `Not_found
133
-
| `Invalid_patch
134
-
| `Will_destroy
135
-
| `Invalid_properties
136
-
| `Singleton
137
-
| `Forbidden_mail_from
138
-
| `Forbidden_from
139
-
| `Forbidden_to_send
140
-
| `Other of string
141
-
]
142
-
143
-
let set_error_type_to_string = function
144
-
| `Forbidden -> "forbidden"
145
-
| `Over_quota -> "overQuota"
146
-
| `Too_large -> "tooLarge"
147
-
| `Rate_limit -> "rateLimit"
148
-
| `Not_found -> "notFound"
149
-
| `Invalid_patch -> "invalidPatch"
150
-
| `Will_destroy -> "willDestroy"
151
-
| `Invalid_properties -> "invalidProperties"
152
-
| `Singleton -> "singleton"
153
-
| `Forbidden_mail_from -> "forbiddenMailFrom"
154
-
| `Forbidden_from -> "forbiddenFrom"
155
-
| `Forbidden_to_send -> "forbiddenToSend"
156
-
| `Other s -> s
157
-
158
-
let set_error_type_of_string = function
159
-
| "forbidden" -> `Forbidden
160
-
| "overQuota" -> `Over_quota
161
-
| "tooLarge" -> `Too_large
162
-
| "rateLimit" -> `Rate_limit
163
-
| "notFound" -> `Not_found
164
-
| "invalidPatch" -> `Invalid_patch
165
-
| "willDestroy" -> `Will_destroy
166
-
| "invalidProperties" -> `Invalid_properties
167
-
| "singleton" -> `Singleton
168
-
| "forbiddenMailFrom" -> `Forbidden_mail_from
169
-
| "forbiddenFrom" -> `Forbidden_from
170
-
| "forbiddenToSend" -> `Forbidden_to_send
171
-
| s -> `Other s
172
-
173
-
let set_error_type_jsont =
174
-
let kind = "SetError type" in
175
-
Jsont.map ~kind
176
-
~dec:(fun s -> set_error_type_of_string s)
177
-
~enc:set_error_type_to_string
178
-
Jsont.string
179
-
180
-
type set_error = {
181
-
type_ : set_error_type;
182
-
description : string option;
183
-
properties : string list option;
184
-
}
185
-
186
-
let set_error ?description ?properties type_ =
187
-
{ type_; description; properties }
188
-
189
-
let set_error_make type_ description properties =
190
-
{ type_; description; properties }
191
-
192
-
let set_error_type_ t = t.type_
193
-
let set_error_description t = t.description
194
-
let set_error_properties t = t.properties
195
-
196
-
let set_error_jsont =
197
-
let kind = "SetError" in
198
-
Jsont.Object.map ~kind set_error_make
199
-
|> Jsont.Object.mem "type" set_error_type_jsont ~enc:set_error_type_
200
-
|> Jsont.Object.opt_mem "description" Jsont.string ~enc:set_error_description
201
-
|> Jsont.Object.opt_mem "properties" (Jsont.list Jsont.string) ~enc:set_error_properties
202
-
|> Jsont.Object.finish
-158
lib/proto/proto_error.mli
-158
lib/proto/proto_error.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP error types as defined in RFC 8620 Section 3.6.1-3.6.2
7
-
8
-
@canonical Jmap.Proto.Error *)
9
-
10
-
(** {1 Request-Level Errors}
11
-
12
-
These errors are returned with an HTTP error status code and a JSON
13
-
Problem Details body (RFC 7807). *)
14
-
15
-
(** Request-level error URNs *)
16
-
module Request_error : sig
17
-
type urn = [
18
-
| `Unknown_capability
19
-
(** urn:ietf:params:jmap:error:unknownCapability
20
-
The client included a capability in "using" that the server does not support. *)
21
-
| `Not_json
22
-
(** urn:ietf:params:jmap:error:notJSON
23
-
The content type was not application/json or the request was not valid JSON. *)
24
-
| `Not_request
25
-
(** urn:ietf:params:jmap:error:notRequest
26
-
The request was valid JSON but not a valid JMAP Request object. *)
27
-
| `Limit
28
-
(** urn:ietf:params:jmap:error:limit
29
-
A server-defined limit was reached. *)
30
-
| `Other of string
31
-
(** Other URN not in the standard set. *)
32
-
]
33
-
34
-
val urn_to_string : urn -> string
35
-
(** [urn_to_string urn] returns the URN string. *)
36
-
37
-
val urn_of_string : string -> urn
38
-
(** [urn_of_string s] parses a URN string. *)
39
-
40
-
type t = {
41
-
type_ : urn;
42
-
(** The error type URN. *)
43
-
status : int;
44
-
(** HTTP status code. *)
45
-
title : string option;
46
-
(** Short human-readable summary. *)
47
-
detail : string option;
48
-
(** Longer human-readable explanation. *)
49
-
limit : string option;
50
-
(** For "limit" errors, the name of the limit that was exceeded. *)
51
-
}
52
-
(** A request-level error per RFC 7807 Problem Details. *)
53
-
54
-
val jsont : t Jsont.t
55
-
(** JSON codec for request-level errors. *)
56
-
end
57
-
58
-
(** {1 Method-Level Errors}
59
-
60
-
These are returned as the second element of an Invocation tuple
61
-
when a method call fails. *)
62
-
63
-
(** Standard method error types per RFC 8620 Section 3.6.2 *)
64
-
type method_error_type = [
65
-
| `Server_unavailable
66
-
(** The server is temporarily unavailable. *)
67
-
| `Server_fail
68
-
(** An unexpected error occurred. *)
69
-
| `Server_partial_fail
70
-
(** Some, but not all, changes were successfully made. *)
71
-
| `Unknown_method
72
-
(** The method name is not recognized. *)
73
-
| `Invalid_arguments
74
-
(** One or more arguments are invalid. *)
75
-
| `Invalid_result_reference
76
-
(** A result reference could not be resolved. *)
77
-
| `Forbidden
78
-
(** The method/arguments are valid but forbidden. *)
79
-
| `Account_not_found
80
-
(** The accountId does not correspond to a valid account. *)
81
-
| `Account_not_supported_by_method
82
-
(** The account does not support this method. *)
83
-
| `Account_read_only
84
-
(** The account is read-only. *)
85
-
| `Other of string
86
-
(** Other error type not in the standard set. *)
87
-
]
88
-
89
-
val method_error_type_to_string : method_error_type -> string
90
-
(** [method_error_type_to_string t] returns the type string. *)
91
-
92
-
val method_error_type_of_string : string -> method_error_type
93
-
(** [method_error_type_of_string s] parses a type string. *)
94
-
95
-
(** A method-level error response. *)
96
-
type method_error = {
97
-
type_ : method_error_type;
98
-
(** The error type. *)
99
-
description : string option;
100
-
(** Human-readable description of the error. *)
101
-
}
102
-
103
-
val method_error_jsont : method_error Jsont.t
104
-
(** JSON codec for method errors. *)
105
-
106
-
(** {1 SetError}
107
-
108
-
Errors returned in notCreated/notUpdated/notDestroyed responses. *)
109
-
110
-
(** Standard SetError types per RFC 8620 Section 5.3 and RFC 8621 Section 7 *)
111
-
type set_error_type = [
112
-
| `Forbidden
113
-
(** The operation is not permitted. *)
114
-
| `Over_quota
115
-
(** The maximum server quota has been reached. *)
116
-
| `Too_large
117
-
(** The object is too large. *)
118
-
| `Rate_limit
119
-
(** Too many objects of this type have been created recently. *)
120
-
| `Not_found
121
-
(** The id does not exist (for update/destroy). *)
122
-
| `Invalid_patch
123
-
(** The PatchObject is invalid. *)
124
-
| `Will_destroy
125
-
(** The object will be destroyed by another operation in the request. *)
126
-
| `Invalid_properties
127
-
(** Some properties were invalid. *)
128
-
| `Singleton
129
-
(** Only one object of this type can exist (for create). *)
130
-
| `Forbidden_mail_from
131
-
(** RFC 8621: The server does not permit the user to send from the address. *)
132
-
| `Forbidden_from
133
-
(** RFC 8621: The server does not permit the user to send a message with
134
-
the From header of the message to be sent. *)
135
-
| `Forbidden_to_send
136
-
(** RFC 8621: The user does not have permission to send at all. *)
137
-
| `Other of string
138
-
(** Other error type. *)
139
-
]
140
-
141
-
val set_error_type_to_string : set_error_type -> string
142
-
val set_error_type_of_string : string -> set_error_type
143
-
144
-
(** A SetError object. *)
145
-
type set_error = {
146
-
type_ : set_error_type;
147
-
(** The error type. *)
148
-
description : string option;
149
-
(** Human-readable description. *)
150
-
properties : string list option;
151
-
(** For invalidProperties errors, the list of invalid property names. *)
152
-
}
153
-
154
-
val set_error : ?description:string -> ?properties:string list -> set_error_type -> set_error
155
-
(** [set_error ?description ?properties type_] creates a SetError. *)
156
-
157
-
val set_error_jsont : set_error Jsont.t
158
-
(** JSON codec for SetError. *)
-123
lib/proto/proto_filter.ml
-123
lib/proto/proto_filter.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type operator = [ `And | `Or | `Not ]
7
-
8
-
let operator_to_string = function
9
-
| `And -> "AND"
10
-
| `Or -> "OR"
11
-
| `Not -> "NOT"
12
-
13
-
let operator_of_string = function
14
-
| "AND" -> `And
15
-
| "OR" -> `Or
16
-
| "NOT" -> `Not
17
-
| s -> Jsont.Error.msgf Jsont.Meta.none "Unknown filter operator: %s" s
18
-
19
-
let operator_jsont =
20
-
let kind = "Filter operator" in
21
-
Jsont.map ~kind
22
-
~dec:(fun s -> operator_of_string s)
23
-
~enc:operator_to_string
24
-
Jsont.string
25
-
26
-
type 'condition filter_operator = {
27
-
operator : operator;
28
-
conditions : 'condition filter list;
29
-
}
30
-
31
-
and 'condition filter =
32
-
| Operator of 'condition filter_operator
33
-
| Condition of 'condition
34
-
35
-
let filter_jsont (type c) (condition_jsont : c Jsont.t) : c filter Jsont.t =
36
-
let kind = "Filter" in
37
-
(* Create a recursive codec using Jsont.rec' *)
38
-
let rec make_filter_jsont () =
39
-
let lazy_self = lazy (make_filter_jsont ()) in
40
-
(* Filter operator codec *)
41
-
let filter_operator_jsont =
42
-
let make operator conditions = { operator; conditions } in
43
-
Jsont.Object.map ~kind:"FilterOperator" make
44
-
|> Jsont.Object.mem "operator" operator_jsont ~enc:(fun o -> o.operator)
45
-
|> Jsont.Object.mem "conditions"
46
-
(Jsont.list (Jsont.rec' lazy_self))
47
-
~enc:(fun o -> o.conditions)
48
-
|> Jsont.Object.finish
49
-
in
50
-
(* Decode function: check for "operator" field to determine type *)
51
-
let dec json =
52
-
match json with
53
-
| Jsont.Object (members, _) ->
54
-
(* members has type (name * json) list where name = string * Meta.t *)
55
-
if List.exists (fun ((k, _), _) -> k = "operator") members then begin
56
-
(* It's an operator *)
57
-
match Jsont.Json.decode' filter_operator_jsont json with
58
-
| Ok op -> Operator op
59
-
| Error e -> raise (Jsont.Error e)
60
-
end else begin
61
-
(* It's a condition *)
62
-
match Jsont.Json.decode' condition_jsont json with
63
-
| Ok c -> Condition c
64
-
| Error e -> raise (Jsont.Error e)
65
-
end
66
-
| Jsont.Null _ | Jsont.Bool _ | Jsont.Number _ | Jsont.String _ | Jsont.Array _ ->
67
-
Jsont.Error.msg Jsont.Meta.none "Filter must be an object"
68
-
in
69
-
(* Encode function *)
70
-
let enc = function
71
-
| Operator op ->
72
-
(match Jsont.Json.encode' filter_operator_jsont op with
73
-
| Ok j -> j
74
-
| Error e -> raise (Jsont.Error e))
75
-
| Condition c ->
76
-
(match Jsont.Json.encode' condition_jsont c with
77
-
| Ok j -> j
78
-
| Error e -> raise (Jsont.Error e))
79
-
in
80
-
Jsont.map ~kind ~dec ~enc Jsont.json
81
-
in
82
-
make_filter_jsont ()
83
-
84
-
type comparator = {
85
-
property : string;
86
-
is_ascending : bool;
87
-
collation : string option;
88
-
}
89
-
90
-
let comparator ?(is_ascending = true) ?collation property =
91
-
{ property; is_ascending; collation }
92
-
93
-
let comparator_property c = c.property
94
-
let comparator_is_ascending c = c.is_ascending
95
-
let comparator_collation c = c.collation
96
-
97
-
let comparator_make property is_ascending collation =
98
-
{ property; is_ascending; collation }
99
-
100
-
let comparator_jsont =
101
-
let kind = "Comparator" in
102
-
Jsont.Object.map ~kind comparator_make
103
-
|> Jsont.Object.mem "property" Jsont.string ~enc:comparator_property
104
-
|> Jsont.Object.mem "isAscending" Jsont.bool ~dec_absent:true ~enc:comparator_is_ascending
105
-
~enc_omit:(fun b -> b = true)
106
-
|> Jsont.Object.opt_mem "collation" Jsont.string ~enc:comparator_collation
107
-
|> Jsont.Object.finish
108
-
109
-
type added_item = {
110
-
id : Proto_id.t;
111
-
index : int64;
112
-
}
113
-
114
-
let added_item_make id index = { id; index }
115
-
let added_item_id a = a.id
116
-
let added_item_index a = a.index
117
-
118
-
let added_item_jsont =
119
-
let kind = "AddedItem" in
120
-
Jsont.Object.map ~kind added_item_make
121
-
|> Jsont.Object.mem "id" Proto_id.jsont ~enc:added_item_id
122
-
|> Jsont.Object.mem "index" Proto_int53.Unsigned.jsont ~enc:added_item_index
123
-
|> Jsont.Object.finish
-76
lib/proto/proto_filter.mli
-76
lib/proto/proto_filter.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP filter and sort types as defined in RFC 8620 Section 5.5
7
-
8
-
@canonical Jmap.Proto.Filter *)
9
-
10
-
(** {1 Filter Operators} *)
11
-
12
-
(** Filter operator types. *)
13
-
type operator = [
14
-
| `And (** All conditions must match *)
15
-
| `Or (** At least one condition must match *)
16
-
| `Not (** Inverts a single condition *)
17
-
]
18
-
19
-
val operator_jsont : operator Jsont.t
20
-
(** JSON codec for filter operators. *)
21
-
22
-
(** A filter operator that combines conditions.
23
-
24
-
When decoding, the filter determines whether a JSON object is an
25
-
operator (has "operator" field) or a condition. *)
26
-
type 'condition filter_operator = {
27
-
operator : operator;
28
-
conditions : 'condition filter list;
29
-
}
30
-
31
-
(** A filter is either an operator combining filters, or a leaf condition. *)
32
-
and 'condition filter =
33
-
| Operator of 'condition filter_operator
34
-
| Condition of 'condition
35
-
36
-
val filter_jsont : 'c Jsont.t -> 'c filter Jsont.t
37
-
(** [filter_jsont condition_jsont] creates a codec for filters with the
38
-
given condition type. The codec automatically distinguishes operators
39
-
from conditions by the presence of the "operator" field. *)
40
-
41
-
(** {1 Comparators} *)
42
-
43
-
(** A comparator for sorting query results. *)
44
-
type comparator = {
45
-
property : string;
46
-
(** The property to sort by. *)
47
-
is_ascending : bool;
48
-
(** [true] for ascending order (default), [false] for descending. *)
49
-
collation : string option;
50
-
(** Optional collation algorithm for string comparison. *)
51
-
}
52
-
53
-
val comparator :
54
-
?is_ascending:bool ->
55
-
?collation:string ->
56
-
string ->
57
-
comparator
58
-
(** [comparator ?is_ascending ?collation property] creates a comparator.
59
-
[is_ascending] defaults to [true]. *)
60
-
61
-
val comparator_property : comparator -> string
62
-
val comparator_is_ascending : comparator -> bool
63
-
val comparator_collation : comparator -> string option
64
-
65
-
val comparator_jsont : comparator Jsont.t
66
-
(** JSON codec for comparators. *)
67
-
68
-
(** {1 Position Information} *)
69
-
70
-
(** Added entry position in query change results. *)
71
-
type added_item = {
72
-
id : Proto_id.t;
73
-
index : int64;
74
-
}
75
-
76
-
val added_item_jsont : added_item Jsont.t
-51
lib/proto/proto_id.ml
-51
lib/proto/proto_id.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP identifier type as defined in RFC 8620 Section 1.2.
7
-
8
-
An Id is a string of 1-255 octets from the URL-safe base64 alphabet. *)
9
-
10
-
type t = string
11
-
12
-
(* Valid characters: A-Za-z0-9_- (URL-safe base64 alphabet) *)
13
-
let is_valid_char c =
14
-
(c >= 'A' && c <= 'Z') ||
15
-
(c >= 'a' && c <= 'z') ||
16
-
(c >= '0' && c <= '9') ||
17
-
c = '_' || c = '-'
18
-
19
-
let validate s =
20
-
let len = String.length s in
21
-
if len = 0 then Error "Id cannot be empty"
22
-
else if len > 255 then Error "Id cannot exceed 255 characters"
23
-
else
24
-
let rec check i =
25
-
if i >= len then Ok s
26
-
else if is_valid_char s.[i] then check (i + 1)
27
-
else Error (Printf.sprintf "Invalid character '%c' in Id at position %d" s.[i] i)
28
-
in
29
-
check 0
30
-
31
-
let of_string = validate
32
-
33
-
let of_string_exn s =
34
-
match validate s with
35
-
| Ok id -> id
36
-
| Error msg -> invalid_arg msg
37
-
38
-
let to_string t = t
39
-
let equal = String.equal
40
-
let compare = String.compare
41
-
let pp ppf t = Format.pp_print_string ppf t
42
-
43
-
let jsont =
44
-
let kind = "Id" in
45
-
let dec s =
46
-
match validate s with
47
-
| Ok id -> id
48
-
| Error msg -> Jsont.Error.msgf Jsont.Meta.none "%s: %s" kind msg
49
-
in
50
-
let enc t = t in
51
-
Jsont.map ~kind ~dec ~enc Jsont.string
-40
lib/proto/proto_id.mli
-40
lib/proto/proto_id.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP identifier type.
7
-
8
-
An Id is a string of 1-255 octets from the URL-safe base64 alphabet
9
-
(A-Za-z0-9_-), plus the ASCII alphanumeric characters.
10
-
11
-
See {{:https://datatracker.ietf.org/doc/html/rfc8620#section-1.2} RFC 8620 Section 1.2}.
12
-
13
-
@canonical Jmap.Proto.Id *)
14
-
15
-
type t
16
-
(** The type of JMAP identifiers. *)
17
-
18
-
val of_string : string -> (t, string) result
19
-
(** [of_string s] creates an Id from string [s].
20
-
Returns [Error msg] if [s] is empty, longer than 255 characters,
21
-
or contains invalid characters. *)
22
-
23
-
val of_string_exn : string -> t
24
-
(** [of_string_exn s] creates an Id from string [s].
25
-
@raise Invalid_argument if the string is invalid. *)
26
-
27
-
val to_string : t -> string
28
-
(** [to_string id] returns the string representation of [id]. *)
29
-
30
-
val equal : t -> t -> bool
31
-
(** [equal a b] tests equality of identifiers. *)
32
-
33
-
val compare : t -> t -> int
34
-
(** [compare a b] compares two identifiers. *)
35
-
36
-
val pp : Format.formatter -> t -> unit
37
-
(** [pp ppf id] pretty-prints [id] to [ppf]. *)
38
-
39
-
val jsont : t Jsont.t
40
-
(** JSON codec for JMAP identifiers. *)
-67
lib/proto/proto_int53.ml
-67
lib/proto/proto_int53.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JavaScript-safe integer types for JSON.
7
-
8
-
These types represent integers that can be safely represented in JavaScript's
9
-
IEEE 754 double-precision floating point format without loss of precision. *)
10
-
11
-
(** 53-bit signed integer with range -2^53+1 to 2^53-1 *)
12
-
module Signed = struct
13
-
type t = int64
14
-
15
-
(* 2^53 - 1 *)
16
-
let max_value = 9007199254740991L
17
-
(* -(2^53 - 1) *)
18
-
let min_value = -9007199254740991L
19
-
20
-
let of_int n = Int64.of_int n
21
-
22
-
let to_int n =
23
-
if n >= Int64.of_int min_int && n <= Int64.of_int max_int then
24
-
Some (Int64.to_int n)
25
-
else
26
-
None
27
-
28
-
let of_int64 n =
29
-
if n >= min_value && n <= max_value then Ok n
30
-
else Error (Printf.sprintf "Int53 out of range: %Ld" n)
31
-
32
-
let jsont =
33
-
let kind = "Int53" in
34
-
let dec f =
35
-
let n = Int64.of_float f in
36
-
if n >= min_value && n <= max_value then n
37
-
else Jsont.Error.msgf Jsont.Meta.none "%s: value %Ld out of safe integer range" kind n
38
-
in
39
-
let enc n = Int64.to_float n in
40
-
Jsont.map ~kind ~dec ~enc Jsont.number
41
-
end
42
-
43
-
(** 53-bit unsigned integer with range 0 to 2^53-1 *)
44
-
module Unsigned = struct
45
-
type t = int64
46
-
47
-
let min_value = 0L
48
-
let max_value = 9007199254740991L
49
-
50
-
let of_int n =
51
-
if n >= 0 then Ok (Int64.of_int n)
52
-
else Error "UnsignedInt53 cannot be negative"
53
-
54
-
let of_int64 n =
55
-
if n >= min_value && n <= max_value then Ok n
56
-
else Error (Printf.sprintf "UnsignedInt53 out of range: %Ld" n)
57
-
58
-
let jsont =
59
-
let kind = "UnsignedInt53" in
60
-
let dec f =
61
-
let n = Int64.of_float f in
62
-
if n >= min_value && n <= max_value then n
63
-
else Jsont.Error.msgf Jsont.Meta.none "%s: value %Ld out of range [0, 2^53-1]" kind n
64
-
in
65
-
let enc n = Int64.to_float n in
66
-
Jsont.map ~kind ~dec ~enc Jsont.number
67
-
end
-64
lib/proto/proto_int53.mli
-64
lib/proto/proto_int53.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JavaScript-safe integer types for JSON.
7
-
8
-
These types represent integers that can be safely represented in JavaScript's
9
-
IEEE 754 double-precision floating point format without loss of precision.
10
-
The safe range is -2^53+1 to 2^53-1.
11
-
12
-
See {{:https://datatracker.ietf.org/doc/html/rfc8620#section-1.3} RFC 8620 Section 1.3}.
13
-
14
-
@canonical Jmap.Proto.Int53 *)
15
-
16
-
(** 53-bit signed integer.
17
-
18
-
The range is -2^53+1 to 2^53-1, which is the safe integer range
19
-
for JavaScript/JSON numbers. *)
20
-
module Signed : sig
21
-
type t = int64
22
-
(** The type of 53-bit signed integers. *)
23
-
24
-
val min_value : t
25
-
(** Minimum value: -9007199254740991 (-2^53+1) *)
26
-
27
-
val max_value : t
28
-
(** Maximum value: 9007199254740991 (2^53-1) *)
29
-
30
-
val of_int : int -> t
31
-
(** [of_int n] converts an OCaml int to Int53. *)
32
-
33
-
val to_int : t -> int option
34
-
(** [to_int n] converts to OCaml int if it fits. *)
35
-
36
-
val of_int64 : int64 -> (t, string) result
37
-
(** [of_int64 n] validates that [n] is in the safe range. *)
38
-
39
-
val jsont : t Jsont.t
40
-
(** JSON codec for 53-bit integers. Encoded as JSON number. *)
41
-
end
42
-
43
-
(** 53-bit unsigned integer.
44
-
45
-
The range is 0 to 2^53-1. *)
46
-
module Unsigned : sig
47
-
type t = int64
48
-
(** The type of 53-bit unsigned integers. *)
49
-
50
-
val min_value : t
51
-
(** Minimum value: 0 *)
52
-
53
-
val max_value : t
54
-
(** Maximum value: 9007199254740991 (2^53-1) *)
55
-
56
-
val of_int : int -> (t, string) result
57
-
(** [of_int n] converts an OCaml int to UnsignedInt53. *)
58
-
59
-
val of_int64 : int64 -> (t, string) result
60
-
(** [of_int64 n] validates that [n] is in the valid range. *)
61
-
62
-
val jsont : t Jsont.t
63
-
(** JSON codec for 53-bit unsigned integers. *)
64
-
end
-113
lib/proto/proto_invocation.ml
-113
lib/proto/proto_invocation.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type result_reference = {
7
-
result_of : string;
8
-
name : string;
9
-
path : Json_pointer.Jmap.t;
10
-
}
11
-
12
-
let result_reference ~result_of ~name ~path =
13
-
{ result_of; name; path }
14
-
15
-
let result_reference_of_strings ~result_of ~name ~path =
16
-
{ result_of; name; path = Json_pointer.Jmap.of_string path }
17
-
18
-
let result_reference_make result_of name path =
19
-
{ result_of; name; path }
20
-
21
-
let result_reference_jsont =
22
-
let kind = "ResultReference" in
23
-
Jsont.Object.map ~kind result_reference_make
24
-
|> Jsont.Object.mem "resultOf" Jsont.string ~enc:(fun r -> r.result_of)
25
-
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun r -> r.name)
26
-
|> Jsont.Object.mem "path" Json_pointer.Jmap.jsont ~enc:(fun r -> r.path)
27
-
|> Jsont.Object.finish
28
-
29
-
(* Result reference resolution *)
30
-
31
-
let find_response ref ~responses =
32
-
List.find_map (fun (call_id, name, json) ->
33
-
if call_id = ref.result_of && name = ref.name
34
-
then Some json
35
-
else None
36
-
) responses
37
-
38
-
let resolve ref ~responses codec =
39
-
match find_response ref ~responses with
40
-
| None ->
41
-
Jsont.Error.msgf Jsont.Meta.none
42
-
"Result reference: no response found for resultOf=%s name=%s"
43
-
ref.result_of ref.name
44
-
| Some json ->
45
-
let extraction_codec = Json_pointer.Jmap.path ref.path codec in
46
-
match Jsont.Json.decode' extraction_codec json with
47
-
| Ok v -> v
48
-
| Error e -> raise (Jsont.Error e)
49
-
50
-
let resolve_ids ref ~responses =
51
-
resolve ref ~responses (Jsont.list Jsont.string)
52
-
53
-
type t = {
54
-
name : string;
55
-
arguments : Jsont.json;
56
-
method_call_id : string;
57
-
}
58
-
59
-
let create ~name ~arguments ~method_call_id =
60
-
{ name; arguments; method_call_id }
61
-
62
-
let name t = t.name
63
-
let arguments t = t.arguments
64
-
let method_call_id t = t.method_call_id
65
-
66
-
(* Helper to encode a typed value back to Jsont.json *)
67
-
let encode_json_value jsont value =
68
-
match Jsont.Json.encode' jsont value with
69
-
| Ok json -> json
70
-
| Error _ -> Jsont.Object ([], Jsont.Meta.none)
71
-
72
-
let jsont =
73
-
let kind = "Invocation" in
74
-
(* Invocation is [name, args, callId] - a 3-element heterogeneous array *)
75
-
(* We need to handle this as a json array since elements have different types *)
76
-
let dec json =
77
-
match json with
78
-
| Jsont.Array ([name_json; arguments; call_id_json], _) ->
79
-
let name = match name_json with
80
-
| Jsont.String (s, _) -> s
81
-
| _ -> Jsont.Error.msg Jsont.Meta.none "Invocation[0] must be a string"
82
-
in
83
-
let method_call_id = match call_id_json with
84
-
| Jsont.String (s, _) -> s
85
-
| _ -> Jsont.Error.msg Jsont.Meta.none "Invocation[2] must be a string"
86
-
in
87
-
{ name; arguments; method_call_id }
88
-
| Jsont.Array _ ->
89
-
Jsont.Error.msg Jsont.Meta.none "Invocation must be a 3-element array"
90
-
| _ ->
91
-
Jsont.Error.msg Jsont.Meta.none "Invocation must be an array"
92
-
in
93
-
let enc t =
94
-
Jsont.Array ([
95
-
Jsont.String (t.name, Jsont.Meta.none);
96
-
t.arguments;
97
-
Jsont.String (t.method_call_id, Jsont.Meta.none);
98
-
], Jsont.Meta.none)
99
-
in
100
-
Jsont.map ~kind ~dec ~enc Jsont.json
101
-
102
-
let make_get ~method_call_id ~method_name args =
103
-
let arguments = encode_json_value Proto_method.get_args_jsont args in
104
-
{ name = method_name; arguments; method_call_id }
105
-
106
-
let make_changes ~method_call_id ~method_name args =
107
-
let arguments = encode_json_value Proto_method.changes_args_jsont args in
108
-
{ name = method_name; arguments; method_call_id }
109
-
110
-
let make_query (type f) ~method_call_id ~method_name
111
-
~(filter_cond_jsont : f Jsont.t) (args : f Proto_method.query_args) =
112
-
let arguments = encode_json_value (Proto_method.query_args_jsont filter_cond_jsont) args in
113
-
{ name = method_name; arguments; method_call_id }
-125
lib/proto/proto_invocation.mli
-125
lib/proto/proto_invocation.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP method invocation as defined in RFC 8620 Section 3.2
7
-
8
-
@canonical Jmap.Proto.Invocation *)
9
-
10
-
(** {1 Result References} *)
11
-
12
-
(** A reference to a result from a previous method call.
13
-
14
-
Used for back-referencing values within a single request.
15
-
The path is a JMAP extended JSON Pointer (RFC 8620 Section 3.7)
16
-
which may contain [*] wildcards for array mapping. *)
17
-
type result_reference = {
18
-
result_of : string;
19
-
(** The method call id to reference. *)
20
-
name : string;
21
-
(** The method name that was called. *)
22
-
path : Json_pointer.Jmap.t;
23
-
(** A JMAP extended JSON Pointer to the value within the result.
24
-
May contain [*] wildcards for mapping through arrays. *)
25
-
}
26
-
27
-
val result_reference :
28
-
result_of:string ->
29
-
name:string ->
30
-
path:Json_pointer.Jmap.t ->
31
-
result_reference
32
-
33
-
val result_reference_of_strings :
34
-
result_of:string ->
35
-
name:string ->
36
-
path:string ->
37
-
result_reference
38
-
(** [result_reference_of_strings] creates a result reference, parsing
39
-
the path string into a JMAP pointer.
40
-
@raise Jsont.Error if the path is not a valid JMAP pointer. *)
41
-
42
-
val result_reference_jsont : result_reference Jsont.t
43
-
44
-
(** {2 Typed Extraction}
45
-
46
-
These functions extract typed values from method responses using
47
-
the result reference's path. *)
48
-
49
-
val resolve_ids :
50
-
result_reference ->
51
-
responses:(string * string * Jsont.json) list ->
52
-
string list
53
-
(** [resolve_ids ref ~responses] resolves the result reference against
54
-
the list of previous responses and extracts a list of string IDs.
55
-
56
-
[responses] is a list of [(method_call_id, method_name, result_json)]
57
-
tuples from previously executed method calls.
58
-
59
-
This is the most common pattern in JMAP where result references are
60
-
used to pass IDs between method calls.
61
-
62
-
@raise Jsont.Error if resolution fails or the result is not a string list. *)
63
-
64
-
val resolve :
65
-
result_reference ->
66
-
responses:(string * string * Jsont.json) list ->
67
-
'a Jsont.t ->
68
-
'a
69
-
(** [resolve ref ~responses codec] resolves the result reference and
70
-
decodes the extracted value with [codec].
71
-
72
-
@raise Jsont.Error if resolution fails or decoding fails. *)
73
-
74
-
(** {1 Invocations} *)
75
-
76
-
(** A method invocation.
77
-
78
-
In JSON, this is represented as a 3-element array:
79
-
["methodName", {args}, "methodCallId"] *)
80
-
type t = {
81
-
name : string;
82
-
(** The method name, e.g., "Email/get". *)
83
-
arguments : Jsont.json;
84
-
(** The method arguments as a JSON object. *)
85
-
method_call_id : string;
86
-
(** Client-specified identifier for this call. *)
87
-
}
88
-
89
-
val create :
90
-
name:string ->
91
-
arguments:Jsont.json ->
92
-
method_call_id:string ->
93
-
t
94
-
(** [create ~name ~arguments ~method_call_id] creates an invocation. *)
95
-
96
-
val name : t -> string
97
-
val arguments : t -> Jsont.json
98
-
val method_call_id : t -> string
99
-
100
-
val jsont : t Jsont.t
101
-
(** JSON codec for invocations (as 3-element array). *)
102
-
103
-
(** {1 Typed Invocation Helpers} *)
104
-
105
-
val make_get :
106
-
method_call_id:string ->
107
-
method_name:string ->
108
-
Proto_method.get_args ->
109
-
t
110
-
(** [make_get ~method_call_id ~method_name args] creates a /get invocation. *)
111
-
112
-
val make_changes :
113
-
method_call_id:string ->
114
-
method_name:string ->
115
-
Proto_method.changes_args ->
116
-
t
117
-
(** [make_changes ~method_call_id ~method_name args] creates a /changes invocation. *)
118
-
119
-
val make_query :
120
-
method_call_id:string ->
121
-
method_name:string ->
122
-
filter_cond_jsont:'f Jsont.t ->
123
-
'f Proto_method.query_args ->
124
-
t
125
-
(** [make_query ~method_call_id ~method_name ~filter_cond_jsont args] creates a /query invocation. *)
-40
lib/proto/proto_json_map.ml
-40
lib/proto/proto_json_map.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JSON object-as-map codec utilities.
7
-
8
-
JMAP frequently uses JSON objects as maps with string or Id keys.
9
-
These codecs convert between JSON objects and OCaml association lists. *)
10
-
11
-
module String_map = Map.Make(String)
12
-
13
-
let of_string value_jsont =
14
-
let kind = "String map" in
15
-
Jsont.Object.map ~kind Fun.id
16
-
|> Jsont.Object.keep_unknown (Jsont.Object.Mems.string_map value_jsont) ~enc:Fun.id
17
-
|> Jsont.Object.finish
18
-
|> Jsont.map
19
-
~dec:(fun m -> List.of_seq (String_map.to_seq m))
20
-
~enc:(fun l -> String_map.of_list l)
21
-
22
-
let of_id value_jsont =
23
-
let kind = "Id map" in
24
-
(* Use string map internally, then convert keys to Ids *)
25
-
let string_codec = of_string value_jsont in
26
-
let dec pairs =
27
-
List.map (fun (k, v) ->
28
-
match Proto_id.of_string k with
29
-
| Ok id -> (id, v)
30
-
| Error msg -> Jsont.Error.msgf Jsont.Meta.none "%s: invalid key %s - %s" kind k msg
31
-
) pairs
32
-
in
33
-
let enc pairs =
34
-
List.map (fun (id, v) -> (Proto_id.to_string id, v)) pairs
35
-
in
36
-
Jsont.map ~kind ~dec ~enc string_codec
37
-
38
-
let id_to_bool = of_id Jsont.bool
39
-
40
-
let string_to_bool = of_string Jsont.bool
-25
lib/proto/proto_json_map.mli
-25
lib/proto/proto_json_map.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JSON object-as-map codec utilities.
7
-
8
-
JMAP frequently uses JSON objects as maps with string or Id keys.
9
-
These codecs convert between JSON objects and OCaml association lists.
10
-
11
-
@canonical Jmap.Proto.Json_map *)
12
-
13
-
val of_string : 'a Jsont.t -> (string * 'a) list Jsont.t
14
-
(** [of_string value_jsont] creates a codec for JSON objects
15
-
used as string-keyed maps. Returns an association list. *)
16
-
17
-
val of_id : 'a Jsont.t -> (Proto_id.t * 'a) list Jsont.t
18
-
(** [of_id value_jsont] creates a codec for JSON objects
19
-
keyed by JMAP identifiers. *)
20
-
21
-
val id_to_bool : (Proto_id.t * bool) list Jsont.t
22
-
(** Codec for Id[Boolean] maps, common in JMAP (e.g., mailboxIds, keywords). *)
23
-
24
-
val string_to_bool : (string * bool) list Jsont.t
25
-
(** Codec for String[Boolean] maps. *)
-327
lib/proto/proto_method.ml
-327
lib/proto/proto_method.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(* Foo/get *)
7
-
8
-
type get_args = {
9
-
account_id : Proto_id.t;
10
-
ids : Proto_id.t list option;
11
-
properties : string list option;
12
-
}
13
-
14
-
let get_args ~account_id ?ids ?properties () =
15
-
{ account_id; ids; properties }
16
-
17
-
let get_args_make account_id ids properties =
18
-
{ account_id; ids; properties }
19
-
20
-
let get_args_jsont =
21
-
let kind = "GetArgs" in
22
-
Jsont.Object.map ~kind get_args_make
23
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
24
-
|> Jsont.Object.opt_mem "ids" (Jsont.list Proto_id.jsont) ~enc:(fun a -> a.ids)
25
-
|> Jsont.Object.opt_mem "properties" (Jsont.list Jsont.string) ~enc:(fun a -> a.properties)
26
-
|> Jsont.Object.finish
27
-
28
-
type 'a get_response = {
29
-
account_id : Proto_id.t;
30
-
state : string;
31
-
list : 'a list;
32
-
not_found : Proto_id.t list;
33
-
}
34
-
35
-
let get_response_jsont (type a) (obj_jsont : a Jsont.t) : a get_response Jsont.t =
36
-
let kind = "GetResponse" in
37
-
let make account_id state list not_found =
38
-
{ account_id; state; list; not_found }
39
-
in
40
-
Jsont.Object.map ~kind make
41
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id)
42
-
|> Jsont.Object.mem "state" Jsont.string ~enc:(fun r -> r.state)
43
-
|> Jsont.Object.mem "list" (Jsont.list obj_jsont) ~enc:(fun r -> r.list)
44
-
|> Jsont.Object.mem "notFound" (Jsont.list Proto_id.jsont) ~enc:(fun r -> r.not_found)
45
-
|> Jsont.Object.finish
46
-
47
-
(* Foo/changes *)
48
-
49
-
type changes_args = {
50
-
account_id : Proto_id.t;
51
-
since_state : string;
52
-
max_changes : int64 option;
53
-
}
54
-
55
-
let changes_args ~account_id ~since_state ?max_changes () =
56
-
{ account_id; since_state; max_changes }
57
-
58
-
let changes_args_make account_id since_state max_changes =
59
-
{ account_id; since_state; max_changes }
60
-
61
-
let changes_args_jsont =
62
-
let kind = "ChangesArgs" in
63
-
Jsont.Object.map ~kind changes_args_make
64
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
65
-
|> Jsont.Object.mem "sinceState" Jsont.string ~enc:(fun a -> a.since_state)
66
-
|> Jsont.Object.opt_mem "maxChanges" Proto_int53.Unsigned.jsont ~enc:(fun a -> a.max_changes)
67
-
|> Jsont.Object.finish
68
-
69
-
type changes_response = {
70
-
account_id : Proto_id.t;
71
-
old_state : string;
72
-
new_state : string;
73
-
has_more_changes : bool;
74
-
created : Proto_id.t list;
75
-
updated : Proto_id.t list;
76
-
destroyed : Proto_id.t list;
77
-
}
78
-
79
-
let changes_response_make account_id old_state new_state has_more_changes
80
-
created updated destroyed =
81
-
{ account_id; old_state; new_state; has_more_changes; created; updated; destroyed }
82
-
83
-
let changes_response_jsont =
84
-
let kind = "ChangesResponse" in
85
-
Jsont.Object.map ~kind changes_response_make
86
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id)
87
-
|> Jsont.Object.mem "oldState" Jsont.string ~enc:(fun r -> r.old_state)
88
-
|> Jsont.Object.mem "newState" Jsont.string ~enc:(fun r -> r.new_state)
89
-
|> Jsont.Object.mem "hasMoreChanges" Jsont.bool ~enc:(fun r -> r.has_more_changes)
90
-
|> Jsont.Object.mem "created" (Jsont.list Proto_id.jsont) ~enc:(fun r -> r.created)
91
-
|> Jsont.Object.mem "updated" (Jsont.list Proto_id.jsont) ~enc:(fun r -> r.updated)
92
-
|> Jsont.Object.mem "destroyed" (Jsont.list Proto_id.jsont) ~enc:(fun r -> r.destroyed)
93
-
|> Jsont.Object.finish
94
-
95
-
(* Foo/set *)
96
-
97
-
type 'a set_args = {
98
-
account_id : Proto_id.t;
99
-
if_in_state : string option;
100
-
create : (Proto_id.t * 'a) list option;
101
-
update : (Proto_id.t * Jsont.json) list option;
102
-
destroy : Proto_id.t list option;
103
-
}
104
-
105
-
let set_args ~account_id ?if_in_state ?create ?update ?destroy () =
106
-
{ account_id; if_in_state; create; update; destroy }
107
-
108
-
let set_args_jsont (type a) (obj_jsont : a Jsont.t) : a set_args Jsont.t =
109
-
let kind = "SetArgs" in
110
-
let make account_id if_in_state create update destroy =
111
-
{ account_id; if_in_state; create; update; destroy }
112
-
in
113
-
Jsont.Object.map ~kind make
114
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
115
-
|> Jsont.Object.opt_mem "ifInState" Jsont.string ~enc:(fun a -> a.if_in_state)
116
-
|> Jsont.Object.opt_mem "create" (Proto_json_map.of_id obj_jsont) ~enc:(fun a -> a.create)
117
-
|> Jsont.Object.opt_mem "update" (Proto_json_map.of_id Jsont.json) ~enc:(fun a -> a.update)
118
-
|> Jsont.Object.opt_mem "destroy" (Jsont.list Proto_id.jsont) ~enc:(fun a -> a.destroy)
119
-
|> Jsont.Object.finish
120
-
121
-
type 'a set_response = {
122
-
account_id : Proto_id.t;
123
-
old_state : string option;
124
-
new_state : string;
125
-
created : (Proto_id.t * 'a) list option;
126
-
updated : (Proto_id.t * 'a option) list option;
127
-
destroyed : Proto_id.t list option;
128
-
not_created : (Proto_id.t * Proto_error.set_error) list option;
129
-
not_updated : (Proto_id.t * Proto_error.set_error) list option;
130
-
not_destroyed : (Proto_id.t * Proto_error.set_error) list option;
131
-
}
132
-
133
-
let set_response_jsont (type a) (obj_jsont : a Jsont.t) : a set_response Jsont.t =
134
-
let kind = "SetResponse" in
135
-
(* All map/list fields in SetResponse can be null per RFC 8620 Section 5.3 *)
136
-
(* opt_mem handles missing keys, Jsont.option handles explicit null values *)
137
-
(* Option.join flattens option option -> option *)
138
-
let join = Option.join in
139
-
let make account_id old_state new_state created updated destroyed
140
-
not_created not_updated not_destroyed =
141
-
{ account_id; old_state; new_state;
142
-
created = join created;
143
-
updated = join updated;
144
-
destroyed = join destroyed;
145
-
not_created = join not_created;
146
-
not_updated = join not_updated;
147
-
not_destroyed = join not_destroyed }
148
-
in
149
-
(* For updated values, the server may return null or an object - RFC 8620 Section 5.3 *)
150
-
(* "Id[Foo|null]" means map values can be null, use Jsont.option to handle this *)
151
-
let nullable_obj = Jsont.(option obj_jsont) in
152
-
let opt enc = Option.map Option.some enc in
153
-
Jsont.Object.map ~kind make
154
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id)
155
-
|> Jsont.Object.opt_mem "oldState" Jsont.string ~enc:(fun r -> r.old_state)
156
-
|> Jsont.Object.mem "newState" Jsont.string ~enc:(fun r -> r.new_state)
157
-
|> Jsont.Object.opt_mem "created" Jsont.(option (Proto_json_map.of_id obj_jsont)) ~enc:(fun r -> opt r.created)
158
-
|> Jsont.Object.opt_mem "updated" Jsont.(option (Proto_json_map.of_id nullable_obj)) ~enc:(fun r -> opt r.updated)
159
-
|> Jsont.Object.opt_mem "destroyed" Jsont.(option (list Proto_id.jsont)) ~enc:(fun r -> opt r.destroyed)
160
-
|> Jsont.Object.opt_mem "notCreated" Jsont.(option (Proto_json_map.of_id Proto_error.set_error_jsont)) ~enc:(fun r -> opt r.not_created)
161
-
|> Jsont.Object.opt_mem "notUpdated" Jsont.(option (Proto_json_map.of_id Proto_error.set_error_jsont)) ~enc:(fun r -> opt r.not_updated)
162
-
|> Jsont.Object.opt_mem "notDestroyed" Jsont.(option (Proto_json_map.of_id Proto_error.set_error_jsont)) ~enc:(fun r -> opt r.not_destroyed)
163
-
|> Jsont.Object.finish
164
-
165
-
(* Foo/copy *)
166
-
167
-
type 'a copy_args = {
168
-
from_account_id : Proto_id.t;
169
-
if_from_in_state : string option;
170
-
account_id : Proto_id.t;
171
-
if_in_state : string option;
172
-
create : (Proto_id.t * 'a) list;
173
-
on_success_destroy_original : bool;
174
-
destroy_from_if_in_state : string option;
175
-
}
176
-
177
-
let copy_args_jsont (type a) (obj_jsont : a Jsont.t) : a copy_args Jsont.t =
178
-
let kind = "CopyArgs" in
179
-
let make from_account_id if_from_in_state account_id if_in_state create
180
-
on_success_destroy_original destroy_from_if_in_state =
181
-
{ from_account_id; if_from_in_state; account_id; if_in_state; create;
182
-
on_success_destroy_original; destroy_from_if_in_state }
183
-
in
184
-
Jsont.Object.map ~kind make
185
-
|> Jsont.Object.mem "fromAccountId" Proto_id.jsont ~enc:(fun a -> a.from_account_id)
186
-
|> Jsont.Object.opt_mem "ifFromInState" Jsont.string ~enc:(fun a -> a.if_from_in_state)
187
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
188
-
|> Jsont.Object.opt_mem "ifInState" Jsont.string ~enc:(fun a -> a.if_in_state)
189
-
|> Jsont.Object.mem "create" (Proto_json_map.of_id obj_jsont) ~enc:(fun a -> a.create)
190
-
|> Jsont.Object.mem "onSuccessDestroyOriginal" Jsont.bool ~dec_absent:false
191
-
~enc:(fun a -> a.on_success_destroy_original)
192
-
~enc_omit:(fun b -> not b)
193
-
|> Jsont.Object.opt_mem "destroyFromIfInState" Jsont.string ~enc:(fun a -> a.destroy_from_if_in_state)
194
-
|> Jsont.Object.finish
195
-
196
-
type 'a copy_response = {
197
-
from_account_id : Proto_id.t;
198
-
account_id : Proto_id.t;
199
-
old_state : string option;
200
-
new_state : string;
201
-
created : (Proto_id.t * 'a) list option;
202
-
not_created : (Proto_id.t * Proto_error.set_error) list option;
203
-
}
204
-
205
-
let copy_response_jsont (type a) (obj_jsont : a Jsont.t) : a copy_response Jsont.t =
206
-
let kind = "CopyResponse" in
207
-
let make from_account_id account_id old_state new_state created not_created =
208
-
{ from_account_id; account_id; old_state; new_state; created; not_created }
209
-
in
210
-
Jsont.Object.map ~kind make
211
-
|> Jsont.Object.mem "fromAccountId" Proto_id.jsont ~enc:(fun r -> r.from_account_id)
212
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id)
213
-
|> Jsont.Object.opt_mem "oldState" Jsont.string ~enc:(fun r -> r.old_state)
214
-
|> Jsont.Object.mem "newState" Jsont.string ~enc:(fun r -> r.new_state)
215
-
|> Jsont.Object.opt_mem "created" (Proto_json_map.of_id obj_jsont) ~enc:(fun r -> r.created)
216
-
|> Jsont.Object.opt_mem "notCreated" (Proto_json_map.of_id Proto_error.set_error_jsont) ~enc:(fun r -> r.not_created)
217
-
|> Jsont.Object.finish
218
-
219
-
(* Foo/query *)
220
-
221
-
type 'filter query_args = {
222
-
account_id : Proto_id.t;
223
-
filter : 'filter Proto_filter.filter option;
224
-
sort : Proto_filter.comparator list option;
225
-
position : int64;
226
-
anchor : Proto_id.t option;
227
-
anchor_offset : int64;
228
-
limit : int64 option;
229
-
calculate_total : bool;
230
-
}
231
-
232
-
let query_args ~account_id ?filter ?sort ?(position = 0L) ?anchor
233
-
?(anchor_offset = 0L) ?limit ?(calculate_total = false) () =
234
-
{ account_id; filter; sort; position; anchor; anchor_offset; limit; calculate_total }
235
-
236
-
let query_args_jsont (type f) (filter_cond_jsont : f Jsont.t) : f query_args Jsont.t =
237
-
let kind = "QueryArgs" in
238
-
let make account_id filter sort position anchor anchor_offset limit calculate_total =
239
-
{ account_id; filter; sort; position; anchor; anchor_offset; limit; calculate_total }
240
-
in
241
-
Jsont.Object.map ~kind make
242
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
243
-
|> Jsont.Object.opt_mem "filter" (Proto_filter.filter_jsont filter_cond_jsont) ~enc:(fun a -> a.filter)
244
-
|> Jsont.Object.opt_mem "sort" (Jsont.list Proto_filter.comparator_jsont) ~enc:(fun a -> a.sort)
245
-
|> Jsont.Object.mem "position" Proto_int53.Signed.jsont ~dec_absent:0L ~enc:(fun a -> a.position)
246
-
~enc_omit:(fun p -> p = 0L)
247
-
|> Jsont.Object.opt_mem "anchor" Proto_id.jsont ~enc:(fun a -> a.anchor)
248
-
|> Jsont.Object.mem "anchorOffset" Proto_int53.Signed.jsont ~dec_absent:0L ~enc:(fun a -> a.anchor_offset)
249
-
~enc_omit:(fun o -> o = 0L)
250
-
|> Jsont.Object.opt_mem "limit" Proto_int53.Unsigned.jsont ~enc:(fun a -> a.limit)
251
-
|> Jsont.Object.mem "calculateTotal" Jsont.bool ~dec_absent:false ~enc:(fun a -> a.calculate_total)
252
-
~enc_omit:(fun b -> not b)
253
-
|> Jsont.Object.finish
254
-
255
-
type query_response = {
256
-
account_id : Proto_id.t;
257
-
query_state : string;
258
-
can_calculate_changes : bool;
259
-
position : int64;
260
-
ids : Proto_id.t list;
261
-
total : int64 option;
262
-
}
263
-
264
-
let query_response_make account_id query_state can_calculate_changes position ids total =
265
-
{ account_id; query_state; can_calculate_changes; position; ids; total }
266
-
267
-
let query_response_jsont =
268
-
let kind = "QueryResponse" in
269
-
Jsont.Object.map ~kind query_response_make
270
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id)
271
-
|> Jsont.Object.mem "queryState" Jsont.string ~enc:(fun r -> r.query_state)
272
-
|> Jsont.Object.mem "canCalculateChanges" Jsont.bool ~enc:(fun r -> r.can_calculate_changes)
273
-
|> Jsont.Object.mem "position" Proto_int53.Unsigned.jsont ~enc:(fun r -> r.position)
274
-
|> Jsont.Object.mem "ids" (Jsont.list Proto_id.jsont) ~enc:(fun r -> r.ids)
275
-
|> Jsont.Object.opt_mem "total" Proto_int53.Unsigned.jsont ~enc:(fun r -> r.total)
276
-
|> Jsont.Object.finish
277
-
278
-
(* Foo/queryChanges *)
279
-
280
-
type 'filter query_changes_args = {
281
-
account_id : Proto_id.t;
282
-
filter : 'filter Proto_filter.filter option;
283
-
sort : Proto_filter.comparator list option;
284
-
since_query_state : string;
285
-
max_changes : int64 option;
286
-
up_to_id : Proto_id.t option;
287
-
calculate_total : bool;
288
-
}
289
-
290
-
let query_changes_args_jsont (type f) (filter_cond_jsont : f Jsont.t) : f query_changes_args Jsont.t =
291
-
let kind = "QueryChangesArgs" in
292
-
let make account_id filter sort since_query_state max_changes up_to_id calculate_total =
293
-
{ account_id; filter; sort; since_query_state; max_changes; up_to_id; calculate_total }
294
-
in
295
-
Jsont.Object.map ~kind make
296
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
297
-
|> Jsont.Object.opt_mem "filter" (Proto_filter.filter_jsont filter_cond_jsont) ~enc:(fun a -> a.filter)
298
-
|> Jsont.Object.opt_mem "sort" (Jsont.list Proto_filter.comparator_jsont) ~enc:(fun a -> a.sort)
299
-
|> Jsont.Object.mem "sinceQueryState" Jsont.string ~enc:(fun a -> a.since_query_state)
300
-
|> Jsont.Object.opt_mem "maxChanges" Proto_int53.Unsigned.jsont ~enc:(fun a -> a.max_changes)
301
-
|> Jsont.Object.opt_mem "upToId" Proto_id.jsont ~enc:(fun a -> a.up_to_id)
302
-
|> Jsont.Object.mem "calculateTotal" Jsont.bool ~dec_absent:false ~enc:(fun a -> a.calculate_total)
303
-
~enc_omit:(fun b -> not b)
304
-
|> Jsont.Object.finish
305
-
306
-
type query_changes_response = {
307
-
account_id : Proto_id.t;
308
-
old_query_state : string;
309
-
new_query_state : string;
310
-
total : int64 option;
311
-
removed : Proto_id.t list;
312
-
added : Proto_filter.added_item list;
313
-
}
314
-
315
-
let query_changes_response_make account_id old_query_state new_query_state total removed added =
316
-
{ account_id; old_query_state; new_query_state; total; removed; added }
317
-
318
-
let query_changes_response_jsont =
319
-
let kind = "QueryChangesResponse" in
320
-
Jsont.Object.map ~kind query_changes_response_make
321
-
|> Jsont.Object.mem "accountId" Proto_id.jsont ~enc:(fun r -> r.account_id)
322
-
|> Jsont.Object.mem "oldQueryState" Jsont.string ~enc:(fun r -> r.old_query_state)
323
-
|> Jsont.Object.mem "newQueryState" Jsont.string ~enc:(fun r -> r.new_query_state)
324
-
|> Jsont.Object.opt_mem "total" Proto_int53.Unsigned.jsont ~enc:(fun r -> r.total)
325
-
|> Jsont.Object.mem "removed" (Jsont.list Proto_id.jsont) ~enc:(fun r -> r.removed)
326
-
|> Jsont.Object.mem "added" (Jsont.list Proto_filter.added_item_jsont) ~enc:(fun r -> r.added)
327
-
|> Jsont.Object.finish
-217
lib/proto/proto_method.mli
-217
lib/proto/proto_method.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP standard method types as defined in RFC 8620 Section 5
7
-
8
-
@canonical Jmap.Proto.Method *)
9
-
10
-
(** {1 Foo/get} *)
11
-
12
-
(** Arguments for /get methods. *)
13
-
type get_args = {
14
-
account_id : Proto_id.t;
15
-
(** The account to fetch from. *)
16
-
ids : Proto_id.t list option;
17
-
(** The ids to fetch. [None] means fetch all. *)
18
-
properties : string list option;
19
-
(** Properties to include. [None] means all. *)
20
-
}
21
-
22
-
val get_args :
23
-
account_id:Proto_id.t ->
24
-
?ids:Proto_id.t list ->
25
-
?properties:string list ->
26
-
unit ->
27
-
get_args
28
-
29
-
val get_args_jsont : get_args Jsont.t
30
-
31
-
(** Response for /get methods. *)
32
-
type 'a get_response = {
33
-
account_id : Proto_id.t;
34
-
(** The account fetched from. *)
35
-
state : string;
36
-
(** Current state string. *)
37
-
list : 'a list;
38
-
(** The objects fetched. *)
39
-
not_found : Proto_id.t list;
40
-
(** Ids that were not found. *)
41
-
}
42
-
43
-
val get_response_jsont : 'a Jsont.t -> 'a get_response Jsont.t
44
-
45
-
(** {1 Foo/changes} *)
46
-
47
-
(** Arguments for /changes methods. *)
48
-
type changes_args = {
49
-
account_id : Proto_id.t;
50
-
since_state : string;
51
-
max_changes : int64 option;
52
-
}
53
-
54
-
val changes_args :
55
-
account_id:Proto_id.t ->
56
-
since_state:string ->
57
-
?max_changes:int64 ->
58
-
unit ->
59
-
changes_args
60
-
61
-
val changes_args_jsont : changes_args Jsont.t
62
-
63
-
(** Response for /changes methods. *)
64
-
type changes_response = {
65
-
account_id : Proto_id.t;
66
-
old_state : string;
67
-
new_state : string;
68
-
has_more_changes : bool;
69
-
created : Proto_id.t list;
70
-
updated : Proto_id.t list;
71
-
destroyed : Proto_id.t list;
72
-
}
73
-
74
-
val changes_response_jsont : changes_response Jsont.t
75
-
76
-
(** {1 Foo/set} *)
77
-
78
-
(** Arguments for /set methods.
79
-
80
-
The ['a] type parameter is the object type being created/updated. *)
81
-
type 'a set_args = {
82
-
account_id : Proto_id.t;
83
-
if_in_state : string option;
84
-
(** If set, only apply if current state matches. *)
85
-
create : (Proto_id.t * 'a) list option;
86
-
(** Objects to create, keyed by temporary id. *)
87
-
update : (Proto_id.t * Jsont.json) list option;
88
-
(** Objects to update. Value is a PatchObject. *)
89
-
destroy : Proto_id.t list option;
90
-
(** Ids to destroy. *)
91
-
}
92
-
93
-
val set_args :
94
-
account_id:Proto_id.t ->
95
-
?if_in_state:string ->
96
-
?create:(Proto_id.t * 'a) list ->
97
-
?update:(Proto_id.t * Jsont.json) list ->
98
-
?destroy:Proto_id.t list ->
99
-
unit ->
100
-
'a set_args
101
-
102
-
val set_args_jsont : 'a Jsont.t -> 'a set_args Jsont.t
103
-
104
-
(** Response for /set methods. *)
105
-
type 'a set_response = {
106
-
account_id : Proto_id.t;
107
-
old_state : string option;
108
-
new_state : string;
109
-
created : (Proto_id.t * 'a) list option;
110
-
(** Successfully created objects, keyed by temporary id. *)
111
-
updated : (Proto_id.t * 'a option) list option;
112
-
(** Successfully updated objects. Value may include server-set properties. *)
113
-
destroyed : Proto_id.t list option;
114
-
(** Successfully destroyed ids. *)
115
-
not_created : (Proto_id.t * Proto_error.set_error) list option;
116
-
(** Failed creates. *)
117
-
not_updated : (Proto_id.t * Proto_error.set_error) list option;
118
-
(** Failed updates. *)
119
-
not_destroyed : (Proto_id.t * Proto_error.set_error) list option;
120
-
(** Failed destroys. *)
121
-
}
122
-
123
-
val set_response_jsont : 'a Jsont.t -> 'a set_response Jsont.t
124
-
125
-
(** {1 Foo/copy} *)
126
-
127
-
(** Arguments for /copy methods. *)
128
-
type 'a copy_args = {
129
-
from_account_id : Proto_id.t;
130
-
if_from_in_state : string option;
131
-
account_id : Proto_id.t;
132
-
if_in_state : string option;
133
-
create : (Proto_id.t * 'a) list;
134
-
on_success_destroy_original : bool;
135
-
destroy_from_if_in_state : string option;
136
-
}
137
-
138
-
val copy_args_jsont : 'a Jsont.t -> 'a copy_args Jsont.t
139
-
140
-
(** Response for /copy methods. *)
141
-
type 'a copy_response = {
142
-
from_account_id : Proto_id.t;
143
-
account_id : Proto_id.t;
144
-
old_state : string option;
145
-
new_state : string;
146
-
created : (Proto_id.t * 'a) list option;
147
-
not_created : (Proto_id.t * Proto_error.set_error) list option;
148
-
}
149
-
150
-
val copy_response_jsont : 'a Jsont.t -> 'a copy_response Jsont.t
151
-
152
-
(** {1 Foo/query} *)
153
-
154
-
(** Arguments for /query methods. *)
155
-
type 'filter query_args = {
156
-
account_id : Proto_id.t;
157
-
filter : 'filter Proto_filter.filter option;
158
-
sort : Proto_filter.comparator list option;
159
-
position : int64;
160
-
anchor : Proto_id.t option;
161
-
anchor_offset : int64;
162
-
limit : int64 option;
163
-
calculate_total : bool;
164
-
}
165
-
166
-
val query_args :
167
-
account_id:Proto_id.t ->
168
-
?filter:'filter Proto_filter.filter ->
169
-
?sort:Proto_filter.comparator list ->
170
-
?position:int64 ->
171
-
?anchor:Proto_id.t ->
172
-
?anchor_offset:int64 ->
173
-
?limit:int64 ->
174
-
?calculate_total:bool ->
175
-
unit ->
176
-
'filter query_args
177
-
178
-
val query_args_jsont : 'filter Jsont.t -> 'filter query_args Jsont.t
179
-
180
-
(** Response for /query methods. *)
181
-
type query_response = {
182
-
account_id : Proto_id.t;
183
-
query_state : string;
184
-
can_calculate_changes : bool;
185
-
position : int64;
186
-
ids : Proto_id.t list;
187
-
total : int64 option;
188
-
}
189
-
190
-
val query_response_jsont : query_response Jsont.t
191
-
192
-
(** {1 Foo/queryChanges} *)
193
-
194
-
(** Arguments for /queryChanges methods. *)
195
-
type 'filter query_changes_args = {
196
-
account_id : Proto_id.t;
197
-
filter : 'filter Proto_filter.filter option;
198
-
sort : Proto_filter.comparator list option;
199
-
since_query_state : string;
200
-
max_changes : int64 option;
201
-
up_to_id : Proto_id.t option;
202
-
calculate_total : bool;
203
-
}
204
-
205
-
val query_changes_args_jsont : 'filter Jsont.t -> 'filter query_changes_args Jsont.t
206
-
207
-
(** Response for /queryChanges methods. *)
208
-
type query_changes_response = {
209
-
account_id : Proto_id.t;
210
-
old_query_state : string;
211
-
new_query_state : string;
212
-
total : int64 option;
213
-
removed : Proto_id.t list;
214
-
added : Proto_filter.added_item list;
215
-
}
216
-
217
-
val query_changes_response_jsont : query_changes_response Jsont.t
-132
lib/proto/proto_push.ml
-132
lib/proto/proto_push.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
module State_change = struct
7
-
type type_state = {
8
-
type_name : string;
9
-
state : string;
10
-
}
11
-
12
-
type t = {
13
-
type_ : string;
14
-
changed : (Proto_id.t * type_state list) list;
15
-
}
16
-
17
-
(* The changed object is account_id -> { typeName: state } *)
18
-
let changed_jsont =
19
-
let kind = "Changed" in
20
-
(* Inner is type -> state string map *)
21
-
let type_states_jsont = Proto_json_map.of_string Jsont.string in
22
-
(* Convert list of (string * string) to type_state list *)
23
-
let decode_type_states pairs =
24
-
List.map (fun (type_name, state) -> { type_name; state }) pairs
25
-
in
26
-
let encode_type_states states =
27
-
List.map (fun ts -> (ts.type_name, ts.state)) states
28
-
in
29
-
Proto_json_map.of_id
30
-
(Jsont.map ~kind ~dec:decode_type_states ~enc:encode_type_states type_states_jsont)
31
-
32
-
let make type_ changed = { type_; changed }
33
-
34
-
let jsont =
35
-
let kind = "StateChange" in
36
-
Jsont.Object.map ~kind make
37
-
|> Jsont.Object.mem "@type" Jsont.string ~enc:(fun t -> t.type_)
38
-
|> Jsont.Object.mem "changed" changed_jsont ~enc:(fun t -> t.changed)
39
-
|> Jsont.Object.finish
40
-
end
41
-
42
-
type push_keys = {
43
-
p256dh : string;
44
-
auth : string;
45
-
}
46
-
47
-
let push_keys_make p256dh auth = { p256dh; auth }
48
-
49
-
let push_keys_jsont =
50
-
let kind = "PushKeys" in
51
-
Jsont.Object.map ~kind push_keys_make
52
-
|> Jsont.Object.mem "p256dh" Jsont.string ~enc:(fun k -> k.p256dh)
53
-
|> Jsont.Object.mem "auth" Jsont.string ~enc:(fun k -> k.auth)
54
-
|> Jsont.Object.finish
55
-
56
-
type t = {
57
-
id : Proto_id.t;
58
-
device_client_id : string;
59
-
url : string;
60
-
keys : push_keys option;
61
-
verification_code : string option;
62
-
expires : Ptime.t option;
63
-
types : string list option;
64
-
}
65
-
66
-
let id t = t.id
67
-
let device_client_id t = t.device_client_id
68
-
let url t = t.url
69
-
let keys t = t.keys
70
-
let verification_code t = t.verification_code
71
-
let expires t = t.expires
72
-
let types t = t.types
73
-
74
-
let make id device_client_id url keys verification_code expires types =
75
-
{ id; device_client_id; url; keys; verification_code; expires; types }
76
-
77
-
let jsont =
78
-
let kind = "PushSubscription" in
79
-
Jsont.Object.map ~kind make
80
-
|> Jsont.Object.mem "id" Proto_id.jsont ~enc:id
81
-
|> Jsont.Object.mem "deviceClientId" Jsont.string ~enc:device_client_id
82
-
|> Jsont.Object.mem "url" Jsont.string ~enc:url
83
-
|> Jsont.Object.opt_mem "keys" push_keys_jsont ~enc:keys
84
-
|> Jsont.Object.opt_mem "verificationCode" Jsont.string ~enc:verification_code
85
-
|> Jsont.Object.opt_mem "expires" Proto_date.Utc.jsont ~enc:expires
86
-
|> Jsont.Object.opt_mem "types" (Jsont.list Jsont.string) ~enc:types
87
-
|> Jsont.Object.finish
88
-
89
-
let get_args_jsont = Proto_method.get_args_jsont
90
-
let get_response_jsont = Proto_method.get_response_jsont jsont
91
-
92
-
type create_args = {
93
-
device_client_id : string;
94
-
url : string;
95
-
keys : push_keys option;
96
-
verification_code : string option;
97
-
types : string list option;
98
-
}
99
-
100
-
let create_args_make device_client_id url keys verification_code types =
101
-
{ device_client_id; url; keys; verification_code; types }
102
-
103
-
let create_args_jsont =
104
-
let kind = "PushSubscription create" in
105
-
Jsont.Object.map ~kind create_args_make
106
-
|> Jsont.Object.mem "deviceClientId" Jsont.string ~enc:(fun a -> a.device_client_id)
107
-
|> Jsont.Object.mem "url" Jsont.string ~enc:(fun a -> a.url)
108
-
|> Jsont.Object.opt_mem "keys" push_keys_jsont ~enc:(fun a -> a.keys)
109
-
|> Jsont.Object.opt_mem "verificationCode" Jsont.string ~enc:(fun a -> a.verification_code)
110
-
|> Jsont.Object.opt_mem "types" (Jsont.list Jsont.string) ~enc:(fun a -> a.types)
111
-
|> Jsont.Object.finish
112
-
113
-
type set_args = {
114
-
account_id : Proto_id.t option;
115
-
if_in_state : string option;
116
-
create : (Proto_id.t * create_args) list option;
117
-
update : (Proto_id.t * Jsont.json) list option;
118
-
destroy : Proto_id.t list option;
119
-
}
120
-
121
-
let set_args_make account_id if_in_state create update destroy =
122
-
{ account_id; if_in_state; create; update; destroy }
123
-
124
-
let set_args_jsont =
125
-
let kind = "PushSubscription/set args" in
126
-
Jsont.Object.map ~kind set_args_make
127
-
|> Jsont.Object.opt_mem "accountId" Proto_id.jsont ~enc:(fun a -> a.account_id)
128
-
|> Jsont.Object.opt_mem "ifInState" Jsont.string ~enc:(fun a -> a.if_in_state)
129
-
|> Jsont.Object.opt_mem "create" (Proto_json_map.of_id create_args_jsont) ~enc:(fun a -> a.create)
130
-
|> Jsont.Object.opt_mem "update" (Proto_json_map.of_id Jsont.json) ~enc:(fun a -> a.update)
131
-
|> Jsont.Object.opt_mem "destroy" (Jsont.list Proto_id.jsont) ~enc:(fun a -> a.destroy)
132
-
|> Jsont.Object.finish
-98
lib/proto/proto_push.mli
-98
lib/proto/proto_push.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP push types as defined in RFC 8620 Section 7
7
-
8
-
@canonical Jmap.Proto.Push *)
9
-
10
-
(** {1 StateChange} *)
11
-
12
-
(** A state change notification for push. *)
13
-
module State_change : sig
14
-
type type_state = {
15
-
type_name : string;
16
-
(** The data type that changed (e.g., "Email", "Mailbox"). *)
17
-
state : string;
18
-
(** The new state string for this type. *)
19
-
}
20
-
21
-
type t = {
22
-
type_ : string;
23
-
(** Always "StateChange". *)
24
-
changed : (Proto_id.t * type_state list) list;
25
-
(** Map of account id to list of type state changes. *)
26
-
}
27
-
28
-
val jsont : t Jsont.t
29
-
end
30
-
31
-
(** {1 PushSubscription} *)
32
-
33
-
(** Web push subscription keys. *)
34
-
type push_keys = {
35
-
p256dh : string;
36
-
(** P-256 ECDH public key as URL-safe base64. *)
37
-
auth : string;
38
-
(** Authentication secret as URL-safe base64. *)
39
-
}
40
-
41
-
val push_keys_jsont : push_keys Jsont.t
42
-
43
-
(** A push subscription object. *)
44
-
type t = {
45
-
id : Proto_id.t;
46
-
(** Server-assigned subscription id. *)
47
-
device_client_id : string;
48
-
(** Client-provided device identifier. *)
49
-
url : string;
50
-
(** The push endpoint URL. *)
51
-
keys : push_keys option;
52
-
(** Optional encryption keys for Web Push. *)
53
-
verification_code : string option;
54
-
(** Code for verifying subscription ownership. *)
55
-
expires : Ptime.t option;
56
-
(** When the subscription expires. *)
57
-
types : string list option;
58
-
(** Data types to receive notifications for. [None] means all. *)
59
-
}
60
-
61
-
val id : t -> Proto_id.t
62
-
val device_client_id : t -> string
63
-
val url : t -> string
64
-
val keys : t -> push_keys option
65
-
val verification_code : t -> string option
66
-
val expires : t -> Ptime.t option
67
-
val types : t -> string list option
68
-
69
-
val jsont : t Jsont.t
70
-
(** JSON codec for PushSubscription. *)
71
-
72
-
(** {1 PushSubscription Methods} *)
73
-
74
-
(** Arguments for PushSubscription/get. *)
75
-
val get_args_jsont : Proto_method.get_args Jsont.t
76
-
77
-
(** Response for PushSubscription/get. *)
78
-
val get_response_jsont : t Proto_method.get_response Jsont.t
79
-
80
-
(** Arguments for PushSubscription/set. *)
81
-
type set_args = {
82
-
account_id : Proto_id.t option;
83
-
(** Not used for PushSubscription. *)
84
-
if_in_state : string option;
85
-
create : (Proto_id.t * create_args) list option;
86
-
update : (Proto_id.t * Jsont.json) list option;
87
-
destroy : Proto_id.t list option;
88
-
}
89
-
90
-
and create_args = {
91
-
device_client_id : string;
92
-
url : string;
93
-
keys : push_keys option;
94
-
verification_code : string option;
95
-
types : string list option;
96
-
}
97
-
98
-
val set_args_jsont : set_args Jsont.t
-34
lib/proto/proto_request.ml
-34
lib/proto/proto_request.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = {
7
-
using : string list;
8
-
method_calls : Proto_invocation.t list;
9
-
created_ids : (Proto_id.t * Proto_id.t) list option;
10
-
}
11
-
12
-
let create ~using ~method_calls ?created_ids () =
13
-
{ using; method_calls; created_ids }
14
-
15
-
let using t = t.using
16
-
let method_calls t = t.method_calls
17
-
let created_ids t = t.created_ids
18
-
19
-
let make using method_calls created_ids =
20
-
{ using; method_calls; created_ids }
21
-
22
-
let jsont =
23
-
let kind = "Request" in
24
-
Jsont.Object.map ~kind make
25
-
|> Jsont.Object.mem "using" (Jsont.list Jsont.string) ~enc:using
26
-
|> Jsont.Object.mem "methodCalls" (Jsont.list Proto_invocation.jsont) ~enc:method_calls
27
-
|> Jsont.Object.opt_mem "createdIds" (Proto_json_map.of_id Proto_id.jsont) ~enc:created_ids
28
-
|> Jsont.Object.finish
29
-
30
-
let single ~using invocation =
31
-
{ using; method_calls = [invocation]; created_ids = None }
32
-
33
-
let batch ~using invocations =
34
-
{ using; method_calls = invocations; created_ids = None }
-47
lib/proto/proto_request.mli
-47
lib/proto/proto_request.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP request object as defined in RFC 8620 Section 3.3
7
-
8
-
@canonical Jmap.Proto.Request *)
9
-
10
-
type t = {
11
-
using : string list;
12
-
(** Capability URIs required for this request. *)
13
-
method_calls : Proto_invocation.t list;
14
-
(** The method calls to execute. *)
15
-
created_ids : (Proto_id.t * Proto_id.t) list option;
16
-
(** Map of client-created temporary ids to server-assigned ids.
17
-
Used for result references in batch operations. *)
18
-
}
19
-
20
-
val create :
21
-
using:string list ->
22
-
method_calls:Proto_invocation.t list ->
23
-
?created_ids:(Proto_id.t * Proto_id.t) list ->
24
-
unit ->
25
-
t
26
-
(** [create ~using ~method_calls ?created_ids ()] creates a JMAP request. *)
27
-
28
-
val using : t -> string list
29
-
val method_calls : t -> Proto_invocation.t list
30
-
val created_ids : t -> (Proto_id.t * Proto_id.t) list option
31
-
32
-
val jsont : t Jsont.t
33
-
(** JSON codec for JMAP requests. *)
34
-
35
-
(** {1 Request Builders} *)
36
-
37
-
val single :
38
-
using:string list ->
39
-
Proto_invocation.t ->
40
-
t
41
-
(** [single ~using invocation] creates a request with a single method call. *)
42
-
43
-
val batch :
44
-
using:string list ->
45
-
Proto_invocation.t list ->
46
-
t
47
-
(** [batch ~using invocations] creates a request with multiple method calls. *)
-46
lib/proto/proto_response.ml
-46
lib/proto/proto_response.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = {
7
-
method_responses : Proto_invocation.t list;
8
-
created_ids : (Proto_id.t * Proto_id.t) list option;
9
-
session_state : string;
10
-
}
11
-
12
-
let method_responses t = t.method_responses
13
-
let created_ids t = t.created_ids
14
-
let session_state t = t.session_state
15
-
16
-
let make method_responses created_ids session_state =
17
-
{ method_responses; created_ids; session_state }
18
-
19
-
let jsont =
20
-
let kind = "Response" in
21
-
Jsont.Object.map ~kind make
22
-
|> Jsont.Object.mem "methodResponses" (Jsont.list Proto_invocation.jsont) ~enc:method_responses
23
-
|> Jsont.Object.opt_mem "createdIds" (Proto_json_map.of_id Proto_id.jsont) ~enc:created_ids
24
-
|> Jsont.Object.mem "sessionState" Jsont.string ~enc:session_state
25
-
|> Jsont.Object.finish
26
-
27
-
let find_response method_call_id response =
28
-
List.find_opt
29
-
(fun inv -> Proto_invocation.method_call_id inv = method_call_id)
30
-
response.method_responses
31
-
32
-
let get_response method_call_id response =
33
-
match find_response method_call_id response with
34
-
| Some inv -> inv
35
-
| None -> raise Not_found
36
-
37
-
let is_error invocation =
38
-
String.equal (Proto_invocation.name invocation) "error"
39
-
40
-
let get_error invocation =
41
-
if is_error invocation then
42
-
match Jsont.Json.decode' Proto_error.method_error_jsont (Proto_invocation.arguments invocation) with
43
-
| Ok v -> Some v
44
-
| Error _ -> None
45
-
else
46
-
None
-39
lib/proto/proto_response.mli
-39
lib/proto/proto_response.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP response object as defined in RFC 8620 Section 3.4
7
-
8
-
@canonical Jmap.Proto.Response *)
9
-
10
-
type t = {
11
-
method_responses : Proto_invocation.t list;
12
-
(** The method responses. Each is [methodName, responseArgs, methodCallId]. *)
13
-
created_ids : (Proto_id.t * Proto_id.t) list option;
14
-
(** Map of client-created temporary ids to server-assigned ids. *)
15
-
session_state : string;
16
-
(** Current session state. Changes indicate session data has changed. *)
17
-
}
18
-
19
-
val method_responses : t -> Proto_invocation.t list
20
-
val created_ids : t -> (Proto_id.t * Proto_id.t) list option
21
-
val session_state : t -> string
22
-
23
-
val jsont : t Jsont.t
24
-
(** JSON codec for JMAP responses. *)
25
-
26
-
(** {1 Response Inspection} *)
27
-
28
-
val find_response : string -> t -> Proto_invocation.t option
29
-
(** [find_response method_call_id response] finds the response for a method call. *)
30
-
31
-
val get_response : string -> t -> Proto_invocation.t
32
-
(** [get_response method_call_id response] gets the response for a method call.
33
-
@raise Not_found if not found. *)
34
-
35
-
val is_error : Proto_invocation.t -> bool
36
-
(** [is_error invocation] returns [true] if the invocation is an error response. *)
37
-
38
-
val get_error : Proto_invocation.t -> Proto_error.method_error option
39
-
(** [get_error invocation] returns the error if this is an error response. *)
-96
lib/proto/proto_session.ml
-96
lib/proto/proto_session.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
module Account = struct
7
-
type t = {
8
-
name : string;
9
-
is_personal : bool;
10
-
is_read_only : bool;
11
-
account_capabilities : (string * Jsont.json) list;
12
-
}
13
-
14
-
let name t = t.name
15
-
let is_personal t = t.is_personal
16
-
let is_read_only t = t.is_read_only
17
-
let account_capabilities t = t.account_capabilities
18
-
19
-
let make name is_personal is_read_only account_capabilities =
20
-
{ name; is_personal; is_read_only; account_capabilities }
21
-
22
-
let jsont =
23
-
let kind = "Account" in
24
-
Jsont.Object.map ~kind make
25
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
26
-
|> Jsont.Object.mem "isPersonal" Jsont.bool ~enc:is_personal
27
-
|> Jsont.Object.mem "isReadOnly" Jsont.bool ~enc:is_read_only
28
-
|> Jsont.Object.mem "accountCapabilities" (Proto_json_map.of_string Jsont.json) ~enc:account_capabilities
29
-
|> Jsont.Object.finish
30
-
end
31
-
32
-
type t = {
33
-
capabilities : (string * Jsont.json) list;
34
-
accounts : (Proto_id.t * Account.t) list;
35
-
primary_accounts : (string * Proto_id.t) list;
36
-
username : string;
37
-
api_url : string;
38
-
download_url : string;
39
-
upload_url : string;
40
-
event_source_url : string;
41
-
state : string;
42
-
}
43
-
44
-
let capabilities t = t.capabilities
45
-
let accounts t = t.accounts
46
-
let primary_accounts t = t.primary_accounts
47
-
let username t = t.username
48
-
let api_url t = t.api_url
49
-
let download_url t = t.download_url
50
-
let upload_url t = t.upload_url
51
-
let event_source_url t = t.event_source_url
52
-
let state t = t.state
53
-
54
-
let make capabilities accounts primary_accounts username api_url
55
-
download_url upload_url event_source_url state =
56
-
{ capabilities; accounts; primary_accounts; username; api_url;
57
-
download_url; upload_url; event_source_url; state }
58
-
59
-
let jsont =
60
-
let kind = "Session" in
61
-
Jsont.Object.map ~kind make
62
-
|> Jsont.Object.mem "capabilities" (Proto_json_map.of_string Jsont.json) ~enc:capabilities
63
-
|> Jsont.Object.mem "accounts" (Proto_json_map.of_id Account.jsont) ~enc:accounts
64
-
|> Jsont.Object.mem "primaryAccounts" (Proto_json_map.of_string Proto_id.jsont) ~enc:primary_accounts
65
-
|> Jsont.Object.mem "username" Jsont.string ~enc:username
66
-
|> Jsont.Object.mem "apiUrl" Jsont.string ~enc:api_url
67
-
|> Jsont.Object.mem "downloadUrl" Jsont.string ~enc:download_url
68
-
|> Jsont.Object.mem "uploadUrl" Jsont.string ~enc:upload_url
69
-
|> Jsont.Object.mem "eventSourceUrl" Jsont.string ~enc:event_source_url
70
-
|> Jsont.Object.mem "state" Jsont.string ~enc:state
71
-
|> Jsont.Object.finish
72
-
73
-
let get_account id session =
74
-
List.assoc_opt id session.accounts
75
-
76
-
let primary_account_for capability session =
77
-
List.assoc_opt capability session.primary_accounts
78
-
79
-
let has_capability uri session =
80
-
List.exists (fun (k, _) -> k = uri) session.capabilities
81
-
82
-
let get_core_capability session =
83
-
match List.assoc_opt Proto_capability.core session.capabilities with
84
-
| None -> None
85
-
| Some json ->
86
-
(match Jsont.Json.decode' Proto_capability.Core.jsont json with
87
-
| Ok v -> Some v
88
-
| Error _ -> None)
89
-
90
-
let get_mail_capability session =
91
-
match List.assoc_opt Proto_capability.mail session.capabilities with
92
-
| None -> None
93
-
| Some json ->
94
-
(match Jsont.Json.decode' Proto_capability.Mail.jsont json with
95
-
| Ok v -> Some v
96
-
| Error _ -> None)
-86
lib/proto/proto_session.mli
-86
lib/proto/proto_session.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** JMAP session object as defined in RFC 8620 Section 2
7
-
8
-
@canonical Jmap.Proto.Session *)
9
-
10
-
(** {1 Account} *)
11
-
12
-
(** An account available to the user. *)
13
-
module Account : sig
14
-
type t = {
15
-
name : string;
16
-
(** Human-readable name for the account. *)
17
-
is_personal : bool;
18
-
(** Whether this is a personal account. *)
19
-
is_read_only : bool;
20
-
(** Whether the account is read-only. *)
21
-
account_capabilities : (string * Jsont.json) list;
22
-
(** Capabilities available for this account. *)
23
-
}
24
-
25
-
val name : t -> string
26
-
val is_personal : t -> bool
27
-
val is_read_only : t -> bool
28
-
val account_capabilities : t -> (string * Jsont.json) list
29
-
30
-
val jsont : t Jsont.t
31
-
end
32
-
33
-
(** {1 Session} *)
34
-
35
-
(** The JMAP session resource. *)
36
-
type t = {
37
-
capabilities : (string * Jsont.json) list;
38
-
(** Server capabilities. Keys are capability URIs. *)
39
-
accounts : (Proto_id.t * Account.t) list;
40
-
(** Available accounts keyed by account id. *)
41
-
primary_accounts : (string * Proto_id.t) list;
42
-
(** Map of capability URI to the primary account id for that capability. *)
43
-
username : string;
44
-
(** The username associated with the credentials. *)
45
-
api_url : string;
46
-
(** URL to POST JMAP requests to. *)
47
-
download_url : string;
48
-
(** URL template for downloading blobs. *)
49
-
upload_url : string;
50
-
(** URL template for uploading blobs. *)
51
-
event_source_url : string;
52
-
(** URL for push event source. *)
53
-
state : string;
54
-
(** Opaque session state string. *)
55
-
}
56
-
57
-
val capabilities : t -> (string * Jsont.json) list
58
-
val accounts : t -> (Proto_id.t * Account.t) list
59
-
val primary_accounts : t -> (string * Proto_id.t) list
60
-
val username : t -> string
61
-
val api_url : t -> string
62
-
val download_url : t -> string
63
-
val upload_url : t -> string
64
-
val event_source_url : t -> string
65
-
val state : t -> string
66
-
67
-
val jsont : t Jsont.t
68
-
(** JSON codec for session objects. *)
69
-
70
-
(** {1 Session Helpers} *)
71
-
72
-
val get_account : Proto_id.t -> t -> Account.t option
73
-
(** [get_account id session] returns the account with the given id. *)
74
-
75
-
val primary_account_for : string -> t -> Proto_id.t option
76
-
(** [primary_account_for capability session] returns the primary account
77
-
for the given capability URI. *)
78
-
79
-
val has_capability : string -> t -> bool
80
-
(** [has_capability uri session] returns [true] if the server supports the capability. *)
81
-
82
-
val get_core_capability : t -> Proto_capability.Core.t option
83
-
(** [get_core_capability session] returns the parsed core capability. *)
84
-
85
-
val get_mail_capability : t -> Proto_capability.Mail.t option
86
-
(** [get_mail_capability session] returns the parsed mail capability. *)
-14
lib/proto/proto_unknown.ml
-14
lib/proto/proto_unknown.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t = Jsont.json
7
-
8
-
let empty = Jsont.Object ([], Jsont.Meta.none)
9
-
10
-
let is_empty = function
11
-
| Jsont.Object ([], _) -> true
12
-
| _ -> false
13
-
14
-
let mems = Jsont.json_mems
-25
lib/proto/proto_unknown.mli
-25
lib/proto/proto_unknown.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Unknown field preservation for forward compatibility.
7
-
8
-
All JMAP objects preserve unknown fields to support future spec versions
9
-
and custom extensions.
10
-
11
-
@canonical Jmap.Proto.Unknown *)
12
-
13
-
type t = Jsont.json
14
-
(** Unknown or unrecognized JSON object members as a generic JSON value.
15
-
This is always an object containing the unknown fields. *)
16
-
17
-
val empty : t
18
-
(** [empty] is the empty set of unknown fields (an empty JSON object). *)
19
-
20
-
val is_empty : t -> bool
21
-
(** [is_empty u] returns [true] if there are no unknown fields. *)
22
-
23
-
val mems : (t, t, Jsont.mem list) Jsont.Object.Mems.map
24
-
(** [mems] is the jsont member map for preserving unknown fields.
25
-
Use with [Jsont.Object.keep_unknown]. *)
-6
lib/top/dune
-6
lib/top/dune
-68
lib/top/jmap_top.ml
-68
lib/top/jmap_top.ml
···
1
-
(* Toplevel printers for JMAP types
2
-
3
-
Usage in toplevel:
4
-
#require "jmap.top";;
5
-
6
-
Printers are automatically installed when the library is loaded.
7
-
*)
8
-
9
-
(* JSON printers *)
10
-
11
-
let json_printer ppf (json : Jsont.json) =
12
-
match Jsont_bytesrw.encode_string Jsont.json json with
13
-
| Ok s -> Format.pp_print_string ppf s
14
-
| Error e -> Format.fprintf ppf "<json encoding error: %s>" e
15
-
16
-
let jsont_error_printer ppf (e : Jsont.Error.t) =
17
-
Format.pp_print_string ppf (Jsont.Error.to_string e)
18
-
19
-
(* JSON encoding helpers *)
20
-
21
-
let encode (type a) (codec : a Jsont.t) (value : a) : Jsont.json =
22
-
match Jsont.Json.encode codec value with
23
-
| Ok json -> json
24
-
| Error e -> invalid_arg e
25
-
26
-
let encode_string (type a) (codec : a Jsont.t) (value : a) : string =
27
-
match Jsont_bytesrw.encode_string codec value with
28
-
| Ok s -> s
29
-
| Error e -> invalid_arg e
30
-
31
-
let pp_as_json (type a) (codec : a Jsont.t) ppf (value : a) =
32
-
json_printer ppf (encode codec value)
33
-
34
-
(* Automatic printer installation *)
35
-
36
-
let printers =
37
-
[ "Jmap.Id.pp";
38
-
"Jmap.Keyword.pp";
39
-
"Jmap.Role.pp";
40
-
"Jmap.Capability.pp";
41
-
"Jmap.Error.pp";
42
-
"Jmap_top.json_printer";
43
-
"Jmap_top.jsont_error_printer" ]
44
-
45
-
(* Suppress stderr during printer installation to avoid noise in MDX tests *)
46
-
let null_formatter = Format.make_formatter (fun _ _ _ -> ()) (fun () -> ())
47
-
48
-
let eval_string_quiet str =
49
-
try
50
-
let lexbuf = Lexing.from_string str in
51
-
let phrase = !Toploop.parse_toplevel_phrase lexbuf in
52
-
Toploop.execute_phrase false null_formatter phrase
53
-
with _ -> false
54
-
55
-
let rec do_install_printers = function
56
-
| [] -> true
57
-
| printer :: rest ->
58
-
let cmd = Printf.sprintf "#install_printer %s;;" printer in
59
-
eval_string_quiet cmd && do_install_printers rest
60
-
61
-
let install () =
62
-
(* Silently ignore failures - this handles non-toplevel contexts like MDX *)
63
-
ignore (do_install_printers printers)
64
-
65
-
(* Only auto-install when OCAML_TOPLEVEL_NAME is set, indicating a real toplevel *)
66
-
let () =
67
-
if Sys.getenv_opt "OCAML_TOPLEVEL_NAME" <> None then
68
-
install ()
-50
lib/top/jmap_top.mli
-50
lib/top/jmap_top.mli
···
1
-
(** Toplevel printers for JMAP types.
2
-
3
-
Printers are automatically installed when the library is loaded:
4
-
{[
5
-
#require "jmap.top";;
6
-
]}
7
-
8
-
After loading, JMAP types will display nicely:
9
-
{[
10
-
# Jmap.Id.of_string_exn "abc123";;
11
-
- : Jmap.Id.t = <id:abc123>
12
-
13
-
# Jmap.Keyword.of_string "$seen";;
14
-
- : Jmap.Keyword.t = `Seen
15
-
16
-
# Jmap.Role.of_string "inbox";;
17
-
- : Jmap.Role.t = `Inbox
18
-
]}
19
-
20
-
JSON values display as formatted strings, making it easy to see
21
-
how OCaml types map to JMAP JSON. *)
22
-
23
-
(** {1 JSON Printers} *)
24
-
25
-
val json_printer : Format.formatter -> Jsont.json -> unit
26
-
(** Formats a JSON value as a compact JSON string. *)
27
-
28
-
val jsont_error_printer : Format.formatter -> Jsont.Error.t -> unit
29
-
(** Formats a Jsont parsing error. *)
30
-
31
-
(** {1 JSON Encoding Helpers}
32
-
33
-
These functions encode OCaml types to JSON, useful for understanding
34
-
how the library maps to JMAP wire format. *)
35
-
36
-
val encode : 'a Jsont.t -> 'a -> Jsont.json
37
-
(** [encode codec value] encodes a value to JSON using the given codec.
38
-
Raises [Invalid_argument] on encoding failure. *)
39
-
40
-
val encode_string : 'a Jsont.t -> 'a -> string
41
-
(** [encode_string codec value] encodes a value to a JSON string. *)
42
-
43
-
val pp_as_json : 'a Jsont.t -> Format.formatter -> 'a -> unit
44
-
(** [pp_as_json codec ppf value] pretty-prints a value as JSON. *)
45
-
46
-
(** {1 Installation} *)
47
-
48
-
val install : unit -> unit
49
-
(** [install ()] installs all printers. This is called automatically when
50
-
the library is loaded, but can be called again if needed. *)
-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