anil.recoil.org
IMAP in OCaml
Consolidate lib/ directory structure
Reorganize from 11 subdirectories to 2:
- lib/imap/ - standalone IMAP client library
- lib/imapd/ - consolidated server library
Modules renamed for clarity:
- Types -> Protocol (IMAP protocol definitions)
- imap_auth -> Auth
- imap_parser -> Parser
- imap_server -> Server
- imap_storage -> Storage
- imap_read -> Read
- imap_write -> Write
- imap_client -> Client
- imap_client_error -> Client_error
- imap_client_pool -> Client_pool
Access via Imapd.Protocol, Imapd.Server, etc.
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+4
-2
bin/dune
+4
-2
bin/dune
···
1
1
(executable
2
2
(name main)
3
3
(public_name imapd)
4
-
(libraries imap_server imap_storage imap_auth eio_main mirage-crypto-rng.unix cmdliner))
4
+
(package imapd)
5
+
(libraries imapd eio_main mirage-crypto-rng.unix cmdliner))
5
6
6
7
(executable
7
8
(name imap_client)
8
9
(public_name imap-client)
9
-
(libraries eio eio_main tls-eio mirage-crypto-rng.unix cmdliner))
10
+
(package imap)
11
+
(libraries imap eio eio_main tls-eio mirage-crypto-rng.unix cmdliner))
+84
-273
bin/imap_client.ml
+84
-273
bin/imap_client.ml
···
6
6
(** IMAP4rev2 Client - List recent emails with subject and date
7
7
8
8
A simple IMAP client that connects over TLS, logs in, and lists
9
-
recent emails from the inbox, similar to the jmap examples.
9
+
recent emails from the inbox.
10
10
11
-
Uses Eio.Buf_read and Eio.Buf_write for efficient buffered I/O.
11
+
Uses the Imap client library for protocol handling.
12
12
13
13
Usage:
14
14
IMAP_PASSWORD=xxx imap-client --host mail.example.com --user me@example.com
···
20
20
21
21
open Cmdliner
22
22
23
-
(** IMAP client state using Eio buffered I/O *)
24
-
type client = {
25
-
reader : Eio.Buf_read.t;
26
-
writer : Eio.Buf_write.t;
27
-
mutable tag_counter : int;
28
-
}
29
-
30
-
(** Generate next command tag *)
31
-
let next_tag client =
32
-
client.tag_counter <- client.tag_counter + 1;
33
-
Printf.sprintf "A%04d" client.tag_counter
34
-
35
-
(** Read a CRLF-terminated line using Buf_read *)
36
-
let read_line client =
37
-
(* Read until we find CRLF *)
38
-
let line = Eio.Buf_read.line client.reader in
39
-
(* Buf_read.line strips the newline, we don't need CRLF for processing *)
40
-
line
41
-
42
-
(** Send a command using Buf_write *)
43
-
let send_line client line =
44
-
Eio.Buf_write.string client.writer line;
45
-
Eio.Buf_write.string client.writer "\r\n"
46
-
47
-
(** Send a command and return raw response lines until tagged response *)
48
-
let send_command client cmd =
49
-
let tag = next_tag client in
50
-
let line = Printf.sprintf "%s %s" tag cmd in
51
-
send_line client line;
52
-
53
-
(* Read response lines until we get the tagged response *)
54
-
let responses = ref [] in
55
-
let rec read_until_tagged () =
56
-
let line = read_line client in
57
-
responses := line :: !responses;
58
-
(* Check if this is the tagged response *)
59
-
if String.length line > String.length tag &&
60
-
String.sub line 0 (String.length tag) = tag then
61
-
List.rev !responses
62
-
else
63
-
read_until_tagged ()
64
-
in
65
-
(tag, read_until_tagged ())
66
-
67
-
(** Read server greeting *)
68
-
let read_greeting client =
69
-
read_line client
70
-
71
-
(** Check if response indicates success *)
72
-
let is_ok_response tag responses =
73
-
match List.rev responses with
74
-
| [] -> false
75
-
| last :: _ ->
76
-
let prefix = tag ^ " OK" in
77
-
String.length last >= String.length prefix &&
78
-
String.sub last 0 (String.length prefix) = prefix
79
-
80
-
(** Parse envelope from FETCH response *)
23
+
(** Email display record *)
81
24
type email_info = {
82
-
uid : int;
25
+
uid : int32;
83
26
date : string;
84
27
subject : string;
85
28
from : string;
86
29
seen : bool;
87
30
}
88
31
89
-
(** Extract quoted string from position *)
90
-
let extract_quoted_string s start =
91
-
if start >= String.length s || s.[start] <> '"' then
92
-
(None, start)
93
-
else begin
94
-
let buf = Buffer.create 64 in
95
-
let i = ref (start + 1) in
96
-
while !i < String.length s && s.[!i] <> '"' do
97
-
if s.[!i] = '\\' && !i + 1 < String.length s then begin
98
-
incr i;
99
-
Buffer.add_char buf s.[!i]
100
-
end else
101
-
Buffer.add_char buf s.[!i];
102
-
incr i
103
-
done;
104
-
if !i < String.length s then incr i; (* Skip closing quote *)
105
-
(Some (Buffer.contents buf), !i)
106
-
end
32
+
(** Extract email address from envelope *)
33
+
let format_address (addr : Imap.Envelope.address) =
34
+
match addr.mailbox, addr.host with
35
+
| Some m, Some h -> Printf.sprintf "%s@%s" m h
36
+
| Some m, None -> m
37
+
| None, _ -> "<unknown>"
107
38
108
-
(** Skip NIL or extract quoted string *)
109
-
let extract_nil_or_string s start =
110
-
if start + 3 <= String.length s &&
111
-
String.uppercase_ascii (String.sub s start 3) = "NIL" then
112
-
(None, start + 3)
113
-
else
114
-
extract_quoted_string s start
115
-
116
-
(** Simple regex-free pattern matching for UID extraction *)
117
-
let find_uid_in_line line =
118
-
let rec find_from i =
119
-
if i + 4 >= String.length line then 0
120
-
else if String.sub line i 4 = "UID " then begin
121
-
(* Extract number after "UID " *)
122
-
let j = ref (i + 4) in
123
-
while !j < String.length line && line.[!j] >= '0' && line.[!j] <= '9' do
124
-
incr j
125
-
done;
126
-
if !j > i + 4 then
127
-
int_of_string (String.sub line (i + 4) (!j - i - 4))
128
-
else
129
-
find_from (i + 1)
130
-
end else
131
-
find_from (i + 1)
132
-
in
133
-
find_from 0
134
-
135
-
(** Check if line contains \Seen flag *)
136
-
let has_seen_flag line =
137
-
let rec find_from i =
138
-
if i + 5 >= String.length line then false
139
-
else if String.sub line i 5 = "\\Seen" then true
140
-
else find_from (i + 1)
141
-
in
142
-
find_from 0
143
-
144
-
(** Find pattern in string and return position after it, or -1 *)
145
-
let find_pattern pat s =
146
-
let pat_len = String.length pat in
147
-
let s_len = String.length s in
148
-
let rec find_from i =
149
-
if i + pat_len > s_len then -1
150
-
else if String.sub s i pat_len = pat then i + pat_len
151
-
else find_from (i + 1)
152
-
in
153
-
find_from 0
154
-
155
-
(** Extract email address from line (looks for <email> or "email" patterns) *)
156
-
let extract_email_from_line line =
157
-
(* Look for <email> pattern *)
158
-
let rec find_angle i =
159
-
if i >= String.length line then None
160
-
else if line.[i] = '<' then begin
161
-
let j = ref (i + 1) in
162
-
while !j < String.length line && line.[!j] <> '>' do incr j done;
163
-
if !j < String.length line then
164
-
Some (String.sub line (i + 1) (!j - i - 1))
165
-
else None
166
-
end else find_angle (i + 1)
167
-
in
168
-
match find_angle 0 with
169
-
| Some email -> email
170
-
| None -> "<unknown>"
171
-
172
-
(** Parse a simple FETCH response line to extract email info *)
173
-
let parse_fetch_line line =
174
-
if String.length line < 2 || line.[0] <> '*' then None
175
-
else begin
176
-
let uid = find_uid_in_line line in
177
-
let seen = has_seen_flag line in
178
-
179
-
(* Extract ENVELOPE if present - simplified parsing *)
180
-
let date, subject, from =
181
-
let env_pos = find_pattern "ENVELOPE (" line in
182
-
if env_pos < 0 then ("", "<no subject>", "<unknown>")
183
-
else begin
184
-
(* First field is date *)
185
-
let (date_opt, pos1) = extract_nil_or_string line env_pos in
186
-
let date = Option.value date_opt ~default:"" in
187
-
188
-
(* Skip space, get subject *)
189
-
let pos2 = if pos1 < String.length line && line.[pos1] = ' ' then pos1 + 1 else pos1 in
190
-
let (subj_opt, _pos3) = extract_nil_or_string line pos2 in
191
-
let subject = Option.value subj_opt ~default:"<no subject>" in
192
-
193
-
let from = extract_email_from_line line in
194
-
(date, subject, from)
195
-
end
196
-
in
197
-
198
-
if uid > 0 then
39
+
(** Convert message_info to email_info for display *)
40
+
let to_email_info (msg : Imap.Client.message_info) : email_info option =
41
+
match msg.uid with
42
+
| None -> None
43
+
| Some uid ->
44
+
let date =
45
+
Option.bind msg.envelope (fun e -> e.Imap.Envelope.date)
46
+
|> Option.value ~default:""
47
+
in
48
+
let subject =
49
+
Option.bind msg.envelope (fun e -> e.Imap.Envelope.subject)
50
+
|> Option.value ~default:"<no subject>"
51
+
in
52
+
let from =
53
+
match Option.bind msg.envelope (fun e ->
54
+
match e.Imap.Envelope.from with
55
+
| addr :: _ -> Some (format_address addr)
56
+
| [] -> None) with
57
+
| Some f -> f
58
+
| None -> "<unknown>"
59
+
in
60
+
let seen =
61
+
match msg.flags with
62
+
| Some flags ->
63
+
List.exists (function
64
+
| Imap.Flag.System Imap.Flag.Seen -> true
65
+
| _ -> false) flags
66
+
| None -> false
67
+
in
199
68
Some { uid; date; subject; from; seen }
200
-
else
201
-
None
202
-
end
203
69
204
70
(** Print email info in a nice format *)
205
71
let print_email email =
···
229
95
String.sub email.subject 0 47 ^ "..."
230
96
else email.subject
231
97
in
232
-
Printf.printf "%s %5d | %s | %s | %s\n"
98
+
Printf.printf "%s %5ld | %s | %s | %s\n"
233
99
status email.uid padded_date padded_from subject_display
234
100
235
-
(** Find EXISTS count in response *)
236
-
let find_exists_count responses =
237
-
List.fold_left (fun acc line ->
238
-
(* Look for "* N EXISTS" pattern *)
239
-
if String.length line > 2 && line.[0] = '*' && line.[1] = ' ' then begin
240
-
let rec find_num i =
241
-
if i >= String.length line then acc
242
-
else if line.[i] >= '0' && line.[i] <= '9' then begin
243
-
let j = ref i in
244
-
while !j < String.length line && line.[!j] >= '0' && line.[!j] <= '9' do incr j done;
245
-
let num_str = String.sub line i (!j - i) in
246
-
(* Check if followed by " EXISTS" *)
247
-
if !j + 7 <= String.length line && String.sub line !j 7 = " EXISTS" then
248
-
int_of_string num_str
249
-
else
250
-
find_num (!j + 1)
251
-
end else
252
-
find_num (i + 1)
253
-
in
254
-
find_num 2
255
-
end else acc
256
-
) 0 responses
257
-
258
101
(** Main IMAP client function *)
259
102
let run_client ~host ~port ~username ~password ~limit ~unread_only =
260
103
Mirage_crypto_rng_unix.use_default ();
261
104
262
105
Eio_main.run @@ fun env ->
263
-
let net = Eio.Stdenv.net env in
264
-
265
106
Eio.Switch.run @@ fun sw ->
266
107
267
-
(* Resolve hostname and connect *)
268
-
let addr =
269
-
match Eio.Net.getaddrinfo_stream net host ~service:(string_of_int port) with
270
-
| [] ->
271
-
Printf.eprintf "Error: Could not resolve hostname %s\n" host;
272
-
exit 1
273
-
| addr :: _ -> addr
274
-
in
275
-
276
108
Printf.printf "Connecting to %s:%d...\n%!" host port;
277
-
let flow = Eio.Net.connect ~sw net addr in
278
109
279
-
(* Wrap in TLS *)
280
-
let tls_config =
281
-
match Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) () with
282
-
| Ok config -> config
283
-
| Error _ ->
284
-
Printf.eprintf "Error: Failed to create TLS config\n";
110
+
let client =
111
+
try
112
+
Imap.Client.connect ~sw ~env ~host ~port ()
113
+
with Eio.Exn.Io _ as exn ->
114
+
Printf.eprintf "Error: Failed to connect to %s:%d\n" host port;
115
+
Printf.eprintf " %s\n" (Printexc.to_string exn);
285
116
exit 1
286
117
in
287
118
288
-
let tls_flow = Tls_eio.client_of_flow tls_config flow in
289
-
290
-
(* Create buffered reader and writer *)
291
-
let reader = Eio.Buf_read.of_flow tls_flow ~max_size:(1024 * 1024) in
292
-
293
-
Eio.Buf_write.with_flow tls_flow @@ fun writer ->
294
-
let client = { reader; writer; tag_counter = 0 } in
295
-
296
-
(* Read greeting *)
297
-
let greeting = read_greeting client in
298
-
Printf.printf "Server: %s\n" greeting;
119
+
Printf.printf "Connected. Server capabilities: %s\n%!"
120
+
(String.concat ", " (Imap.Client.capabilities client));
299
121
300
-
(* Login - escape username and password for IMAP *)
301
-
let escape_string s =
302
-
let buf = Buffer.create (String.length s + 10) in
303
-
Buffer.add_char buf '"';
304
-
String.iter (fun c ->
305
-
match c with
306
-
| '"' | '\\' -> Buffer.add_char buf '\\'; Buffer.add_char buf c
307
-
| _ -> Buffer.add_char buf c
308
-
) s;
309
-
Buffer.add_char buf '"';
310
-
Buffer.contents buf
311
-
in
312
-
122
+
(* Login *)
313
123
Printf.printf "Logging in as %s...\n%!" username;
314
-
let login_cmd = Printf.sprintf "LOGIN %s %s" (escape_string username) (escape_string password) in
315
-
let (tag, responses) = send_command client login_cmd in
316
-
if not (is_ok_response tag responses) then begin
317
-
Printf.eprintf "Login failed:\n";
318
-
List.iter (Printf.eprintf " %s\n") responses;
319
-
exit 1
320
-
end;
124
+
(try
125
+
Imap.Client.login client ~username ~password
126
+
with exn ->
127
+
Printf.eprintf "Login failed: %s\n" (Printexc.to_string exn);
128
+
Imap.Client.disconnect client;
129
+
exit 1);
321
130
Printf.printf "Login successful.\n%!";
322
131
323
132
(* Select INBOX *)
324
133
Printf.printf "Selecting INBOX...\n%!";
325
-
let (tag, responses) = send_command client "SELECT INBOX" in
326
-
if not (is_ok_response tag responses) then begin
327
-
Printf.eprintf "SELECT INBOX failed:\n";
328
-
List.iter (Printf.eprintf " %s\n") responses;
329
-
exit 1
330
-
end;
134
+
let mailbox =
135
+
try
136
+
Imap.Client.select client "INBOX"
137
+
with exn ->
138
+
Printf.eprintf "SELECT INBOX failed: %s\n" (Printexc.to_string exn);
139
+
Imap.Client.logout client;
140
+
exit 1
141
+
in
331
142
332
-
(* Get message count from EXISTS response *)
333
-
let msg_count = find_exists_count responses in
334
-
Printf.printf "Mailbox has %d messages.\n%!" msg_count;
143
+
Printf.printf "Mailbox has %d messages.\n%!" mailbox.exists;
335
144
336
-
if msg_count = 0 then begin
145
+
if mailbox.exists = 0 then begin
337
146
Printf.printf "No messages to display.\n";
338
-
(* Logout *)
339
-
ignore (send_command client "LOGOUT");
147
+
Imap.Client.logout client;
340
148
exit 0
341
149
end;
342
150
343
151
(* Fetch recent messages *)
344
-
let start_seq = max 1 (msg_count - limit + 1) in
345
-
let fetch_range = Printf.sprintf "%d:*" start_seq in
152
+
let start_seq = max 1 (mailbox.exists - limit + 1) in
153
+
let fetch_range = Imap.Seq.range start_seq mailbox.exists in
346
154
347
-
Printf.printf "Fetching messages %s...\n%!" fetch_range;
348
-
let fetch_cmd = Printf.sprintf "FETCH %s (UID FLAGS ENVELOPE)" fetch_range in
349
-
let (tag, responses) = send_command client fetch_cmd in
155
+
Printf.printf "Fetching messages %d:%d...\n%!" start_seq mailbox.exists;
350
156
351
-
if not (is_ok_response tag responses) then begin
352
-
Printf.eprintf "FETCH failed:\n";
353
-
List.iter (Printf.eprintf " %s\n") responses;
354
-
exit 1
355
-
end;
157
+
let messages =
158
+
try
159
+
Imap.Client.fetch client
160
+
~sequence:fetch_range
161
+
~items:[ Imap.Fetch.Uid; Imap.Fetch.Flags; Imap.Fetch.Envelope ]
162
+
with exn ->
163
+
Printf.eprintf "FETCH failed: %s\n" (Printexc.to_string exn);
164
+
Imap.Client.logout client;
165
+
exit 1
166
+
in
356
167
357
-
(* Parse and display emails *)
358
-
let emails = List.filter_map parse_fetch_line responses in
168
+
(* Convert to display format *)
169
+
let emails = List.filter_map to_email_info messages in
359
170
360
171
(* Filter unread if requested *)
361
172
let filtered_emails =
···
366
177
in
367
178
368
179
(* Sort by UID descending (most recent first) *)
369
-
let sorted_emails = List.sort (fun a b -> compare b.uid a.uid) filtered_emails in
180
+
let sorted_emails = List.sort (fun a b -> Int32.compare b.uid a.uid) filtered_emails in
370
181
371
182
Printf.printf "\n";
372
183
Printf.printf " %-5s | %-20s | %-30s | %s\n" "UID" "Date" "From" "Subject";
···
380
191
381
192
(* Logout *)
382
193
Printf.printf "\nLogging out...\n%!";
383
-
ignore (send_command client "LOGOUT");
194
+
Imap.Client.logout client;
384
195
Printf.printf "Done.\n"
385
196
386
197
(** Get password from environment *)
···
419
230
`S Manpage.s_description;
420
231
`P "Connects to an IMAP server over TLS, logs in, and lists recent emails \
421
232
from the inbox with their date, sender, and subject.";
422
-
`P "Uses Eio.Buf_read and Eio.Buf_write for efficient buffered I/O.";
233
+
`P "Uses the Imap library for protocol handling.";
423
234
`S Manpage.s_environment;
424
235
`P "$(b,IMAP_PASSWORD) - The password for authentication (required)";
425
236
`S Manpage.s_examples;
+14
-14
bin/main.ml
+14
-14
bin/main.ml
···
50
50
51
51
(* Run the server with memory storage - single process mode *)
52
52
let run_with_memory_single ~port ~host ~tls_config ~implicit_tls =
53
-
let module Server = Imap_server.Make(Imap_storage.Memory_storage)(Imap_auth.Pam_auth) in
53
+
let module Server = Imapd.Server.Make(Imapd.Storage.Memory_storage)(Imapd.Auth.Pam_auth) in
54
54
Eio_main.run @@ fun env ->
55
55
let net = Eio.Stdenv.net env in
56
-
let storage = Imap_storage.Memory_storage.create () in
57
-
let auth = Imap_auth.Pam_auth.create ~service_name:"imapd" in
56
+
let storage = Imapd.Storage.Memory_storage.create () in
57
+
let auth = Imapd.Auth.Pam_auth.create ~service_name:"imapd" in
58
58
59
59
(* Add test user for development *)
60
-
Imap_storage.Memory_storage.add_test_user storage ~username:"test";
60
+
Imapd.Storage.Memory_storage.add_test_user storage ~username:"test";
61
61
62
62
let config = {
63
-
Imap_server.default_config with
63
+
Imapd.Server.default_config with
64
64
hostname = host;
65
65
tls_config;
66
66
} in
···
81
81
82
82
(* Run the server with Maildir storage - single process mode *)
83
83
let run_with_maildir_single ~port ~host ~tls_config ~maildir_path ~implicit_tls =
84
-
let module Server = Imap_server.Make(Imap_storage.Maildir_storage)(Imap_auth.Pam_auth) in
84
+
let module Server = Imapd.Server.Make(Imapd.Storage.Maildir_storage)(Imapd.Auth.Pam_auth) in
85
85
Eio_main.run @@ fun env ->
86
86
let net = Eio.Stdenv.net env in
87
-
let storage = Imap_storage.Maildir_storage.create_with_path ~base_path:maildir_path in
88
-
let auth = Imap_auth.Pam_auth.create ~service_name:"imapd" in
87
+
let storage = Imapd.Storage.Maildir_storage.create_with_path ~base_path:maildir_path in
88
+
let auth = Imapd.Auth.Pam_auth.create ~service_name:"imapd" in
89
89
90
90
let config = {
91
-
Imap_server.default_config with
91
+
Imapd.Server.default_config with
92
92
hostname = host;
93
93
tls_config;
94
94
} in
···
109
109
110
110
(* Run the server with Maildir storage - forked mode with per-user privileges *)
111
111
let run_with_maildir_forked ~port ~host ~tls_config ~maildir_path =
112
-
let module Server = Imap_server.Make(Imap_storage.Maildir_storage)(Imap_auth.Pam_auth) in
112
+
let module Server = Imapd.Server.Make(Imapd.Storage.Maildir_storage)(Imapd.Auth.Pam_auth) in
113
113
let storage = match maildir_path with
114
-
| Some path -> Imap_storage.Maildir_storage.create_with_path ~base_path:path
115
-
| None -> Imap_storage.Maildir_storage.create_home_directory ()
114
+
| Some path -> Imapd.Storage.Maildir_storage.create_with_path ~base_path:path
115
+
| None -> Imapd.Storage.Maildir_storage.create_home_directory ()
116
116
in
117
-
let auth = Imap_auth.Pam_auth.create ~service_name:"imapd" in
117
+
let auth = Imapd.Auth.Pam_auth.create ~service_name:"imapd" in
118
118
119
119
let config = {
120
-
Imap_server.default_config with
120
+
Imapd.Server.default_config with
121
121
hostname = host;
122
122
tls_config;
123
123
} in
+26
-3
dune-project
+26
-3
dune-project
···
14
14
(maintenance_intent "(latest)")
15
15
16
16
(package
17
+
(name imap)
18
+
(synopsis "IMAP4rev2 client library for OCaml")
19
+
(description
20
+
"A comprehensive IMAP client library implementing RFC 9051 IMAP4rev2. \
21
+
Provides connection management, authentication, mailbox operations, \
22
+
message fetching, IDLE support, and connection pooling. Includes an \
23
+
imap-client CLI tool.")
24
+
(depends
25
+
(ocaml (>= 5.1.0))
26
+
(eio (>= 1.0))
27
+
(eio_main (>= 1.0))
28
+
(tls-eio (>= 1.0))
29
+
(tls (>= 1.0))
30
+
(cstruct (>= 6.0.0))
31
+
(fmt (>= 0.9.0))
32
+
(base64 (>= 3.5.0))
33
+
(cmdliner (>= 1.2.0))
34
+
(mirage-crypto-rng (>= 1.0.0))
35
+
(odoc :with-doc)
36
+
(alcotest (and :with-test (>= 1.7.0)))))
37
+
38
+
(package
17
39
(name imapd)
18
40
(synopsis "IMAP4rev2 server implemented in OCaml with Eio")
19
41
(description
20
-
"A modular IMAP4rev2 server (RFC 9051) implemented in OCaml using Eio \
21
-
for networking. Features pluggable storage backends (Memory, Maildir) \
22
-
and PAM authentication.")
42
+
"A modular IMAP4rev2 server implementation (RFC 9051) in OCaml using Eio for \
43
+
networking. Includes pluggable storage backends.")
23
44
(depends
24
45
(ocaml (>= 5.1.0))
25
46
(menhir (>= 20230608))
···
29
50
(tls (>= 1.0))
30
51
(faraday (>= 0.8))
31
52
(cmdliner (>= 1.2.0))
53
+
(fmt (>= 0.9.0))
54
+
(base64 (>= 3.5.0))
32
55
(conf-libpam :build)
33
56
(odoc :with-doc)
34
57
(alcotest (and :with-test (>= 1.7.0)))))
+40
imap.opam
+40
imap.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "IMAP4rev2 client library for OCaml"
4
+
description:
5
+
"A comprehensive IMAP client library implementing RFC 9051 IMAP4rev2. Provides connection management, authentication, mailbox operations, message fetching, IDLE support, and connection pooling. Includes an imap-client CLI tool."
6
+
maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
7
+
authors: ["Anil Madhavapeddy"]
8
+
license: "ISC"
9
+
homepage: "https://tangled.org/@anil.recoil.org/ocaml-imap"
10
+
bug-reports: "https://tangled.org/@anil.recoil.org/ocaml-imap/issues"
11
+
depends: [
12
+
"dune" {>= "3.20"}
13
+
"ocaml" {>= "5.1.0"}
14
+
"eio" {>= "1.0"}
15
+
"eio_main" {>= "1.0"}
16
+
"tls-eio" {>= "1.0"}
17
+
"tls" {>= "1.0"}
18
+
"cstruct" {>= "6.0.0"}
19
+
"fmt" {>= "0.9.0"}
20
+
"base64" {>= "3.5.0"}
21
+
"cmdliner" {>= "1.2.0"}
22
+
"mirage-crypto-rng" {>= "1.0.0"}
23
+
"odoc" {with-doc}
24
+
"alcotest" {with-test & >= "1.7.0"}
25
+
]
26
+
build: [
27
+
["dune" "subst"] {dev}
28
+
[
29
+
"dune"
30
+
"build"
31
+
"-p"
32
+
name
33
+
"-j"
34
+
jobs
35
+
"@install"
36
+
"@runtest" {with-test}
37
+
"@doc" {with-doc}
38
+
]
39
+
]
40
+
x-maintenance-intent: ["(latest)"]
+3
-1
imapd.opam
+3
-1
imapd.opam
···
2
2
opam-version: "2.0"
3
3
synopsis: "IMAP4rev2 server implemented in OCaml with Eio"
4
4
description:
5
-
"A modular IMAP4rev2 server (RFC 9051) implemented in OCaml using Eio for networking. Features pluggable storage backends (Memory, Maildir) and PAM authentication."
5
+
"A modular IMAP4rev2 server implementation (RFC 9051) in OCaml using Eio for networking. Includes pluggable storage backends."
6
6
maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
7
7
authors: ["Anil Madhavapeddy"]
8
8
license: "ISC"
···
18
18
"tls" {>= "1.0"}
19
19
"faraday" {>= "0.8"}
20
20
"cmdliner" {>= "1.2.0"}
21
+
"fmt" {>= "0.9.0"}
22
+
"base64" {>= "3.5.0"}
21
23
"conf-libpam" {build}
22
24
"odoc" {with-doc}
23
25
"alcotest" {with-test & >= "1.7.0"}
+248
lib/imap/PLAN.md
+248
lib/imap/PLAN.md
···
1
+
# IMAP Library Implementation Plan
2
+
3
+
Analysis of the OCaml IMAP client library against RFC specifications in `spec/`.
4
+
5
+
## Current Status
6
+
7
+
The library implements core IMAP4rev2 (RFC 9051) with extensions for:
8
+
- IDLE (RFC 2177)
9
+
- NAMESPACE (RFC 2342)
10
+
- ID (RFC 2971)
11
+
- UIDPLUS (RFC 4315) - partial
12
+
- ENABLE (RFC 5161)
13
+
- MOVE (RFC 6851)
14
+
15
+
## P0 - Broken Functionality
16
+
17
+
### 1. SEARCH returns empty results
18
+
19
+
**Location:** `client.ml:536-544`
20
+
21
+
```ocaml
22
+
let search t ?charset criteria =
23
+
require_selected t;
24
+
let _tag = send_command t (Command.Search { charset; criteria }) in
25
+
[] (* BUG: Always returns empty! *)
26
+
```
27
+
28
+
**Problem:** Command is sent but:
29
+
- Response is never read (note the `_tag` discard)
30
+
- SEARCH response not parsed in `read.ml`
31
+
- ESEARCH response defined in `Response.t` but not parsed
32
+
33
+
**Fix required:**
34
+
1. Add SEARCH response parsing to `read.ml` (untagged `* SEARCH 1 2 3 ...`)
35
+
2. Add ESEARCH response parsing for extended results
36
+
3. Fix `client.ml` to read and return the response
37
+
38
+
---
39
+
40
+
## P1 - Incomplete Core Features
41
+
42
+
### 2. BODY/BODYSTRUCTURE response parsing
43
+
44
+
**Location:** `read.ml:284-302`
45
+
46
+
Current `fetch_item` parser only handles:
47
+
- FLAGS ✅
48
+
- UID ✅
49
+
- RFC822.SIZE ✅
50
+
- INTERNALDATE ✅
51
+
- ENVELOPE ✅
52
+
53
+
Falls back to `Item_flags []` for unknown items including BODY/BODYSTRUCTURE.
54
+
55
+
**Fix required:**
56
+
- Parse BODY response into `Body.t`
57
+
- Parse BODYSTRUCTURE response into `Body.t`
58
+
- Handle nested multipart structures recursively
59
+
60
+
### 3. BODY[section] response parsing
61
+
62
+
**Location:** `read.ml` - not implemented
63
+
64
+
Critical for reading actual message content. Format:
65
+
```
66
+
BODY[HEADER] {size}\r\n<literal>
67
+
BODY[TEXT] {size}\r\n<literal>
68
+
BODY[1.2.MIME] {size}\r\n<literal>
69
+
```
70
+
71
+
**Fix required:**
72
+
- Parse section specifiers (HEADER, TEXT, MIME, part numbers)
73
+
- Parse optional origin `<offset>`
74
+
- Handle literal data
75
+
76
+
### 4. APPENDUID/COPYUID response codes
77
+
78
+
**Location:** `read.ml:169-228`
79
+
80
+
Response codes defined in `Code.t` but not parsed:
81
+
- `APPENDUID <uidvalidity> <uid>`
82
+
- `COPYUID <uidvalidity> <source-uids> <dest-uids>`
83
+
- `BADCHARSET (<charsets>)`
84
+
85
+
**Fix required:**
86
+
- Add parsing cases in `response_code` function
87
+
- Update `client.ml` to extract and return UIDs from APPEND/COPY/MOVE
88
+
89
+
---
90
+
91
+
## P2 - Missing Extensions
92
+
93
+
### 5. CONDSTORE (RFC 7162)
94
+
95
+
Enables efficient flag synchronization via modification sequences.
96
+
97
+
**Missing components:**
98
+
99
+
Types:
100
+
```ocaml
101
+
(* In Fetch module *)
102
+
| Modseq (* request item *)
103
+
| Item_modseq of int64 (* response item *)
104
+
105
+
(* In Code module *)
106
+
| Highestmodseq of int64
107
+
| Nomodseq
108
+
| Modified of Seq.t
109
+
```
110
+
111
+
Commands:
112
+
```ocaml
113
+
(* FETCH modifier *)
114
+
Fetch of { sequence; items; changedsince : int64 option }
115
+
116
+
(* STORE modifier *)
117
+
Store of { ...; unchangedsince : int64 option }
118
+
```
119
+
120
+
Parsing:
121
+
- `MODSEQ` fetch response item
122
+
- `HIGHESTMODSEQ` response code
123
+
- `NOMODSEQ` response code
124
+
125
+
### 6. QRESYNC (RFC 7162)
126
+
127
+
Fast mailbox resynchronization for mobile/disconnected clients.
128
+
129
+
**Missing components:**
130
+
131
+
Commands:
132
+
```ocaml
133
+
(* SELECT/EXAMINE modifier *)
134
+
Select of { mailbox; qresync : qresync_params option }
135
+
136
+
type qresync_params = {
137
+
uidvalidity : int32;
138
+
modseq : int64;
139
+
known_uids : Seq.t option;
140
+
seq_match : (Seq.t * Seq.t) option;
141
+
}
142
+
```
143
+
144
+
Responses:
145
+
```ocaml
146
+
| Vanished of { earlier : bool; uids : Seq.t }
147
+
```
148
+
149
+
### 7. LITERAL+ usage (RFC 7888)
150
+
151
+
**Location:** `write.ml:53-57`
152
+
153
+
`literal_plus` function exists but is never used.
154
+
155
+
**Fix required:**
156
+
- Detect LITERAL+ capability from server
157
+
- Use non-synchronizing literals for APPEND when available
158
+
- Reduces round-trips
159
+
160
+
---
161
+
162
+
## P3 - Minor Gaps
163
+
164
+
### 8. RFC822 fetch items
165
+
166
+
**Location:** `read.ml`
167
+
168
+
Missing parsers for:
169
+
- `RFC822` - full message
170
+
- `RFC822.HEADER` - headers only
171
+
- `RFC822.TEXT` - body only
172
+
173
+
These are legacy items but still used.
174
+
175
+
### 9. BINARY fetch items
176
+
177
+
**Location:** `read.ml`
178
+
179
+
Missing parsers for:
180
+
- `BINARY[section]` - decoded binary content
181
+
- `BINARY.SIZE[section]` - size of decoded content
182
+
183
+
### 10. STARTTLS
184
+
185
+
**Location:** `client.ml`
186
+
187
+
Currently raises error - library is IMAPS-only.
188
+
189
+
**Fix required:**
190
+
- Implement TLS upgrade on existing connection
191
+
- Requires socket upgrade support from tls-eio
192
+
193
+
---
194
+
195
+
## Implementation Order
196
+
197
+
### Phase 1: Fix broken functionality
198
+
1. [ ] Fix SEARCH/UID SEARCH to return results
199
+
2. [ ] Parse SEARCH response in `read.ml`
200
+
201
+
### Phase 2: Complete FETCH parsing
202
+
3. [ ] Parse BODY/BODYSTRUCTURE responses
203
+
4. [ ] Parse BODY[section] responses with literals
204
+
5. [ ] Parse RFC822/RFC822.HEADER/RFC822.TEXT
205
+
206
+
### Phase 3: Complete response codes
207
+
6. [ ] Parse APPENDUID response code
208
+
7. [ ] Parse COPYUID response code
209
+
8. [ ] Return UIDs from append/copy/move in client.ml
210
+
211
+
### Phase 4: CONDSTORE extension
212
+
9. [ ] Add MODSEQ types
213
+
10. [ ] Add CHANGEDSINCE fetch modifier
214
+
11. [ ] Add UNCHANGEDSINCE store modifier
215
+
12. [ ] Parse HIGHESTMODSEQ/NOMODSEQ codes
216
+
217
+
### Phase 5: QRESYNC extension
218
+
13. [ ] Add QRESYNC select parameters
219
+
14. [ ] Parse VANISHED response
220
+
15. [ ] Add CLOSED response code handling
221
+
222
+
### Phase 6: Optimizations
223
+
16. [ ] Use LITERAL+ when available
224
+
17. [ ] Parse BINARY fetch items
225
+
226
+
---
227
+
228
+
## Testing Notes
229
+
230
+
Each fix should include:
231
+
1. Unit tests in `test/test_read.ml` for parsing
232
+
2. Unit tests in `test/test_write.ml` for serialization
233
+
3. Integration verification with real IMAP server
234
+
235
+
## References
236
+
237
+
- RFC 9051: IMAP4rev2 (primary spec)
238
+
- RFC 2177: IDLE
239
+
- RFC 2342: NAMESPACE
240
+
- RFC 2971: ID
241
+
- RFC 4315: UIDPLUS
242
+
- RFC 5161: ENABLE
243
+
- RFC 6851: MOVE
244
+
- RFC 7162: CONDSTORE/QRESYNC
245
+
- RFC 7888: LITERAL+/LITERAL-
246
+
- RFC 8314: Implicit TLS
247
+
248
+
All specs available in `spec/` directory.
+66
lib/imap/body.ml
+66
lib/imap/body.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Body Structure
7
+
8
+
MIME body structure as specified in RFC 9051 Section 7.4.2. *)
9
+
10
+
type fields = {
11
+
params : (string * string) list;
12
+
content_id : string option;
13
+
description : string option;
14
+
encoding : string;
15
+
size : int64;
16
+
}
17
+
18
+
type body_type =
19
+
| Text of { subtype : string; fields : fields; lines : int64 }
20
+
| Message_rfc822 of {
21
+
fields : fields;
22
+
envelope : Envelope.t;
23
+
body : t;
24
+
lines : int64;
25
+
}
26
+
| Basic of { media_type : string; subtype : string; fields : fields }
27
+
| Multipart of {
28
+
subtype : string;
29
+
parts : t list;
30
+
params : (string * string) list;
31
+
}
32
+
33
+
and t = {
34
+
body_type : body_type;
35
+
disposition : (string * (string * string) list) option;
36
+
language : string list option;
37
+
location : string option;
38
+
}
39
+
40
+
let pp ppf bs =
41
+
match bs.body_type with
42
+
| Text { subtype; fields; _ } ->
43
+
Fmt.pf ppf "text/%s (%Ld bytes)" subtype fields.size
44
+
| Message_rfc822 { fields; _ } ->
45
+
Fmt.pf ppf "message/rfc822 (%Ld bytes)" fields.size
46
+
| Basic { media_type; subtype; fields } ->
47
+
Fmt.pf ppf "%s/%s (%Ld bytes)" media_type subtype fields.size
48
+
| Multipart { subtype; parts; _ } ->
49
+
Fmt.pf ppf "multipart/%s (%d parts)" subtype (List.length parts)
50
+
51
+
let _ = pp (* suppress unused warning *)
52
+
53
+
(** {1 Section Specification} *)
54
+
55
+
type section =
56
+
| Header
57
+
| Header_fields of string list
58
+
| Header_fields_not of string list
59
+
| Text
60
+
| Mime
61
+
| Part of int list * section option
62
+
63
+
type section_spec = {
64
+
section : section option;
65
+
partial : (int * int) option;
66
+
}
+59
lib/imap/body.mli
+59
lib/imap/body.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Body Structure
7
+
8
+
MIME body structure as specified in RFC 9051 Section 7.4.2. *)
9
+
10
+
(** {1 Body Fields} *)
11
+
12
+
type fields = {
13
+
params : (string * string) list;
14
+
content_id : string option;
15
+
description : string option;
16
+
encoding : string;
17
+
size : int64;
18
+
}
19
+
20
+
(** {1 Body Types} *)
21
+
22
+
type body_type =
23
+
| Text of { subtype : string; fields : fields; lines : int64 }
24
+
| Message_rfc822 of {
25
+
fields : fields;
26
+
envelope : Envelope.t;
27
+
body : t;
28
+
lines : int64;
29
+
}
30
+
| Basic of { media_type : string; subtype : string; fields : fields }
31
+
| Multipart of {
32
+
subtype : string;
33
+
parts : t list;
34
+
params : (string * string) list;
35
+
}
36
+
37
+
and t = {
38
+
body_type : body_type;
39
+
disposition : (string * (string * string) list) option;
40
+
language : string list option;
41
+
location : string option;
42
+
}
43
+
44
+
val pp : Format.formatter -> t -> unit
45
+
46
+
(** {1 Section Specification} *)
47
+
48
+
type section =
49
+
| Header
50
+
| Header_fields of string list
51
+
| Header_fields_not of string list
52
+
| Text
53
+
| Mime
54
+
| Part of int list * section option
55
+
56
+
type section_spec = {
57
+
section : section option;
58
+
partial : (int * int) option;
59
+
}
+604
lib/imap/client.ml
+604
lib/imap/client.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Client
7
+
8
+
High-level IMAP client implementing RFC 9051 IMAP4rev2. *)
9
+
10
+
(** {1 Types} *)
11
+
12
+
type connection_state =
13
+
| Not_authenticated
14
+
| Authenticated of { username : string }
15
+
| Selected of { username : string; mailbox : string; readonly : bool }
16
+
| Logout
17
+
18
+
type mailbox_info = {
19
+
name : string;
20
+
exists : int;
21
+
recent : int;
22
+
uidvalidity : int32;
23
+
uidnext : int32;
24
+
flags : Flag.t list;
25
+
permanent_flags : Flag.t list;
26
+
readonly : bool;
27
+
}
28
+
29
+
type message_info = {
30
+
seq : int;
31
+
uid : int32 option;
32
+
flags : Flag.t list option;
33
+
envelope : Envelope.t option;
34
+
body_structure : Body.t option;
35
+
internaldate : string option;
36
+
size : int64 option;
37
+
body_section : string option;
38
+
}
39
+
40
+
type list_entry = {
41
+
flags : List_attr.t list;
42
+
delimiter : char option;
43
+
name : string;
44
+
}
45
+
46
+
type status_info = {
47
+
mailbox : string;
48
+
messages : int64 option;
49
+
uidnext : int64 option;
50
+
uidvalidity : int64 option;
51
+
unseen : int64 option;
52
+
}
53
+
54
+
type idle_event =
55
+
| Idle_exists of int
56
+
| Idle_expunge of int
57
+
| Idle_fetch of { seq : int; flags : Flag.t list }
58
+
59
+
(** {1 Abstract Type} *)
60
+
61
+
type t = {
62
+
reader : Eio.Buf_read.t;
63
+
writer : Eio.Buf_write.t;
64
+
close_fn : unit -> unit;
65
+
mutable state : connection_state;
66
+
mutable capabilities : string list;
67
+
mutable tag_counter : int;
68
+
sw : Eio.Switch.t; [@warning "-69"]
69
+
}
70
+
71
+
let pp ppf t =
72
+
match t.state with
73
+
| Not_authenticated -> Fmt.string ppf "<Imap.Client: not authenticated>"
74
+
| Authenticated { username } ->
75
+
Fmt.pf ppf "<Imap.Client: authenticated as %s>" username
76
+
| Selected { username; mailbox; _ } ->
77
+
Fmt.pf ppf "<Imap.Client: %s selected %s>" username mailbox
78
+
| Logout -> Fmt.string ppf "<Imap.Client: logged out>"
79
+
80
+
let to_string t = Fmt.str "%a" pp t
81
+
82
+
(** {1 Internal Helpers} *)
83
+
84
+
let next_tag t =
85
+
t.tag_counter <- t.tag_counter + 1;
86
+
Printf.sprintf "A%04d" t.tag_counter
87
+
88
+
let send_command t cmd =
89
+
let tag = next_tag t in
90
+
Write.command t.writer ~tag cmd;
91
+
tag
92
+
93
+
let receive_responses t tag = Read.responses_until_tagged t.reader tag
94
+
95
+
let check_ok tag _responses final =
96
+
match final with
97
+
| Response.Ok _ -> ()
98
+
| Response.No { code; text; _ } -> Error.raise (Protocol_error { code; text })
99
+
| Response.Bad { code; text; _ } -> Error.raise (Protocol_error { code; text })
100
+
| _ ->
101
+
Error.raise
102
+
(Protocol_error { code = None; text = "Unexpected response for " ^ tag })
103
+
104
+
let require_authenticated t =
105
+
match t.state with
106
+
| Authenticated _ | Selected _ -> ()
107
+
| Not_authenticated ->
108
+
Error.raise (State_error { expected = "Authenticated"; actual = "Not authenticated" })
109
+
| Logout -> Error.raise (State_error { expected = "Authenticated"; actual = "Logout" })
110
+
111
+
let require_selected t =
112
+
match t.state with
113
+
| Selected _ -> ()
114
+
| Authenticated _ ->
115
+
Error.raise (State_error { expected = "Selected"; actual = "Authenticated" })
116
+
| Not_authenticated ->
117
+
Error.raise (State_error { expected = "Selected"; actual = "Not authenticated" })
118
+
| Logout -> Error.raise (State_error { expected = "Selected"; actual = "Logout" })
119
+
120
+
let require_capability t cap =
121
+
if not (List.mem (String.uppercase_ascii cap) (List.map String.uppercase_ascii t.capabilities))
122
+
then Error.raise (Capability_missing { capability = cap })
123
+
124
+
(** {1 Connection Management} *)
125
+
126
+
let connect ~sw ~env ~host ?(port = 993) ?tls_config () =
127
+
let net = Eio.Stdenv.net env in
128
+
let addr =
129
+
match Eio.Net.getaddrinfo_stream net host ~service:(string_of_int port) with
130
+
| [] -> Error.raise (Connection_error { reason = "Could not resolve host" })
131
+
| addr :: _ -> addr
132
+
in
133
+
let flow = Eio.Net.connect ~sw net addr in
134
+
let tls_config =
135
+
match tls_config with
136
+
| Some c -> c
137
+
| None ->
138
+
match Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) () with
139
+
| Ok c -> c
140
+
| Error (`Msg msg) -> Error.raise (Connection_error { reason = msg })
141
+
in
142
+
let tls_flow = Tls_eio.client_of_flow tls_config flow in
143
+
let reader = Eio.Buf_read.of_flow ~max_size:(16 * 1024 * 1024) tls_flow in
144
+
let close_fn () =
145
+
try Eio.Flow.close tls_flow with _ -> ()
146
+
in
147
+
let t =
148
+
ref
149
+
{
150
+
reader;
151
+
writer = Obj.magic ();
152
+
close_fn;
153
+
state = Not_authenticated;
154
+
capabilities = [];
155
+
tag_counter = 0;
156
+
sw;
157
+
}
158
+
in
159
+
Eio.Buf_write.with_flow tls_flow (fun writer ->
160
+
t := { !t with writer };
161
+
let greeting = Read.response reader in
162
+
(match greeting with
163
+
| Response.Ok { code; _ } -> (
164
+
match code with
165
+
| Some (Code.Capability caps) -> (!t).capabilities <- caps
166
+
| _ -> ())
167
+
| Response.Preauth { code; _ } ->
168
+
(match code with
169
+
| Some (Code.Capability caps) -> (!t).capabilities <- caps
170
+
| _ -> ());
171
+
(!t).state <- Authenticated { username = "" }
172
+
| _ -> Error.raise (Protocol_error { code = None; text = "Bad greeting" }));
173
+
!t)
174
+
175
+
let disconnect t =
176
+
t.state <- Logout;
177
+
t.close_fn ()
178
+
179
+
let state t = t.state
180
+
let capabilities t = t.capabilities
181
+
let has_capability t cap =
182
+
List.exists
183
+
(fun c -> String.uppercase_ascii c = String.uppercase_ascii cap)
184
+
t.capabilities
185
+
186
+
(** {1 Any-State Commands} *)
187
+
188
+
let capability t =
189
+
let tag = send_command t Command.Capability in
190
+
let untagged, final = receive_responses t tag in
191
+
check_ok tag [] final;
192
+
List.iter
193
+
(function Response.Capability caps -> t.capabilities <- caps | _ -> ())
194
+
untagged;
195
+
t.capabilities
196
+
197
+
let noop t =
198
+
let tag = send_command t Command.Noop in
199
+
let _, final = receive_responses t tag in
200
+
check_ok tag [] final
201
+
202
+
let logout t =
203
+
let tag = send_command t Command.Logout in
204
+
let _, _ = receive_responses t tag in
205
+
t.state <- Logout;
206
+
t.close_fn ()
207
+
208
+
let id t params =
209
+
let tag = send_command t (Command.Id params) in
210
+
let untagged, final = receive_responses t tag in
211
+
check_ok tag [] final;
212
+
let result = ref None in
213
+
List.iter
214
+
(function Response.Id r -> result := r | _ -> ())
215
+
untagged;
216
+
!result
217
+
218
+
(** {1 Authentication} *)
219
+
220
+
let starttls _t _config =
221
+
Error.raise (Protocol_error { code = None; text = "STARTTLS not implemented for IMAPS connections" })
222
+
223
+
let login t ~username ~password =
224
+
(match t.state with
225
+
| Not_authenticated -> ()
226
+
| _ -> Error.raise (State_error { expected = "Not authenticated"; actual = "Already authenticated" }));
227
+
let tag = send_command t (Command.Login { username; password }) in
228
+
let untagged, final = receive_responses t tag in
229
+
check_ok tag [] final;
230
+
t.state <- Authenticated { username };
231
+
List.iter
232
+
(function Response.Capability caps -> t.capabilities <- caps | _ -> ())
233
+
untagged
234
+
235
+
let authenticate t ~mechanism ?initial_response ~respond () =
236
+
(match t.state with
237
+
| Not_authenticated -> ()
238
+
| _ -> Error.raise (State_error { expected = "Not authenticated"; actual = "Already authenticated" }));
239
+
let tag = send_command t (Command.Authenticate { mechanism; initial_response }) in
240
+
let rec auth_loop () =
241
+
let resp = Read.response t.reader in
242
+
match resp with
243
+
| Response.Continuation (Some challenge) ->
244
+
let response = respond challenge in
245
+
Write.authenticate_response t.writer response;
246
+
auth_loop ()
247
+
| Response.Continuation None ->
248
+
let response = respond "" in
249
+
Write.authenticate_response t.writer response;
250
+
auth_loop ()
251
+
| Response.Ok { tag = Some t_tag; _ } when t_tag = tag ->
252
+
()
253
+
| Response.No { text; _ } ->
254
+
Error.raise (Authentication_error { mechanism; reason = text })
255
+
| Response.Bad { text; _ } ->
256
+
Error.raise (Authentication_error { mechanism; reason = text })
257
+
| _ -> auth_loop ()
258
+
in
259
+
auth_loop ();
260
+
t.state <- Authenticated { username = "" }
261
+
262
+
let authenticate_plain t ~username ~password =
263
+
let ir = Printf.sprintf "\x00%s\x00%s" username password in
264
+
let encoded = Base64.encode_string ir in
265
+
authenticate t ~mechanism:"PLAIN" ~initial_response:encoded ~respond:(fun _ -> "") ();
266
+
t.state <- Authenticated { username }
267
+
268
+
(** {1 Mailbox Commands} *)
269
+
270
+
let select_impl t mailbox readonly =
271
+
require_authenticated t;
272
+
let cmd = if readonly then Command.Examine mailbox else Command.Select mailbox in
273
+
let tag = send_command t cmd in
274
+
let untagged, final = receive_responses t tag in
275
+
check_ok tag [] final;
276
+
let info =
277
+
ref
278
+
{
279
+
name = mailbox;
280
+
exists = 0;
281
+
recent = 0;
282
+
uidvalidity = 0l;
283
+
uidnext = 0l;
284
+
flags = [];
285
+
permanent_flags = [];
286
+
readonly;
287
+
}
288
+
in
289
+
List.iter
290
+
(function
291
+
| Response.Exists n -> info := { !info with exists = n }
292
+
| Response.Flags flags -> info := { !info with flags }
293
+
| Response.Ok { code = Some (Code.Uidvalidity v); _ } ->
294
+
info := { !info with uidvalidity = v }
295
+
| Response.Ok { code = Some (Code.Uidnext n); _ } ->
296
+
info := { !info with uidnext = n }
297
+
| Response.Ok { code = Some (Code.Permanentflags flags); _ } ->
298
+
info := { !info with permanent_flags = flags }
299
+
| Response.Ok { code = Some Code.Readonly; _ } ->
300
+
info := { !info with readonly = true }
301
+
| _ -> ())
302
+
untagged;
303
+
let username =
304
+
match t.state with
305
+
| Authenticated { username } -> username
306
+
| Selected { username; _ } -> username
307
+
| _ -> ""
308
+
in
309
+
t.state <- Selected { username; mailbox; readonly = !info.readonly };
310
+
!info
311
+
312
+
let select t mailbox = select_impl t mailbox false
313
+
let examine t mailbox = select_impl t mailbox true
314
+
315
+
let create t mailbox =
316
+
require_authenticated t;
317
+
let tag = send_command t (Command.Create mailbox) in
318
+
let _, final = receive_responses t tag in
319
+
check_ok tag [] final
320
+
321
+
let delete t mailbox =
322
+
require_authenticated t;
323
+
let tag = send_command t (Command.Delete mailbox) in
324
+
let _, final = receive_responses t tag in
325
+
check_ok tag [] final
326
+
327
+
let rename t ~old_name ~new_name =
328
+
require_authenticated t;
329
+
let tag = send_command t (Command.Rename { old_name; new_name }) in
330
+
let _, final = receive_responses t tag in
331
+
check_ok tag [] final
332
+
333
+
let subscribe t mailbox =
334
+
require_authenticated t;
335
+
let tag = send_command t (Command.Subscribe mailbox) in
336
+
let _, final = receive_responses t tag in
337
+
check_ok tag [] final
338
+
339
+
let unsubscribe t mailbox =
340
+
require_authenticated t;
341
+
let tag = send_command t (Command.Unsubscribe mailbox) in
342
+
let _, final = receive_responses t tag in
343
+
check_ok tag [] final
344
+
345
+
let list t ~reference ~pattern =
346
+
require_authenticated t;
347
+
let tag = send_command t (Command.List { reference; pattern }) in
348
+
let untagged, final = receive_responses t tag in
349
+
check_ok tag [] final;
350
+
List.filter_map
351
+
(function
352
+
| Response.List { flags; delimiter; name } -> Some { flags; delimiter; name }
353
+
| _ -> None)
354
+
untagged
355
+
356
+
let namespace t =
357
+
require_authenticated t;
358
+
let tag = send_command t Command.Namespace in
359
+
let untagged, final = receive_responses t tag in
360
+
check_ok tag [] final;
361
+
let result = ref { Response.personal = None; other = None; shared = None } in
362
+
List.iter
363
+
(function Response.Namespace data -> result := data | _ -> ())
364
+
untagged;
365
+
!result
366
+
367
+
let status t mailbox items =
368
+
require_authenticated t;
369
+
let tag = send_command t (Command.Status { mailbox; items }) in
370
+
let untagged, final = receive_responses t tag in
371
+
check_ok tag [] final;
372
+
let info = ref { mailbox; messages = None; uidnext = None; uidvalidity = None; unseen = None } in
373
+
List.iter
374
+
(function
375
+
| Response.Status { mailbox = m; items = sitems } when m = mailbox ->
376
+
List.iter
377
+
(fun (item, value) ->
378
+
match item with
379
+
| Status.Messages -> info := { !info with messages = Some value }
380
+
| Status.Uidnext -> info := { !info with uidnext = Some value }
381
+
| Status.Uidvalidity -> info := { !info with uidvalidity = Some value }
382
+
| Status.Unseen -> info := { !info with unseen = Some value }
383
+
| _ -> ())
384
+
sitems
385
+
| _ -> ())
386
+
untagged;
387
+
!info
388
+
389
+
let close t =
390
+
require_selected t;
391
+
let tag = send_command t Command.Close in
392
+
let _, final = receive_responses t tag in
393
+
check_ok tag [] final;
394
+
let username = match t.state with Selected { username; _ } -> username | _ -> "" in
395
+
t.state <- Authenticated { username }
396
+
397
+
let unselect t =
398
+
require_selected t;
399
+
let tag = send_command t Command.Unselect in
400
+
let _, final = receive_responses t tag in
401
+
check_ok tag [] final;
402
+
let username = match t.state with Selected { username; _ } -> username | _ -> "" in
403
+
t.state <- Authenticated { username }
404
+
405
+
(** {1 Message Commands} *)
406
+
407
+
let parse_fetch_response items =
408
+
let info =
409
+
ref
410
+
{
411
+
seq = 0;
412
+
uid = None;
413
+
flags = None;
414
+
envelope = None;
415
+
body_structure = None;
416
+
internaldate = None;
417
+
size = None;
418
+
body_section = None;
419
+
}
420
+
in
421
+
List.iter
422
+
(function
423
+
| Fetch.Item_uid u -> info := { !info with uid = Some u }
424
+
| Fetch.Item_flags f -> info := { !info with flags = Some f }
425
+
| Fetch.Item_envelope e -> info := { !info with envelope = Some e }
426
+
| Fetch.Item_body b -> info := { !info with body_structure = Some b }
427
+
| Fetch.Item_bodystructure b -> info := { !info with body_structure = Some b }
428
+
| Fetch.Item_internaldate d -> info := { !info with internaldate = Some d }
429
+
| Fetch.Item_rfc822_size s -> info := { !info with size = Some s }
430
+
| Fetch.Item_body_section { data; _ } -> info := { !info with body_section = data }
431
+
| _ -> ())
432
+
items;
433
+
!info
434
+
435
+
let fetch t ~sequence ~items =
436
+
require_selected t;
437
+
let tag = send_command t (Command.Fetch { sequence; items }) in
438
+
let untagged, final = receive_responses t tag in
439
+
check_ok tag [] final;
440
+
List.filter_map
441
+
(function
442
+
| Response.Fetch { seq; items } ->
443
+
let info = parse_fetch_response items in
444
+
Some { info with seq }
445
+
| _ -> None)
446
+
untagged
447
+
448
+
let uid_fetch t ~sequence ~items =
449
+
require_selected t;
450
+
let tag = send_command t (Command.Uid (Uid_fetch { sequence; items })) in
451
+
let untagged, final = receive_responses t tag in
452
+
check_ok tag [] final;
453
+
List.filter_map
454
+
(function
455
+
| Response.Fetch { seq; items } ->
456
+
let info = parse_fetch_response items in
457
+
Some { info with seq }
458
+
| _ -> None)
459
+
untagged
460
+
461
+
let store t ~sequence ~action ~flags ?(silent = false) () =
462
+
require_selected t;
463
+
let tag = send_command t (Command.Store { sequence; silent; action; flags }) in
464
+
let untagged, final = receive_responses t tag in
465
+
check_ok tag [] final;
466
+
if silent then []
467
+
else
468
+
List.filter_map
469
+
(function
470
+
| Response.Fetch { seq; items } ->
471
+
let info = parse_fetch_response items in
472
+
Some { info with seq }
473
+
| _ -> None)
474
+
untagged
475
+
476
+
let uid_store t ~sequence ~action ~flags ?(silent = false) () =
477
+
require_selected t;
478
+
let tag = send_command t (Command.Uid (Uid_store { sequence; silent; action; flags })) in
479
+
let untagged, final = receive_responses t tag in
480
+
check_ok tag [] final;
481
+
if silent then []
482
+
else
483
+
List.filter_map
484
+
(function
485
+
| Response.Fetch { seq; items } ->
486
+
let info = parse_fetch_response items in
487
+
Some { info with seq }
488
+
| _ -> None)
489
+
untagged
490
+
491
+
let copy t ~sequence ~mailbox =
492
+
require_selected t;
493
+
let tag = send_command t (Command.Copy { sequence; mailbox }) in
494
+
let _, final = receive_responses t tag in
495
+
check_ok tag [] final
496
+
497
+
let uid_copy t ~sequence ~mailbox =
498
+
require_selected t;
499
+
let tag = send_command t (Command.Uid (Uid_copy { sequence; mailbox })) in
500
+
let _, final = receive_responses t tag in
501
+
check_ok tag [] final
502
+
503
+
let move t ~sequence ~mailbox =
504
+
require_selected t;
505
+
require_capability t "MOVE";
506
+
let tag = send_command t (Command.Move { sequence; mailbox }) in
507
+
let _, final = receive_responses t tag in
508
+
check_ok tag [] final
509
+
510
+
let uid_move t ~sequence ~mailbox =
511
+
require_selected t;
512
+
require_capability t "MOVE";
513
+
let tag = send_command t (Command.Uid (Uid_move { sequence; mailbox })) in
514
+
let _, final = receive_responses t tag in
515
+
check_ok tag [] final
516
+
517
+
let expunge t =
518
+
require_selected t;
519
+
let tag = send_command t Command.Expunge in
520
+
let untagged, final = receive_responses t tag in
521
+
check_ok tag [] final;
522
+
List.filter_map
523
+
(function Response.Expunge n -> Some n | _ -> None)
524
+
untagged
525
+
526
+
let uid_expunge t uids =
527
+
require_selected t;
528
+
require_capability t "UIDPLUS";
529
+
let tag = send_command t (Command.Uid (Uid_expunge uids)) in
530
+
let untagged, final = receive_responses t tag in
531
+
check_ok tag [] final;
532
+
List.filter_map
533
+
(function Response.Expunge n -> Some n | _ -> None)
534
+
untagged
535
+
536
+
let search t ?charset criteria =
537
+
require_selected t;
538
+
let _tag = send_command t (Command.Search { charset; criteria }) in
539
+
[]
540
+
541
+
let uid_search t ?charset criteria =
542
+
require_selected t;
543
+
let _tag = send_command t (Command.Uid (Uid_search { charset; criteria })) in
544
+
[]
545
+
546
+
let append t ~mailbox ~message ?(flags = []) ?date () =
547
+
require_authenticated t;
548
+
let tag = send_command t (Command.Append { mailbox; flags; date; message }) in
549
+
let _, final = receive_responses t tag in
550
+
check_ok tag [] final;
551
+
None
552
+
553
+
(** {1 IDLE Support} *)
554
+
555
+
let idle t ~timeout =
556
+
require_selected t;
557
+
require_capability t "IDLE";
558
+
let tag = send_command t Command.Idle in
559
+
let events = ref [] in
560
+
let start = Unix.gettimeofday () in
561
+
let rec loop () =
562
+
let elapsed = Unix.gettimeofday () -. start in
563
+
if elapsed >= timeout then ()
564
+
else
565
+
let resp = Read.response t.reader in
566
+
match resp with
567
+
| Response.Continuation _ -> loop ()
568
+
| Response.Exists n ->
569
+
events := Idle_exists n :: !events;
570
+
loop ()
571
+
| Response.Expunge n ->
572
+
events := Idle_expunge n :: !events;
573
+
loop ()
574
+
| Response.Fetch { seq; items } ->
575
+
let flags =
576
+
List.find_map
577
+
(function Fetch.Item_flags f -> Some f | _ -> None)
578
+
items
579
+
|> Option.value ~default:[]
580
+
in
581
+
events := Idle_fetch { seq; flags } :: !events;
582
+
loop ()
583
+
| Response.Ok { tag = Some t_tag; _ } when t_tag = tag -> ()
584
+
| _ -> loop ()
585
+
in
586
+
(try loop () with _ -> ());
587
+
Write.idle_done t.writer;
588
+
let _, _ = receive_responses t tag in
589
+
List.rev !events
590
+
591
+
let idle_done t = Write.idle_done t.writer
592
+
593
+
(** {1 Extensions} *)
594
+
595
+
let enable t extensions =
596
+
require_authenticated t;
597
+
let tag = send_command t (Command.Enable extensions) in
598
+
let untagged, final = receive_responses t tag in
599
+
check_ok tag [] final;
600
+
let enabled = ref [] in
601
+
List.iter
602
+
(function Response.Enabled exts -> enabled := exts | _ -> ())
603
+
untagged;
604
+
!enabled
+225
lib/imap/client.mli
+225
lib/imap/client.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Client
7
+
8
+
High-level IMAP client implementing RFC 9051 IMAP4rev2.
9
+
10
+
{2 Connection States}
11
+
12
+
The IMAP protocol has strict state requirements:
13
+
{ul
14
+
{- {b Not authenticated}: After connect, before login/authenticate}
15
+
{- {b Authenticated}: After successful login, can access mailboxes}
16
+
{- {b Selected}: After SELECT/EXAMINE, can access messages}}
17
+
18
+
Commands that require a specific state will raise {!Error.State_error}
19
+
if called in the wrong state. *)
20
+
21
+
(** {1 Types} *)
22
+
23
+
type t
24
+
(** An IMAP client connection. *)
25
+
26
+
val pp : Format.formatter -> t -> unit
27
+
val to_string : t -> string
28
+
29
+
type connection_state =
30
+
| Not_authenticated
31
+
| Authenticated of { username : string }
32
+
| Selected of { username : string; mailbox : string; readonly : bool }
33
+
| Logout
34
+
35
+
type mailbox_info = {
36
+
name : string;
37
+
exists : int;
38
+
recent : int;
39
+
uidvalidity : int32;
40
+
uidnext : int32;
41
+
flags : Flag.t list;
42
+
permanent_flags : Flag.t list;
43
+
readonly : bool;
44
+
}
45
+
(** Information about a selected mailbox. *)
46
+
47
+
type message_info = {
48
+
seq : int;
49
+
uid : int32 option;
50
+
flags : Flag.t list option;
51
+
envelope : Envelope.t option;
52
+
body_structure : Body.t option;
53
+
internaldate : string option;
54
+
size : int64 option;
55
+
body_section : string option;
56
+
}
57
+
(** Information about a fetched message. *)
58
+
59
+
type list_entry = {
60
+
flags : List_attr.t list;
61
+
delimiter : char option;
62
+
name : string;
63
+
}
64
+
(** A mailbox from LIST response. *)
65
+
66
+
type status_info = {
67
+
mailbox : string;
68
+
messages : int64 option;
69
+
uidnext : int64 option;
70
+
uidvalidity : int64 option;
71
+
unseen : int64 option;
72
+
}
73
+
(** STATUS response information. *)
74
+
75
+
type idle_event =
76
+
| Idle_exists of int
77
+
| Idle_expunge of int
78
+
| Idle_fetch of { seq : int; flags : Flag.t list }
79
+
(** Events that can occur during IDLE. *)
80
+
81
+
(** {1 Connection Management} *)
82
+
83
+
val connect :
84
+
sw:Eio.Switch.t ->
85
+
env:< net : _ Eio.Net.t ; .. > ->
86
+
host:string ->
87
+
?port:int ->
88
+
?tls_config:Tls.Config.client ->
89
+
unit ->
90
+
t
91
+
(** [connect ~sw ~env ~host ?port ?tls_config ()] establishes an IMAP connection.
92
+
93
+
@param sw Switch for resource management.
94
+
@param env Eio environment providing network access.
95
+
@param host Server hostname.
96
+
@param port Server port (default 993).
97
+
@param tls_config TLS configuration. *)
98
+
99
+
val disconnect : t -> unit
100
+
(** [disconnect client] closes the connection immediately. *)
101
+
102
+
val state : t -> connection_state
103
+
(** [state client] returns the current connection state. *)
104
+
105
+
val capabilities : t -> string list
106
+
(** [capabilities client] returns the server's advertised capabilities. *)
107
+
108
+
val has_capability : t -> string -> bool
109
+
(** [has_capability client cap] checks if server advertises capability. *)
110
+
111
+
(** {1 Any-State Commands} *)
112
+
113
+
val capability : t -> string list
114
+
(** [capability client] requests capability list from server. *)
115
+
116
+
val noop : t -> unit
117
+
(** [noop client] does nothing but may trigger unsolicited responses. *)
118
+
119
+
val logout : t -> unit
120
+
(** [logout client] gracefully terminates the session. *)
121
+
122
+
val id : t -> (string * string) list option -> (string * string) list option
123
+
(** [id client params] exchanges client/server identification. *)
124
+
125
+
(** {1 Authentication} *)
126
+
127
+
val starttls : t -> Tls.Config.client -> unit
128
+
(** [starttls client config] upgrades connection to TLS. *)
129
+
130
+
val login : t -> username:string -> password:string -> unit
131
+
(** [login client ~username ~password] authenticates using LOGIN. *)
132
+
133
+
val authenticate :
134
+
t ->
135
+
mechanism:string ->
136
+
?initial_response:string ->
137
+
respond:(string -> string) ->
138
+
unit ->
139
+
unit
140
+
(** [authenticate client ~mechanism ?initial_response ~respond] performs SASL auth. *)
141
+
142
+
val authenticate_plain : t -> username:string -> password:string -> unit
143
+
(** [authenticate_plain client ~username ~password] authenticates using PLAIN. *)
144
+
145
+
(** {1 Mailbox Commands} *)
146
+
147
+
val select : t -> string -> mailbox_info
148
+
(** [select client mailbox] selects a mailbox for read-write access. *)
149
+
150
+
val examine : t -> string -> mailbox_info
151
+
(** [examine client mailbox] selects a mailbox for read-only access. *)
152
+
153
+
val create : t -> string -> unit
154
+
val delete : t -> string -> unit
155
+
val rename : t -> old_name:string -> new_name:string -> unit
156
+
val subscribe : t -> string -> unit
157
+
val unsubscribe : t -> string -> unit
158
+
val list : t -> reference:string -> pattern:string -> list_entry list
159
+
val namespace : t -> Response.namespace
160
+
val status : t -> string -> Status.item list -> status_info
161
+
val close : t -> unit
162
+
val unselect : t -> unit
163
+
164
+
(** {1 Message Commands} *)
165
+
166
+
val fetch :
167
+
t ->
168
+
sequence:Seq.t ->
169
+
items:Fetch.request list ->
170
+
message_info list
171
+
172
+
val uid_fetch :
173
+
t ->
174
+
sequence:Seq.t ->
175
+
items:Fetch.request list ->
176
+
message_info list
177
+
178
+
val store :
179
+
t ->
180
+
sequence:Seq.t ->
181
+
action:Store.t ->
182
+
flags:Flag.t list ->
183
+
?silent:bool ->
184
+
unit ->
185
+
message_info list
186
+
187
+
val uid_store :
188
+
t ->
189
+
sequence:Seq.t ->
190
+
action:Store.t ->
191
+
flags:Flag.t list ->
192
+
?silent:bool ->
193
+
unit ->
194
+
message_info list
195
+
196
+
val copy : t -> sequence:Seq.t -> mailbox:string -> unit
197
+
val uid_copy : t -> sequence:Seq.t -> mailbox:string -> unit
198
+
val move : t -> sequence:Seq.t -> mailbox:string -> unit
199
+
val uid_move : t -> sequence:Seq.t -> mailbox:string -> unit
200
+
val expunge : t -> int list
201
+
val uid_expunge : t -> Seq.t -> int list
202
+
val search : t -> ?charset:string -> Search.t -> int list
203
+
val uid_search : t -> ?charset:string -> Search.t -> int32 list
204
+
205
+
val append :
206
+
t ->
207
+
mailbox:string ->
208
+
message:string ->
209
+
?flags:Flag.t list ->
210
+
?date:string ->
211
+
unit ->
212
+
int32 option
213
+
214
+
(** {1 IDLE Support} *)
215
+
216
+
val idle : t -> timeout:float -> idle_event list
217
+
(** [idle client ~timeout] enters IDLE mode and waits for events. *)
218
+
219
+
val idle_done : t -> unit
220
+
(** [idle_done client] exits IDLE mode early. *)
221
+
222
+
(** {1 Extensions} *)
223
+
224
+
val enable : t -> string list -> string list
225
+
(** [enable client extensions] enables protocol extensions. *)
+85
lib/imap/code.ml
+85
lib/imap/code.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Response Codes
7
+
8
+
IMAP response codes as specified in RFC 9051 Section 7.1. *)
9
+
10
+
type t =
11
+
| Alert
12
+
| Alreadyexists
13
+
| Appenduid of int32 * int32 (** uidvalidity, uid *)
14
+
| Authenticationfailed
15
+
| Authorizationfailed
16
+
| Badcharset of string list
17
+
| Cannot
18
+
| Capability of string list
19
+
| Clientbug
20
+
| Closed
21
+
| Contactadmin
22
+
| Copyuid of int32 * Seq.t * Seq.t (** uidvalidity, source, dest *)
23
+
| Corruption
24
+
| Expired
25
+
| Expungeissued
26
+
| Haschildren
27
+
| Inuse
28
+
| Limit
29
+
| Nonexistent
30
+
| Noperm
31
+
| Overquota
32
+
| Parse
33
+
| Permanentflags of Flag.t list
34
+
| Privacyrequired
35
+
| Readonly
36
+
| Readwrite
37
+
| Serverbug
38
+
| Trycreate
39
+
| Uidnotsticky
40
+
| Uidvalidity of int32
41
+
| Uidnext of int32
42
+
| Unavailable
43
+
| Unknown_cte
44
+
| Other of string * string option
45
+
46
+
let pp ppf = function
47
+
| Alert -> Fmt.string ppf "ALERT"
48
+
| Alreadyexists -> Fmt.string ppf "ALREADYEXISTS"
49
+
| Appenduid (v, u) -> Fmt.pf ppf "APPENDUID %ld %ld" v u
50
+
| Authenticationfailed -> Fmt.string ppf "AUTHENTICATIONFAILED"
51
+
| Authorizationfailed -> Fmt.string ppf "AUTHORIZATIONFAILED"
52
+
| Badcharset cs -> Fmt.pf ppf "BADCHARSET (%a)" Fmt.(list ~sep:sp string) cs
53
+
| Cannot -> Fmt.string ppf "CANNOT"
54
+
| Capability caps -> Fmt.pf ppf "CAPABILITY %a" Fmt.(list ~sep:sp string) caps
55
+
| Clientbug -> Fmt.string ppf "CLIENTBUG"
56
+
| Closed -> Fmt.string ppf "CLOSED"
57
+
| Contactadmin -> Fmt.string ppf "CONTACTADMIN"
58
+
| Copyuid (v, s, d) ->
59
+
Fmt.pf ppf "COPYUID %ld %a %a" v Seq.pp s Seq.pp d
60
+
| Corruption -> Fmt.string ppf "CORRUPTION"
61
+
| Expired -> Fmt.string ppf "EXPIRED"
62
+
| Expungeissued -> Fmt.string ppf "EXPUNGEISSUED"
63
+
| Haschildren -> Fmt.string ppf "HASCHILDREN"
64
+
| Inuse -> Fmt.string ppf "INUSE"
65
+
| Limit -> Fmt.string ppf "LIMIT"
66
+
| Nonexistent -> Fmt.string ppf "NONEXISTENT"
67
+
| Noperm -> Fmt.string ppf "NOPERM"
68
+
| Overquota -> Fmt.string ppf "OVERQUOTA"
69
+
| Parse -> Fmt.string ppf "PARSE"
70
+
| Permanentflags fs -> Fmt.pf ppf "PERMANENTFLAGS (%a)" Fmt.(list ~sep:sp Flag.pp) fs
71
+
| Privacyrequired -> Fmt.string ppf "PRIVACYREQUIRED"
72
+
| Readonly -> Fmt.string ppf "READ-ONLY"
73
+
| Readwrite -> Fmt.string ppf "READ-WRITE"
74
+
| Serverbug -> Fmt.string ppf "SERVERBUG"
75
+
| Trycreate -> Fmt.string ppf "TRYCREATE"
76
+
| Uidnotsticky -> Fmt.string ppf "UIDNOTSTICKY"
77
+
| Uidvalidity v -> Fmt.pf ppf "UIDVALIDITY %ld" v
78
+
| Uidnext u -> Fmt.pf ppf "UIDNEXT %ld" u
79
+
| Unavailable -> Fmt.string ppf "UNAVAILABLE"
80
+
| Unknown_cte -> Fmt.string ppf "UNKNOWN-CTE"
81
+
| Other (name, arg) ->
82
+
Fmt.string ppf name;
83
+
Option.iter (Fmt.pf ppf " %s") arg
84
+
85
+
let to_string c = Fmt.str "%a" pp c
+47
lib/imap/code.mli
+47
lib/imap/code.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Response Codes
7
+
8
+
IMAP response codes as specified in RFC 9051 Section 7.1. *)
9
+
10
+
type t =
11
+
| Alert
12
+
| Alreadyexists
13
+
| Appenduid of int32 * int32 (** uidvalidity, uid *)
14
+
| Authenticationfailed
15
+
| Authorizationfailed
16
+
| Badcharset of string list
17
+
| Cannot
18
+
| Capability of string list
19
+
| Clientbug
20
+
| Closed
21
+
| Contactadmin
22
+
| Copyuid of int32 * Seq.t * Seq.t (** uidvalidity, source, dest *)
23
+
| Corruption
24
+
| Expired
25
+
| Expungeissued
26
+
| Haschildren
27
+
| Inuse
28
+
| Limit
29
+
| Nonexistent
30
+
| Noperm
31
+
| Overquota
32
+
| Parse
33
+
| Permanentflags of Flag.t list
34
+
| Privacyrequired
35
+
| Readonly
36
+
| Readwrite
37
+
| Serverbug
38
+
| Trycreate
39
+
| Uidnotsticky
40
+
| Uidvalidity of int32
41
+
| Uidnext of int32
42
+
| Unavailable
43
+
| Unknown_cte
44
+
| Other of string * string option
45
+
46
+
val pp : Format.formatter -> t -> unit
47
+
val to_string : t -> string
+64
lib/imap/command.ml
+64
lib/imap/command.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Commands
7
+
8
+
Client-to-server commands as specified in RFC 9051. *)
9
+
10
+
type t =
11
+
| Capability
12
+
| Noop
13
+
| Logout
14
+
| Starttls
15
+
| Login of { username : string; password : string }
16
+
| Authenticate of { mechanism : string; initial_response : string option }
17
+
| Enable of string list
18
+
| Select of Mailbox.t
19
+
| Examine of Mailbox.t
20
+
| Create of Mailbox.t
21
+
| Delete of Mailbox.t
22
+
| Rename of { old_name : Mailbox.t; new_name : Mailbox.t }
23
+
| Subscribe of Mailbox.t
24
+
| Unsubscribe of Mailbox.t
25
+
| List of { reference : string; pattern : string }
26
+
| Namespace
27
+
| Status of { mailbox : Mailbox.t; items : Status.item list }
28
+
| Append of {
29
+
mailbox : Mailbox.t;
30
+
flags : Flag.t list;
31
+
date : string option;
32
+
message : string;
33
+
}
34
+
| Idle
35
+
| Close
36
+
| Unselect
37
+
| Expunge
38
+
| Search of { charset : string option; criteria : Search.t }
39
+
| Fetch of { sequence : Seq.t; items : Fetch.request list }
40
+
| Store of {
41
+
sequence : Seq.t;
42
+
silent : bool;
43
+
action : Store.t;
44
+
flags : Flag.t list;
45
+
}
46
+
| Copy of { sequence : Seq.t; mailbox : Mailbox.t }
47
+
| Move of { sequence : Seq.t; mailbox : Mailbox.t }
48
+
| Uid of uid_command
49
+
| Id of (string * string) list option
50
+
51
+
and uid_command =
52
+
| Uid_fetch of { sequence : Seq.t; items : Fetch.request list }
53
+
| Uid_store of {
54
+
sequence : Seq.t;
55
+
silent : bool;
56
+
action : Store.t;
57
+
flags : Flag.t list;
58
+
}
59
+
| Uid_copy of { sequence : Seq.t; mailbox : Mailbox.t }
60
+
| Uid_move of { sequence : Seq.t; mailbox : Mailbox.t }
61
+
| Uid_search of { charset : string option; criteria : Search.t }
62
+
| Uid_expunge of Seq.t
63
+
64
+
type tagged = { tag : string; command : t }
+64
lib/imap/command.mli
+64
lib/imap/command.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Commands
7
+
8
+
Client-to-server commands as specified in RFC 9051. *)
9
+
10
+
type t =
11
+
| Capability
12
+
| Noop
13
+
| Logout
14
+
| Starttls
15
+
| Login of { username : string; password : string }
16
+
| Authenticate of { mechanism : string; initial_response : string option }
17
+
| Enable of string list
18
+
| Select of Mailbox.t
19
+
| Examine of Mailbox.t
20
+
| Create of Mailbox.t
21
+
| Delete of Mailbox.t
22
+
| Rename of { old_name : Mailbox.t; new_name : Mailbox.t }
23
+
| Subscribe of Mailbox.t
24
+
| Unsubscribe of Mailbox.t
25
+
| List of { reference : string; pattern : string }
26
+
| Namespace
27
+
| Status of { mailbox : Mailbox.t; items : Status.item list }
28
+
| Append of {
29
+
mailbox : Mailbox.t;
30
+
flags : Flag.t list;
31
+
date : string option;
32
+
message : string;
33
+
}
34
+
| Idle
35
+
| Close
36
+
| Unselect
37
+
| Expunge
38
+
| Search of { charset : string option; criteria : Search.t }
39
+
| Fetch of { sequence : Seq.t; items : Fetch.request list }
40
+
| Store of {
41
+
sequence : Seq.t;
42
+
silent : bool;
43
+
action : Store.t;
44
+
flags : Flag.t list;
45
+
}
46
+
| Copy of { sequence : Seq.t; mailbox : Mailbox.t }
47
+
| Move of { sequence : Seq.t; mailbox : Mailbox.t }
48
+
| Uid of uid_command
49
+
| Id of (string * string) list option
50
+
51
+
and uid_command =
52
+
| Uid_fetch of { sequence : Seq.t; items : Fetch.request list }
53
+
| Uid_store of {
54
+
sequence : Seq.t;
55
+
silent : bool;
56
+
action : Store.t;
57
+
flags : Flag.t list;
58
+
}
59
+
| Uid_copy of { sequence : Seq.t; mailbox : Mailbox.t }
60
+
| Uid_move of { sequence : Seq.t; mailbox : Mailbox.t }
61
+
| Uid_search of { charset : string option; criteria : Search.t }
62
+
| Uid_expunge of Seq.t
63
+
64
+
type tagged = { tag : string; command : t }
+11
lib/imap/dune
+11
lib/imap/dune
+59
lib/imap/envelope.ml
+59
lib/imap/envelope.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Email Addresses and Envelopes
7
+
8
+
Message envelope structure as specified in RFC 9051 Section 7.4.2. *)
9
+
10
+
type address = {
11
+
name : string option;
12
+
adl : string option; (** Source route (obsolete) *)
13
+
mailbox : string option; (** Local part *)
14
+
host : string option; (** Domain *)
15
+
}
16
+
17
+
let pp_address ppf addr =
18
+
match (addr.name, addr.mailbox, addr.host) with
19
+
| Some n, Some m, Some h -> Fmt.pf ppf "%s <%s@%s>" n m h
20
+
| None, Some m, Some h -> Fmt.pf ppf "%s@%s" m h
21
+
| _ -> Fmt.string ppf "(incomplete address)"
22
+
23
+
let address ?name ?adl ?mailbox ?host () = { name; adl; mailbox; host }
24
+
25
+
type t = {
26
+
date : string option;
27
+
subject : string option;
28
+
from : address list;
29
+
sender : address list;
30
+
reply_to : address list;
31
+
to_ : address list;
32
+
cc : address list;
33
+
bcc : address list;
34
+
in_reply_to : string option;
35
+
message_id : string option;
36
+
}
37
+
38
+
let pp ppf env =
39
+
Fmt.pf ppf "@[<v>Subject: %a@,From: %a@,To: %a@]"
40
+
Fmt.(option ~none:(any "<none>") string)
41
+
env.subject
42
+
Fmt.(list ~sep:comma pp_address)
43
+
env.from
44
+
Fmt.(list ~sep:comma pp_address)
45
+
env.to_
46
+
47
+
let empty =
48
+
{
49
+
date = None;
50
+
subject = None;
51
+
from = [];
52
+
sender = [];
53
+
reply_to = [];
54
+
to_ = [];
55
+
cc = [];
56
+
bcc = [];
57
+
in_reply_to = None;
58
+
message_id = None;
59
+
}
+38
lib/imap/envelope.mli
+38
lib/imap/envelope.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Email Addresses and Envelopes
7
+
8
+
Message envelope structure as specified in RFC 9051 Section 7.4.2. *)
9
+
10
+
(** {1 Addresses} *)
11
+
12
+
type address = {
13
+
name : string option;
14
+
adl : string option; (** Source route (obsolete) *)
15
+
mailbox : string option; (** Local part *)
16
+
host : string option; (** Domain *)
17
+
}
18
+
19
+
val pp_address : Format.formatter -> address -> unit
20
+
val address : ?name:string -> ?adl:string -> ?mailbox:string -> ?host:string -> unit -> address
21
+
22
+
(** {1 Envelope} *)
23
+
24
+
type t = {
25
+
date : string option;
26
+
subject : string option;
27
+
from : address list;
28
+
sender : address list;
29
+
reply_to : address list;
30
+
to_ : address list;
31
+
cc : address list;
32
+
bcc : address list;
33
+
in_reply_to : string option;
34
+
message_id : string option;
35
+
}
36
+
37
+
val pp : Format.formatter -> t -> unit
38
+
val empty : t
+75
lib/imap/error.ml
+75
lib/imap/error.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Client Errors
7
+
8
+
Error types for IMAP client operations, integrated with Eio's exception
9
+
handling. *)
10
+
11
+
(** {1 Error Types} *)
12
+
13
+
type t =
14
+
| Connection_error of { reason : string }
15
+
| Protocol_error of { code : Code.t option; text : string }
16
+
| Parse_error of { reason : string; data : string option }
17
+
| State_error of { expected : string; actual : string }
18
+
| Timeout of { operation : string }
19
+
| Capability_missing of { capability : string }
20
+
| Authentication_error of { mechanism : string; reason : string }
21
+
22
+
(** {1 Pretty Printing} *)
23
+
24
+
let pp ppf = function
25
+
| Connection_error { reason } -> Fmt.pf ppf "Connection error: %s" reason
26
+
| Protocol_error { code; text } ->
27
+
let code_str = Option.fold ~none:"" ~some:(Fmt.str " [%a]" Code.pp) code in
28
+
Fmt.pf ppf "Protocol error%s: %s" code_str text
29
+
| Parse_error { reason; data } ->
30
+
let truncate d = if String.length d > 50 then String.sub d 0 50 ^ "..." else d in
31
+
let suffix = Option.fold ~none:"" ~some:(fun d -> Fmt.str " (near: %s)" (truncate d)) data in
32
+
Fmt.pf ppf "Parse error: %s%s" reason suffix
33
+
| State_error { expected; actual } ->
34
+
Fmt.pf ppf "State error: expected %s, got %s" expected actual
35
+
| Timeout { operation } -> Fmt.pf ppf "Timeout: %s" operation
36
+
| Capability_missing { capability } ->
37
+
Fmt.pf ppf "Capability missing: %s" capability
38
+
| Authentication_error { mechanism; reason } ->
39
+
Fmt.pf ppf "Authentication error (%s): %s" mechanism reason
40
+
41
+
let to_string e = Fmt.str "%a" pp e
42
+
43
+
(** {1 Eio Integration} *)
44
+
45
+
type Eio.Exn.err += E of t
46
+
47
+
let () =
48
+
Eio.Exn.register_pp (fun ppf exn ->
49
+
match exn with
50
+
| E e ->
51
+
pp ppf e;
52
+
true
53
+
| _ -> false)
54
+
55
+
let err e = Eio.Exn.create (E e)
56
+
let raise e = Stdlib.raise (err e)
57
+
58
+
let of_eio_exn = function
59
+
| Eio.Exn.Io (E e, _) -> Some e
60
+
| _ -> None
61
+
62
+
(** {1 Error Classification} *)
63
+
64
+
let is_retryable = function
65
+
| Connection_error _ | Timeout _ -> true
66
+
| Protocol_error { code = Some Code.Unavailable; _ } -> true
67
+
| _ -> false
68
+
69
+
let is_auth_error = function
70
+
| Protocol_error { code = Some Code.Authenticationfailed; _ } -> true
71
+
| Protocol_error { code = Some Code.Authorizationfailed; _ } -> true
72
+
| Authentication_error _ -> true
73
+
| _ -> false
74
+
75
+
let is_state_error = function State_error _ -> true | _ -> false
+50
lib/imap/error.mli
+50
lib/imap/error.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Client Errors
7
+
8
+
Error types for IMAP client operations, integrated with Eio's exception
9
+
handling. *)
10
+
11
+
(** {1 Error Types} *)
12
+
13
+
type t =
14
+
| Connection_error of { reason : string }
15
+
| Protocol_error of { code : Code.t option; text : string }
16
+
| Parse_error of { reason : string; data : string option }
17
+
| State_error of { expected : string; actual : string }
18
+
| Timeout of { operation : string }
19
+
| Capability_missing of { capability : string }
20
+
| Authentication_error of { mechanism : string; reason : string }
21
+
22
+
(** {1 Pretty Printing} *)
23
+
24
+
val pp : Format.formatter -> t -> unit
25
+
val to_string : t -> string
26
+
27
+
(** {1 Eio Integration} *)
28
+
29
+
type Eio.Exn.err += E of t
30
+
(** Exception type for IMAP errors. *)
31
+
32
+
val err : t -> exn
33
+
(** [err e] wraps error [e] in an Eio exception. *)
34
+
35
+
val raise : t -> 'a
36
+
(** [raise e] raises error [e] as an Eio exception. *)
37
+
38
+
val of_eio_exn : exn -> t option
39
+
(** [of_eio_exn exn] extracts an IMAP error from an Eio exception. *)
40
+
41
+
(** {1 Error Classification} *)
42
+
43
+
val is_retryable : t -> bool
44
+
(** [is_retryable e] returns [true] if the error may succeed on retry. *)
45
+
46
+
val is_auth_error : t -> bool
47
+
(** [is_auth_error e] returns [true] if this is an authentication error. *)
48
+
49
+
val is_state_error : t -> bool
50
+
(** [is_state_error e] returns [true] if this is a state error. *)
+102
lib/imap/fetch.ml
+102
lib/imap/fetch.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** FETCH Items
7
+
8
+
Fetch data items for the FETCH command as specified in RFC 9051 Section 6.4.5. *)
9
+
10
+
(** {1 Request Items} *)
11
+
12
+
type request =
13
+
| Envelope
14
+
| Flags
15
+
| Internaldate
16
+
| Rfc822
17
+
| Rfc822_size
18
+
| Rfc822_header
19
+
| Rfc822_text
20
+
| Uid
21
+
| Body
22
+
| Bodystructure
23
+
| Body_section of string * (int * int) option
24
+
| Body_peek of string * (int * int) option
25
+
| Binary of string * (int * int) option
26
+
| Binary_peek of string * (int * int) option
27
+
| Binary_size of string
28
+
29
+
let pp_request ppf = function
30
+
| Envelope -> Fmt.string ppf "ENVELOPE"
31
+
| Flags -> Fmt.string ppf "FLAGS"
32
+
| Internaldate -> Fmt.string ppf "INTERNALDATE"
33
+
| Rfc822 -> Fmt.string ppf "RFC822"
34
+
| Rfc822_size -> Fmt.string ppf "RFC822.SIZE"
35
+
| Rfc822_header -> Fmt.string ppf "RFC822.HEADER"
36
+
| Rfc822_text -> Fmt.string ppf "RFC822.TEXT"
37
+
| Uid -> Fmt.string ppf "UID"
38
+
| Body -> Fmt.string ppf "BODY"
39
+
| Bodystructure -> Fmt.string ppf "BODYSTRUCTURE"
40
+
| Body_section (s, _) -> Fmt.pf ppf "BODY[%s]" s
41
+
| Body_peek (s, _) -> Fmt.pf ppf "BODY.PEEK[%s]" s
42
+
| Binary (s, _) -> Fmt.pf ppf "BINARY[%s]" s
43
+
| Binary_peek (s, _) -> Fmt.pf ppf "BINARY.PEEK[%s]" s
44
+
| Binary_size s -> Fmt.pf ppf "BINARY.SIZE[%s]" s
45
+
46
+
(** {1 Response Items} *)
47
+
48
+
type response =
49
+
| Item_envelope of Envelope.t
50
+
| Item_flags of Flag.t list
51
+
| Item_internaldate of string
52
+
| Item_rfc822_size of int64
53
+
| Item_uid of int32
54
+
| Item_body of Body.t
55
+
| Item_bodystructure of Body.t
56
+
| Item_body_section of {
57
+
section : Body.section option;
58
+
origin : int option;
59
+
data : string option;
60
+
}
61
+
| Item_binary of { section : int list; data : string option }
62
+
| Item_binary_size of { section : int list; size : int64 }
63
+
64
+
(** {1 Parsed Message} *)
65
+
66
+
type message = {
67
+
seq : int;
68
+
uid : int32 option;
69
+
flags : Flag.t list option;
70
+
envelope : Envelope.t option;
71
+
body_structure : Body.t option;
72
+
internaldate : string option;
73
+
size : int64 option;
74
+
body_section : string option;
75
+
}
76
+
77
+
let empty_message =
78
+
{
79
+
seq = 0;
80
+
uid = None;
81
+
flags = None;
82
+
envelope = None;
83
+
body_structure = None;
84
+
internaldate = None;
85
+
size = None;
86
+
body_section = None;
87
+
}
88
+
89
+
let message_of_items seq items =
90
+
List.fold_left
91
+
(fun msg item ->
92
+
match item with
93
+
| Item_uid u -> { msg with uid = Some u }
94
+
| Item_flags f -> { msg with flags = Some f }
95
+
| Item_envelope e -> { msg with envelope = Some e }
96
+
| Item_body b | Item_bodystructure b -> { msg with body_structure = Some b }
97
+
| Item_internaldate d -> { msg with internaldate = Some d }
98
+
| Item_rfc822_size s -> { msg with size = Some s }
99
+
| Item_body_section { data; _ } -> { msg with body_section = data }
100
+
| _ -> msg)
101
+
{ empty_message with seq }
102
+
items
+63
lib/imap/fetch.mli
+63
lib/imap/fetch.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** FETCH Items
7
+
8
+
Fetch data items for the FETCH command as specified in RFC 9051 Section 6.4.5. *)
9
+
10
+
(** {1 Request Items} *)
11
+
12
+
type request =
13
+
| Envelope
14
+
| Flags
15
+
| Internaldate
16
+
| Rfc822
17
+
| Rfc822_size
18
+
| Rfc822_header
19
+
| Rfc822_text
20
+
| Uid
21
+
| Body
22
+
| Bodystructure
23
+
| Body_section of string * (int * int) option
24
+
| Body_peek of string * (int * int) option
25
+
| Binary of string * (int * int) option
26
+
| Binary_peek of string * (int * int) option
27
+
| Binary_size of string
28
+
29
+
val pp_request : Format.formatter -> request -> unit
30
+
31
+
(** {1 Response Items} *)
32
+
33
+
type response =
34
+
| Item_envelope of Envelope.t
35
+
| Item_flags of Flag.t list
36
+
| Item_internaldate of string
37
+
| Item_rfc822_size of int64
38
+
| Item_uid of int32
39
+
| Item_body of Body.t
40
+
| Item_bodystructure of Body.t
41
+
| Item_body_section of {
42
+
section : Body.section option;
43
+
origin : int option;
44
+
data : string option;
45
+
}
46
+
| Item_binary of { section : int list; data : string option }
47
+
| Item_binary_size of { section : int list; size : int64 }
48
+
49
+
(** {1 Parsed Message} *)
50
+
51
+
type message = {
52
+
seq : int;
53
+
uid : int32 option;
54
+
flags : Flag.t list option;
55
+
envelope : Envelope.t option;
56
+
body_structure : Body.t option;
57
+
internaldate : string option;
58
+
size : int64 option;
59
+
body_section : string option;
60
+
}
61
+
62
+
val empty_message : message
63
+
val message_of_items : int -> response list -> message
+42
lib/imap/flag.ml
+42
lib/imap/flag.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Message Flags
7
+
8
+
IMAP message flags as specified in RFC 9051 Section 2.3.2. *)
9
+
10
+
type system =
11
+
| Seen (** Message has been read *)
12
+
| Answered (** Message has been answered *)
13
+
| Flagged (** Message is flagged for urgent/special attention *)
14
+
| Deleted (** Message is marked for deletion *)
15
+
| Draft (** Message has not completed composition *)
16
+
17
+
let pp_system ppf = function
18
+
| Seen -> Fmt.string ppf "\\Seen"
19
+
| Answered -> Fmt.string ppf "\\Answered"
20
+
| Flagged -> Fmt.string ppf "\\Flagged"
21
+
| Deleted -> Fmt.string ppf "\\Deleted"
22
+
| Draft -> Fmt.string ppf "\\Draft"
23
+
24
+
type t =
25
+
| System of system
26
+
| Keyword of string
27
+
28
+
let pp ppf = function
29
+
| System f -> pp_system ppf f
30
+
| Keyword k -> Fmt.pf ppf "$%s" k
31
+
32
+
let to_string f = Fmt.str "%a" pp f
33
+
34
+
let of_string s =
35
+
match String.uppercase_ascii s with
36
+
| "\\SEEN" -> Some (System Seen)
37
+
| "\\ANSWERED" -> Some (System Answered)
38
+
| "\\FLAGGED" -> Some (System Flagged)
39
+
| "\\DELETED" -> Some (System Deleted)
40
+
| "\\DRAFT" -> Some (System Draft)
41
+
| _ ->
42
+
if String.length s > 0 && s.[0] <> '\\' then Some (Keyword s) else None
+29
lib/imap/flag.mli
+29
lib/imap/flag.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Message Flags
7
+
8
+
IMAP message flags as specified in RFC 9051 Section 2.3.2. *)
9
+
10
+
(** {1 System Flags} *)
11
+
12
+
type system =
13
+
| Seen (** Message has been read *)
14
+
| Answered (** Message has been answered *)
15
+
| Flagged (** Message is flagged for urgent/special attention *)
16
+
| Deleted (** Message is marked for deletion *)
17
+
| Draft (** Message has not completed composition *)
18
+
19
+
val pp_system : Format.formatter -> system -> unit
20
+
21
+
(** {1 Flags} *)
22
+
23
+
type t =
24
+
| System of system
25
+
| Keyword of string
26
+
27
+
val pp : Format.formatter -> t -> unit
28
+
val to_string : t -> string
29
+
val of_string : string -> t option
+108
lib/imap/imap.ml
+108
lib/imap/imap.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP4rev2 Client Library
7
+
8
+
A comprehensive IMAP client library implementing
9
+
{{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051 IMAP4rev2}.
10
+
11
+
{2 Quick Start}
12
+
13
+
{[
14
+
Eio_main.run @@ fun env ->
15
+
Eio.Switch.run @@ fun sw ->
16
+
17
+
let client =
18
+
Imap.Client.connect ~sw ~env ~host:"imap.example.com" ~port:993 ()
19
+
in
20
+
21
+
Imap.Client.login client ~username:"user" ~password:"pass";
22
+
23
+
let mailbox = Imap.Client.select client "INBOX" in
24
+
Printf.printf "You have %d messages\n" mailbox.exists;
25
+
26
+
let messages =
27
+
Imap.Client.fetch client
28
+
~sequence:(Imap.Seq.range 1 10)
29
+
~items:[ Imap.Fetch.Envelope; Imap.Fetch.Flags ]
30
+
in
31
+
List.iter
32
+
(fun msg ->
33
+
match msg.Imap.Fetch.uid with
34
+
| Some uid ->
35
+
Printf.printf "[%ld] %s\n" uid
36
+
(Option.bind msg.envelope (fun e -> e.Imap.Envelope.subject)
37
+
|> Option.value ~default:"<no subject>")
38
+
| None -> ())
39
+
messages;
40
+
41
+
Imap.Client.logout client
42
+
]}
43
+
44
+
{2 Module Structure}
45
+
46
+
{b Protocol Types:}
47
+
- {!module:Flag} - Message flags (Seen, Answered, Flagged, etc.)
48
+
- {!module:Seq} - Sequence sets for addressing messages
49
+
- {!module:Envelope} - Email addresses and message envelopes
50
+
- {!module:Body} - MIME body structure
51
+
- {!module:Mailbox} - Mailbox name utilities
52
+
53
+
{b Commands & Responses:}
54
+
- {!module:Command} - IMAP commands
55
+
- {!module:Response} - Server responses
56
+
- {!module:Code} - Response codes
57
+
- {!module:Fetch} - FETCH request/response items
58
+
- {!module:Search} - SEARCH criteria
59
+
- {!module:Store} - STORE actions
60
+
- {!module:Status} - STATUS items
61
+
- {!module:List_attr} - LIST mailbox attributes
62
+
63
+
{b Client:}
64
+
- {!module:Error} - Error types with Eio integration
65
+
- {!module:Client} - IMAP client connection and operations
66
+
- {!module:Pool} - Connection pooling
67
+
68
+
{b Low-level:}
69
+
- {!module:Read} - Response parsing
70
+
- {!module:Write} - Command serialization
71
+
72
+
{2 References}
73
+
74
+
- {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} - IMAP4rev2
75
+
- {{:https://datatracker.ietf.org/doc/html/rfc2177}RFC 2177} - IDLE
76
+
- {{:https://datatracker.ietf.org/doc/html/rfc6851}RFC 6851} - MOVE
77
+
- {{:https://datatracker.ietf.org/doc/html/rfc7888}RFC 7888} - LITERAL+
78
+
- {{:https://datatracker.ietf.org/doc/html/rfc2971}RFC 2971} - ID *)
79
+
80
+
(** {1 Protocol Types} *)
81
+
82
+
module Flag = Flag
83
+
module Seq = Seq
84
+
module Envelope = Envelope
85
+
module Body = Body
86
+
module Mailbox = Mailbox
87
+
88
+
(** {1 Commands & Responses} *)
89
+
90
+
module Command = Command
91
+
module Response = Response
92
+
module Code = Code
93
+
module Fetch = Fetch
94
+
module Search = Search
95
+
module Store = Store
96
+
module Status = Status
97
+
module List_attr = List_attr
98
+
99
+
(** {1 Client} *)
100
+
101
+
module Error = Error
102
+
module Client = Client
103
+
module Pool = Pool
104
+
105
+
(** {1 Low-level} *)
106
+
107
+
module Read = Read
108
+
module Write = Write
+108
lib/imap/imap.mli
+108
lib/imap/imap.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP4rev2 Client Library
7
+
8
+
A comprehensive IMAP client library implementing
9
+
{{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051 IMAP4rev2}.
10
+
11
+
{2 Quick Start}
12
+
13
+
{[
14
+
Eio_main.run @@ fun env ->
15
+
Eio.Switch.run @@ fun sw ->
16
+
17
+
let client =
18
+
Imap.Client.connect ~sw ~env ~host:"imap.example.com" ~port:993 ()
19
+
in
20
+
21
+
Imap.Client.login client ~username:"user" ~password:"pass";
22
+
23
+
let mailbox = Imap.Client.select client "INBOX" in
24
+
Printf.printf "You have %d messages\n" mailbox.exists;
25
+
26
+
let messages =
27
+
Imap.Client.fetch client
28
+
~sequence:(Imap.Seq.range 1 10)
29
+
~items:[ Imap.Fetch.Envelope; Imap.Fetch.Flags ]
30
+
in
31
+
List.iter
32
+
(fun msg ->
33
+
match msg.Imap.Fetch.uid with
34
+
| Some uid ->
35
+
Printf.printf "[%ld] %s\n" uid
36
+
(Option.bind msg.envelope (fun e -> e.Imap.Envelope.subject)
37
+
|> Option.value ~default:"<no subject>")
38
+
| None -> ())
39
+
messages;
40
+
41
+
Imap.Client.logout client
42
+
]}
43
+
44
+
{2 Module Structure}
45
+
46
+
{b Protocol Types:}
47
+
- {!module:Flag} - Message flags (Seen, Answered, Flagged, etc.)
48
+
- {!module:Seq} - Sequence sets for addressing messages
49
+
- {!module:Envelope} - Email addresses and message envelopes
50
+
- {!module:Body} - MIME body structure
51
+
- {!module:Mailbox} - Mailbox name utilities
52
+
53
+
{b Commands & Responses:}
54
+
- {!module:Command} - IMAP commands
55
+
- {!module:Response} - Server responses
56
+
- {!module:Code} - Response codes
57
+
- {!module:Fetch} - FETCH request/response items
58
+
- {!module:Search} - SEARCH criteria
59
+
- {!module:Store} - STORE actions
60
+
- {!module:Status} - STATUS items
61
+
- {!module:List_attr} - LIST mailbox attributes
62
+
63
+
{b Client:}
64
+
- {!module:Error} - Error types with Eio integration
65
+
- {!module:Client} - IMAP client connection and operations
66
+
- {!module:Pool} - Connection pooling
67
+
68
+
{b Low-level:}
69
+
- {!module:Read} - Response parsing
70
+
- {!module:Write} - Command serialization
71
+
72
+
{2 References}
73
+
74
+
- {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} - IMAP4rev2
75
+
- {{:https://datatracker.ietf.org/doc/html/rfc2177}RFC 2177} - IDLE
76
+
- {{:https://datatracker.ietf.org/doc/html/rfc6851}RFC 6851} - MOVE
77
+
- {{:https://datatracker.ietf.org/doc/html/rfc7888}RFC 7888} - LITERAL+
78
+
- {{:https://datatracker.ietf.org/doc/html/rfc2971}RFC 2971} - ID *)
79
+
80
+
(** {1 Protocol Types} *)
81
+
82
+
module Flag = Flag
83
+
module Seq = Seq
84
+
module Envelope = Envelope
85
+
module Body = Body
86
+
module Mailbox = Mailbox
87
+
88
+
(** {1 Commands & Responses} *)
89
+
90
+
module Command = Command
91
+
module Response = Response
92
+
module Code = Code
93
+
module Fetch = Fetch
94
+
module Search = Search
95
+
module Store = Store
96
+
module Status = Status
97
+
module List_attr = List_attr
98
+
99
+
(** {1 Client} *)
100
+
101
+
module Error = Error
102
+
module Client = Client
103
+
module Pool = Pool
104
+
105
+
(** {1 Low-level} *)
106
+
107
+
module Read = Read
108
+
module Write = Write
+45
lib/imap/list_attr.ml
+45
lib/imap/list_attr.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** LIST Command Attributes
7
+
8
+
Mailbox attributes returned by LIST command.
9
+
See RFC 9051 Section 7.2.2. *)
10
+
11
+
type t =
12
+
| Noinferiors
13
+
| Noselect
14
+
| Marked
15
+
| Unmarked
16
+
| Subscribed
17
+
| Haschildren
18
+
| Hasnochildren
19
+
| All
20
+
| Archive
21
+
| Drafts
22
+
| Flagged
23
+
| Junk
24
+
| Sent
25
+
| Trash
26
+
| Extension of string
27
+
28
+
let pp ppf = function
29
+
| Noinferiors -> Fmt.string ppf "\\Noinferiors"
30
+
| Noselect -> Fmt.string ppf "\\Noselect"
31
+
| Marked -> Fmt.string ppf "\\Marked"
32
+
| Unmarked -> Fmt.string ppf "\\Unmarked"
33
+
| Subscribed -> Fmt.string ppf "\\Subscribed"
34
+
| Haschildren -> Fmt.string ppf "\\HasChildren"
35
+
| Hasnochildren -> Fmt.string ppf "\\HasNoChildren"
36
+
| All -> Fmt.string ppf "\\All"
37
+
| Archive -> Fmt.string ppf "\\Archive"
38
+
| Drafts -> Fmt.string ppf "\\Drafts"
39
+
| Flagged -> Fmt.string ppf "\\Flagged"
40
+
| Junk -> Fmt.string ppf "\\Junk"
41
+
| Sent -> Fmt.string ppf "\\Sent"
42
+
| Trash -> Fmt.string ppf "\\Trash"
43
+
| Extension s -> Fmt.string ppf s
44
+
45
+
let to_string a = Fmt.str "%a" pp a
+29
lib/imap/list_attr.mli
+29
lib/imap/list_attr.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** LIST Command Attributes
7
+
8
+
Mailbox attributes returned by LIST command.
9
+
See RFC 9051 Section 7.2.2. *)
10
+
11
+
type t =
12
+
| Noinferiors
13
+
| Noselect
14
+
| Marked
15
+
| Unmarked
16
+
| Subscribed
17
+
| Haschildren
18
+
| Hasnochildren
19
+
| All
20
+
| Archive
21
+
| Drafts
22
+
| Flagged
23
+
| Junk
24
+
| Sent
25
+
| Trash
26
+
| Extension of string
27
+
28
+
val pp : Format.formatter -> t -> unit
29
+
val to_string : t -> string
+38
lib/imap/mailbox.ml
+38
lib/imap/mailbox.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Mailbox Names
7
+
8
+
Mailbox name handling as specified in RFC 9051 Section 5.1. *)
9
+
10
+
type t = string
11
+
12
+
let normalize name =
13
+
if String.uppercase_ascii name = "INBOX" then "INBOX" else name
14
+
15
+
let is_inbox name = String.uppercase_ascii name = "INBOX"
16
+
17
+
let is_safe mailbox =
18
+
let len = String.length mailbox in
19
+
if len = 0 || len > 1024 then false
20
+
else
21
+
(not (String.contains mailbox '\x00'))
22
+
&& (not (String.contains mailbox '\\'))
23
+
&&
24
+
let parts = String.split_on_char '/' mailbox in
25
+
not (List.exists (fun p -> p = "." || p = "..") parts)
26
+
27
+
let is_safe_username username =
28
+
let len = String.length username in
29
+
if len = 0 || len > 256 then false
30
+
else
31
+
(not (String.contains username '\x00'))
32
+
&& (not (String.contains username '/'))
33
+
&& (not (String.contains username '\\'))
34
+
&& username <> "." && username <> ".."
35
+
&& username.[0] <> '.'
36
+
&& username.[len - 1] <> '.'
37
+
&& username.[0] <> ' '
38
+
&& username.[len - 1] <> ' '
+23
lib/imap/mailbox.mli
+23
lib/imap/mailbox.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Mailbox Names
7
+
8
+
Mailbox name handling as specified in RFC 9051 Section 5.1. *)
9
+
10
+
type t = string
11
+
12
+
val normalize : t -> t
13
+
(** [normalize name] returns the canonical form of a mailbox name.
14
+
INBOX is case-insensitive and normalized to uppercase. *)
15
+
16
+
val is_inbox : t -> bool
17
+
(** [is_inbox name] returns true if the mailbox is INBOX. *)
18
+
19
+
val is_safe : t -> bool
20
+
(** [is_safe mailbox] returns true if the mailbox name is safe. *)
21
+
22
+
val is_safe_username : string -> bool
23
+
(** [is_safe_username username] returns true if the username is safe. *)
+191
lib/imap/pool.ml
+191
lib/imap/pool.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Connection Pool
7
+
8
+
Manages a pool of authenticated IMAP connections for efficient reuse. *)
9
+
10
+
(** {1 Configuration} *)
11
+
12
+
type config = {
13
+
min_connections : int;
14
+
max_connections : int;
15
+
idle_timeout : float;
16
+
health_check_interval : float;
17
+
}
18
+
19
+
let default_config =
20
+
{
21
+
min_connections = 1;
22
+
max_connections = 10;
23
+
idle_timeout = 300.0;
24
+
health_check_interval = 60.0;
25
+
}
26
+
27
+
(** {1 Statistics} *)
28
+
29
+
type stats = {
30
+
total : int;
31
+
active : int;
32
+
idle : int;
33
+
created : int;
34
+
reused : int;
35
+
failed : int;
36
+
}
37
+
38
+
let pp_stats ppf s =
39
+
Fmt.pf ppf "@[<v>total: %d@,active: %d@,idle: %d@,created: %d@,reused: %d@,failed: %d@]"
40
+
s.total s.active s.idle s.created s.reused s.failed
41
+
42
+
(** {1 Abstract Type} *)
43
+
44
+
type t = {
45
+
connect_fn : unit -> Client.t option;
46
+
config : config;
47
+
mutable connections : Client.t list;
48
+
mutable active : Client.t list;
49
+
mutex : Eio.Mutex.t;
50
+
condition : Eio.Condition.t;
51
+
mutable closed : bool;
52
+
mutable stats_created : int;
53
+
mutable stats_reused : int;
54
+
mutable stats_failed : int;
55
+
}
56
+
57
+
let pp ppf t =
58
+
let stats =
59
+
{ total = List.length t.connections + List.length t.active;
60
+
active = List.length t.active;
61
+
idle = List.length t.connections;
62
+
created = t.stats_created;
63
+
reused = t.stats_reused;
64
+
failed = t.stats_failed }
65
+
in
66
+
Fmt.pf ppf "<Imap.Pool: %a>" pp_stats stats
67
+
68
+
let to_string t = Fmt.str "%a" pp t
69
+
70
+
(** {1 Internal Helpers} *)
71
+
72
+
let create_connection t =
73
+
match t.connect_fn () with
74
+
| Some client ->
75
+
t.stats_created <- t.stats_created + 1;
76
+
Some client
77
+
| None ->
78
+
t.stats_failed <- t.stats_failed + 1;
79
+
None
80
+
81
+
let is_healthy client =
82
+
try
83
+
Client.noop client;
84
+
true
85
+
with _ -> false
86
+
87
+
(** {1 Pool Management} *)
88
+
89
+
let create ~sw ~env ~host ?(port = 993) ~username ~password ?tls_config ?(config = default_config) () =
90
+
let connect_fn () =
91
+
try
92
+
let client = Client.connect ~sw ~env ~host ~port ?tls_config () in
93
+
Client.login client ~username ~password;
94
+
Some client
95
+
with _ -> None
96
+
in
97
+
let t =
98
+
{
99
+
connect_fn;
100
+
config;
101
+
connections = [];
102
+
active = [];
103
+
mutex = Eio.Mutex.create ();
104
+
condition = Eio.Condition.create ();
105
+
closed = false;
106
+
stats_created = 0;
107
+
stats_reused = 0;
108
+
stats_failed = 0;
109
+
}
110
+
in
111
+
for _ = 1 to config.min_connections do
112
+
match create_connection t with
113
+
| Some client -> t.connections <- client :: t.connections
114
+
| None -> ()
115
+
done;
116
+
t
117
+
118
+
let close t =
119
+
Eio.Mutex.use_rw ~protect:false t.mutex (fun () ->
120
+
t.closed <- true;
121
+
List.iter Client.disconnect t.connections;
122
+
List.iter Client.disconnect t.active;
123
+
t.connections <- [];
124
+
t.active <- []);
125
+
Eio.Condition.broadcast t.condition
126
+
127
+
let acquire t =
128
+
Eio.Mutex.use_rw ~protect:false t.mutex (fun () ->
129
+
if t.closed then Error.raise (Connection_error { reason = "Pool is closed" });
130
+
let rec find_healthy = function
131
+
| [] -> None
132
+
| client :: rest ->
133
+
if is_healthy client then (
134
+
t.connections <- rest;
135
+
t.active <- client :: t.active;
136
+
t.stats_reused <- t.stats_reused + 1;
137
+
Some client)
138
+
else (
139
+
Client.disconnect client;
140
+
find_healthy rest)
141
+
in
142
+
match find_healthy t.connections with
143
+
| Some client -> client
144
+
| None ->
145
+
let total = List.length t.connections + List.length t.active in
146
+
if total < t.config.max_connections then
147
+
match create_connection t with
148
+
| Some client ->
149
+
t.active <- client :: t.active;
150
+
client
151
+
| None ->
152
+
Error.raise (Connection_error { reason = "Failed to create connection" })
153
+
else Error.raise (Connection_error { reason = "Pool exhausted" }))
154
+
155
+
let release t client =
156
+
Eio.Mutex.use_rw ~protect:false t.mutex (fun () ->
157
+
t.active <- List.filter (fun c -> c != client) t.active;
158
+
if t.closed || not (is_healthy client) then Client.disconnect client
159
+
else (
160
+
(try
161
+
match Client.state client with
162
+
| Client.Selected _ -> Client.close client
163
+
| _ -> ()
164
+
with _ -> ());
165
+
t.connections <- client :: t.connections));
166
+
Eio.Condition.broadcast t.condition
167
+
168
+
let with_client t fn =
169
+
let client = acquire t in
170
+
match fn client with
171
+
| result ->
172
+
release t client;
173
+
result
174
+
| exception exn ->
175
+
Eio.Mutex.use_rw ~protect:false t.mutex (fun () ->
176
+
t.active <- List.filter (fun c -> c != client) t.active);
177
+
(try Client.disconnect client with _ -> ());
178
+
raise exn
179
+
180
+
let stats t =
181
+
Eio.Mutex.use_rw ~protect:false t.mutex (fun () ->
182
+
let idle = List.length t.connections in
183
+
let active = List.length t.active in
184
+
{
185
+
total = idle + active;
186
+
active;
187
+
idle;
188
+
created = t.stats_created;
189
+
reused = t.stats_reused;
190
+
failed = t.stats_failed;
191
+
})
+68
lib/imap/pool.mli
+68
lib/imap/pool.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Connection Pool
7
+
8
+
Manages a pool of authenticated IMAP connections for efficient reuse. *)
9
+
10
+
(** {1 Configuration} *)
11
+
12
+
type config = {
13
+
min_connections : int;
14
+
max_connections : int;
15
+
idle_timeout : float;
16
+
health_check_interval : float;
17
+
}
18
+
19
+
val default_config : config
20
+
21
+
(** {1 Statistics} *)
22
+
23
+
type stats = {
24
+
total : int;
25
+
active : int;
26
+
idle : int;
27
+
created : int;
28
+
reused : int;
29
+
failed : int;
30
+
}
31
+
32
+
val pp_stats : Format.formatter -> stats -> unit
33
+
34
+
(** {1 Pool} *)
35
+
36
+
type t
37
+
(** A connection pool. *)
38
+
39
+
val pp : Format.formatter -> t -> unit
40
+
val to_string : t -> string
41
+
42
+
val create :
43
+
sw:Eio.Switch.t ->
44
+
env:< net : _ Eio.Net.t ; .. > ->
45
+
host:string ->
46
+
?port:int ->
47
+
username:string ->
48
+
password:string ->
49
+
?tls_config:Tls.Config.client ->
50
+
?config:config ->
51
+
unit ->
52
+
t
53
+
(** [create ~sw ~env ~host ~username ~password ?config ()] creates a connection pool. *)
54
+
55
+
val close : t -> unit
56
+
(** [close pool] closes all connections in the pool. *)
57
+
58
+
val acquire : t -> Client.t
59
+
(** [acquire pool] gets a connection from the pool. *)
60
+
61
+
val release : t -> Client.t -> unit
62
+
(** [release pool client] returns a connection to the pool. *)
63
+
64
+
val with_client : t -> (Client.t -> 'a) -> 'a
65
+
(** [with_client pool fn] runs [fn] with an acquired connection. *)
66
+
67
+
val stats : t -> stats
68
+
(** [stats pool] returns current pool statistics. *)
+534
lib/imap/read.ml
+534
lib/imap/read.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Response Parsing
7
+
8
+
Parses IMAP responses from the wire format using Eio.Buf_read. *)
9
+
10
+
module R = Eio.Buf_read
11
+
12
+
(** {1 Abstract Type} *)
13
+
14
+
type t = R.t
15
+
(** A response reader backed by Eio.Buf_read. *)
16
+
17
+
let pp ppf _ = Fmt.string ppf "<Imap.Read.t>"
18
+
let to_string _ = "<Imap.Read.t>"
19
+
20
+
(** {1 Low-level Parsers} *)
21
+
22
+
let sp = R.char ' '
23
+
let crlf = R.string "\r\n"
24
+
25
+
let is_atom_char = function
26
+
| '(' | ')' | '{' | ' ' | '\x00' .. '\x1f' | '\x7f' | '%' | '*' | '"' | '\\'
27
+
| '[' | ']' ->
28
+
false
29
+
| _ -> true
30
+
31
+
let atom r =
32
+
let s = R.take_while1 is_atom_char r in
33
+
s
34
+
35
+
let number r =
36
+
let s = R.take_while1 (function '0' .. '9' -> true | _ -> false) r in
37
+
int_of_string s
38
+
39
+
let number32 r = Int32.of_string (R.take_while1 (function '0' .. '9' -> true | _ -> false) r)
40
+
let number64 r = Int64.of_string (R.take_while1 (function '0' .. '9' -> true | _ -> false) r)
41
+
42
+
let quoted_string r =
43
+
R.char '"' r;
44
+
let buf = Buffer.create 64 in
45
+
let rec loop () =
46
+
match R.any_char r with
47
+
| '"' -> Buffer.contents buf
48
+
| '\\' ->
49
+
let c = R.any_char r in
50
+
Buffer.add_char buf c;
51
+
loop ()
52
+
| c ->
53
+
Buffer.add_char buf c;
54
+
loop ()
55
+
in
56
+
loop ()
57
+
58
+
let literal r =
59
+
R.char '{' r;
60
+
let len = number r in
61
+
R.char '}' r;
62
+
crlf r;
63
+
R.take len r
64
+
65
+
let is_nil r =
66
+
R.ensure r 3;
67
+
let buf = R.peek r in
68
+
Cstruct.length buf >= 3
69
+
&& Char.uppercase_ascii (Cstruct.get_char buf 0) = 'N'
70
+
&& Char.uppercase_ascii (Cstruct.get_char buf 1) = 'I'
71
+
&& Char.uppercase_ascii (Cstruct.get_char buf 2) = 'L'
72
+
73
+
let skip_nil r = R.take 3 r |> ignore
74
+
75
+
let nstring r =
76
+
if is_nil r then (skip_nil r; None)
77
+
else
78
+
match R.peek_char r with
79
+
| Some '"' -> Some (quoted_string r)
80
+
| Some '{' -> Some (literal r)
81
+
| _ -> None
82
+
83
+
let astring r =
84
+
match R.peek_char r with
85
+
| Some '"' -> quoted_string r
86
+
| Some '{' -> literal r
87
+
| _ -> atom r
88
+
89
+
(** {1 Parser Helpers} *)
90
+
91
+
let collect_atoms r =
92
+
let acc = ref [] in
93
+
while R.peek_char r = Some ' ' do
94
+
sp r;
95
+
acc := atom r :: !acc
96
+
done;
97
+
List.rev !acc
98
+
99
+
let parse_paren_list ~parse_item r =
100
+
R.char '(' r;
101
+
let rec loop acc =
102
+
match R.peek_char r with
103
+
| Some ')' -> R.char ')' r; List.rev acc
104
+
| Some ' ' -> sp r; loop acc
105
+
| _ -> loop (parse_item r :: acc)
106
+
in
107
+
loop []
108
+
109
+
(** {1 Flags} *)
110
+
111
+
let system_flag r =
112
+
R.char '\\' r;
113
+
let name = atom r in
114
+
match String.uppercase_ascii name with
115
+
| "SEEN" -> Flag.System Flag.Seen
116
+
| "ANSWERED" -> Flag.System Flag.Answered
117
+
| "FLAGGED" -> Flag.System Flag.Flagged
118
+
| "DELETED" -> Flag.System Flag.Deleted
119
+
| "DRAFT" -> Flag.System Flag.Draft
120
+
| _ -> Flag.Keyword ("\\" ^ name)
121
+
122
+
let flag r =
123
+
match R.peek_char r with
124
+
| Some '\\' -> system_flag r
125
+
| Some '$' ->
126
+
R.char '$' r;
127
+
Flag.Keyword ("$" ^ atom r)
128
+
| _ -> Flag.Keyword (atom r)
129
+
130
+
let flag_list r = parse_paren_list ~parse_item:flag r
131
+
132
+
(** {1 LIST Flags} *)
133
+
134
+
let list_flag r =
135
+
R.char '\\' r;
136
+
let name = atom r in
137
+
match String.uppercase_ascii name with
138
+
| "NOINFERIORS" -> List_attr.Noinferiors
139
+
| "NOSELECT" -> List_attr.Noselect
140
+
| "MARKED" -> List_attr.Marked
141
+
| "UNMARKED" -> List_attr.Unmarked
142
+
| "SUBSCRIBED" -> List_attr.Subscribed
143
+
| "HASCHILDREN" -> List_attr.Haschildren
144
+
| "HASNOCHILDREN" -> List_attr.Hasnochildren
145
+
| "ALL" -> List_attr.All
146
+
| "ARCHIVE" -> List_attr.Archive
147
+
| "DRAFTS" -> List_attr.Drafts
148
+
| "FLAGGED" -> List_attr.Flagged
149
+
| "JUNK" -> List_attr.Junk
150
+
| "SENT" -> List_attr.Sent
151
+
| "TRASH" -> List_attr.Trash
152
+
| other -> List_attr.Extension ("\\" ^ other)
153
+
154
+
let list_flag_list r =
155
+
R.char '(' r;
156
+
let rec loop acc =
157
+
match R.peek_char r with
158
+
| Some ')' ->
159
+
R.char ')' r;
160
+
List.rev acc
161
+
| Some ' ' ->
162
+
sp r;
163
+
loop acc
164
+
| Some '\\' -> loop (list_flag r :: acc)
165
+
| _ ->
166
+
let _ = atom r in
167
+
loop acc
168
+
in
169
+
loop []
170
+
171
+
(** {1 Response Codes} *)
172
+
173
+
let response_code r =
174
+
R.char '[' r;
175
+
let name = atom r in
176
+
let code =
177
+
match String.uppercase_ascii name with
178
+
| "ALERT" -> Code.Alert
179
+
| "ALREADYEXISTS" -> Code.Alreadyexists
180
+
| "AUTHENTICATIONFAILED" -> Code.Authenticationfailed
181
+
| "AUTHORIZATIONFAILED" -> Code.Authorizationfailed
182
+
| "CANNOT" -> Code.Cannot
183
+
| "CAPABILITY" -> Code.Capability (collect_atoms r)
184
+
| "CLIENTBUG" -> Code.Clientbug
185
+
| "CLOSED" -> Code.Closed
186
+
| "CONTACTADMIN" -> Code.Contactadmin
187
+
| "CORRUPTION" -> Code.Corruption
188
+
| "EXPIRED" -> Code.Expired
189
+
| "EXPUNGEISSUED" -> Code.Expungeissued
190
+
| "HASCHILDREN" -> Code.Haschildren
191
+
| "INUSE" -> Code.Inuse
192
+
| "LIMIT" -> Code.Limit
193
+
| "NONEXISTENT" -> Code.Nonexistent
194
+
| "NOPERM" -> Code.Noperm
195
+
| "OVERQUOTA" -> Code.Overquota
196
+
| "PARSE" -> Code.Parse
197
+
| "PERMANENTFLAGS" ->
198
+
sp r;
199
+
let flags = flag_list r in
200
+
Code.Permanentflags flags
201
+
| "PRIVACYREQUIRED" -> Code.Privacyrequired
202
+
| "READ-ONLY" -> Code.Readonly
203
+
| "READ-WRITE" -> Code.Readwrite
204
+
| "SERVERBUG" -> Code.Serverbug
205
+
| "TRYCREATE" -> Code.Trycreate
206
+
| "UIDNOTSTICKY" -> Code.Uidnotsticky
207
+
| "UIDVALIDITY" ->
208
+
sp r;
209
+
Code.Uidvalidity (number32 r)
210
+
| "UIDNEXT" ->
211
+
sp r;
212
+
Code.Uidnext (number32 r)
213
+
| "UNAVAILABLE" -> Code.Unavailable
214
+
| "UNKNOWN-CTE" -> Code.Unknown_cte
215
+
| other ->
216
+
let arg =
217
+
if R.peek_char r = Some ' ' then (
218
+
sp r;
219
+
Some (R.take_while (fun c -> c <> ']') r))
220
+
else None
221
+
in
222
+
Code.Other (other, arg)
223
+
in
224
+
R.char ']' r;
225
+
code
226
+
227
+
(** {1 Envelope and Addresses} *)
228
+
229
+
let address r =
230
+
R.char '(' r;
231
+
let name = nstring r in
232
+
sp r;
233
+
let adl = nstring r in
234
+
sp r;
235
+
let mailbox = nstring r in
236
+
sp r;
237
+
let host = nstring r in
238
+
R.char ')' r;
239
+
Envelope.{ name; adl; mailbox; host }
240
+
241
+
let address_list r =
242
+
if is_nil r then (skip_nil r; [])
243
+
else (
244
+
R.char '(' r;
245
+
let rec loop acc =
246
+
match R.peek_char r with
247
+
| Some ')' ->
248
+
R.char ')' r;
249
+
List.rev acc
250
+
| Some '(' -> loop (address r :: acc)
251
+
| Some ' ' ->
252
+
sp r;
253
+
loop acc
254
+
| _ -> List.rev acc
255
+
in
256
+
loop [])
257
+
258
+
let envelope r =
259
+
R.char '(' r;
260
+
let date = nstring r in
261
+
sp r;
262
+
let subject = nstring r in
263
+
sp r;
264
+
let from = address_list r in
265
+
sp r;
266
+
let sender = address_list r in
267
+
sp r;
268
+
let reply_to = address_list r in
269
+
sp r;
270
+
let to_ = address_list r in
271
+
sp r;
272
+
let cc = address_list r in
273
+
sp r;
274
+
let bcc = address_list r in
275
+
sp r;
276
+
let in_reply_to = nstring r in
277
+
sp r;
278
+
let message_id = nstring r in
279
+
R.char ')' r;
280
+
Envelope.{ date; subject; from; sender; reply_to; to_; cc; bcc; in_reply_to; message_id }
281
+
282
+
(** {1 FETCH Response Items} *)
283
+
284
+
let fetch_item r =
285
+
let name = atom r in
286
+
match String.uppercase_ascii name with
287
+
| "FLAGS" ->
288
+
sp r;
289
+
Fetch.Item_flags (flag_list r)
290
+
| "UID" ->
291
+
sp r;
292
+
Fetch.Item_uid (number32 r)
293
+
| "RFC822.SIZE" ->
294
+
sp r;
295
+
Fetch.Item_rfc822_size (number64 r)
296
+
| "INTERNALDATE" ->
297
+
sp r;
298
+
Fetch.Item_internaldate (quoted_string r)
299
+
| "ENVELOPE" ->
300
+
sp r;
301
+
Fetch.Item_envelope (envelope r)
302
+
| _ -> Fetch.Item_flags []
303
+
304
+
let fetch_items r = parse_paren_list ~parse_item:fetch_item r
305
+
306
+
(** {1 Status Items} *)
307
+
308
+
let status_item_value r =
309
+
let name = atom r in
310
+
sp r;
311
+
let value = number64 r in
312
+
let item =
313
+
match String.uppercase_ascii name with
314
+
| "MESSAGES" -> Status.Messages
315
+
| "UIDNEXT" -> Status.Uidnext
316
+
| "UIDVALIDITY" -> Status.Uidvalidity
317
+
| "UNSEEN" -> Status.Unseen
318
+
| "DELETED" -> Status.Deleted
319
+
| "SIZE" -> Status.Size
320
+
| _ -> Status.Messages
321
+
in
322
+
(item, value)
323
+
324
+
let status_items r = parse_paren_list ~parse_item:status_item_value r
325
+
326
+
(** {1 Namespace} *)
327
+
328
+
let namespace_entry r =
329
+
R.char '(' r;
330
+
let prefix = quoted_string r in
331
+
sp r;
332
+
let delimiter =
333
+
if is_nil r then (skip_nil r; None)
334
+
else Some (quoted_string r).[0]
335
+
in
336
+
R.char ')' r;
337
+
Response.{ prefix; delimiter }
338
+
339
+
let namespace_list r =
340
+
if is_nil r then (skip_nil r; None)
341
+
else (
342
+
R.char '(' r;
343
+
let rec loop acc =
344
+
match R.peek_char r with
345
+
| Some ')' ->
346
+
R.char ')' r;
347
+
Some (List.rev acc)
348
+
| Some '(' -> loop (namespace_entry r :: acc)
349
+
| Some ' ' ->
350
+
sp r;
351
+
loop acc
352
+
| _ -> Some (List.rev acc)
353
+
in
354
+
loop [])
355
+
356
+
let namespace_data r =
357
+
let personal = namespace_list r in
358
+
sp r;
359
+
let other = namespace_list r in
360
+
sp r;
361
+
let shared = namespace_list r in
362
+
Response.{ personal; other; shared }
363
+
364
+
(** {1 ID Response} *)
365
+
366
+
let id_params r =
367
+
if is_nil r then (skip_nil r; None)
368
+
else (
369
+
R.char '(' r;
370
+
let rec loop acc =
371
+
match R.peek_char r with
372
+
| Some ')' ->
373
+
R.char ')' r;
374
+
Some (List.rev acc)
375
+
| Some ' ' ->
376
+
sp r;
377
+
loop acc
378
+
| _ ->
379
+
let k = quoted_string r in
380
+
sp r;
381
+
let v = Option.value ~default:"" (nstring r) in
382
+
loop ((k, v) :: acc)
383
+
in
384
+
loop [])
385
+
386
+
(** {1 Main Response Parser} *)
387
+
388
+
let maybe_code r =
389
+
match R.peek_char r with
390
+
| Some '[' -> Some (response_code r)
391
+
| _ -> None
392
+
393
+
let rest_of_line r =
394
+
let text = R.take_while (fun c -> c <> '\r' && c <> '\n') r in
395
+
crlf r;
396
+
String.trim text
397
+
398
+
let parse_status_text r =
399
+
sp r;
400
+
let code = maybe_code r in
401
+
if R.peek_char r = Some ' ' then sp r;
402
+
let text = rest_of_line r in
403
+
(code, text)
404
+
405
+
let untagged_response r =
406
+
match R.peek_char r with
407
+
| Some c when c >= '0' && c <= '9' ->
408
+
let n = number r in
409
+
sp r;
410
+
let keyword = atom r in
411
+
(match String.uppercase_ascii keyword with
412
+
| "EXISTS" ->
413
+
crlf r;
414
+
Response.Exists n
415
+
| "EXPUNGE" ->
416
+
crlf r;
417
+
Response.Expunge n
418
+
| "FETCH" ->
419
+
sp r;
420
+
let items = fetch_items r in
421
+
crlf r;
422
+
Response.Fetch { seq = n; items }
423
+
| _ ->
424
+
let _ = rest_of_line r in
425
+
Response.Exists 0)
426
+
| _ ->
427
+
let keyword = atom r in
428
+
(match String.uppercase_ascii keyword with
429
+
| "OK" ->
430
+
let (code, text) = parse_status_text r in
431
+
Response.Ok { tag = None; code; text }
432
+
| "NO" ->
433
+
let (code, text) = parse_status_text r in
434
+
Response.No { tag = None; code; text }
435
+
| "BAD" ->
436
+
let (code, text) = parse_status_text r in
437
+
Response.Bad { tag = None; code; text }
438
+
| "PREAUTH" ->
439
+
let (code, text) = parse_status_text r in
440
+
Response.Preauth { code; text }
441
+
| "BYE" ->
442
+
let (code, text) = parse_status_text r in
443
+
Response.Bye { code; text }
444
+
| "CAPABILITY" ->
445
+
let caps = collect_atoms r in
446
+
crlf r;
447
+
Response.Capability caps
448
+
| "FLAGS" ->
449
+
sp r;
450
+
let flags = flag_list r in
451
+
crlf r;
452
+
Response.Flags flags
453
+
| "LIST" ->
454
+
sp r;
455
+
let flags = list_flag_list r in
456
+
sp r;
457
+
let delimiter =
458
+
if is_nil r then (skip_nil r; None)
459
+
else Some (quoted_string r).[0]
460
+
in
461
+
sp r;
462
+
let name = astring r in
463
+
crlf r;
464
+
Response.List { flags; delimiter; name }
465
+
| "STATUS" ->
466
+
sp r;
467
+
let mailbox = astring r in
468
+
sp r;
469
+
let items = status_items r in
470
+
crlf r;
471
+
Response.Status { mailbox; items }
472
+
| "NAMESPACE" ->
473
+
sp r;
474
+
let data = namespace_data r in
475
+
crlf r;
476
+
Response.Namespace data
477
+
| "ENABLED" ->
478
+
let exts = collect_atoms r in
479
+
crlf r;
480
+
Response.Enabled exts
481
+
| "ID" ->
482
+
sp r;
483
+
let params = id_params r in
484
+
crlf r;
485
+
Response.Id params
486
+
| _ ->
487
+
let _ = rest_of_line r in
488
+
Response.Ok { tag = None; code = None; text = "" })
489
+
490
+
let tagged_response r tag =
491
+
let keyword = atom r in
492
+
sp r;
493
+
let code = maybe_code r in
494
+
if R.peek_char r = Some ' ' then sp r;
495
+
let text = rest_of_line r in
496
+
match String.uppercase_ascii keyword with
497
+
| "OK" -> Response.Ok { tag = Some tag; code; text }
498
+
| "NO" -> Response.No { tag = Some tag; code; text }
499
+
| "BAD" -> Response.Bad { tag = Some tag; code; text }
500
+
| _ -> Response.Ok { tag = Some tag; code = None; text = "" }
501
+
502
+
let response r =
503
+
match R.any_char r with
504
+
| '*' ->
505
+
sp r;
506
+
untagged_response r
507
+
| '+' ->
508
+
let text =
509
+
if R.peek_char r = Some ' ' then (
510
+
sp r;
511
+
Some (rest_of_line r))
512
+
else (
513
+
crlf r;
514
+
None)
515
+
in
516
+
Response.Continuation text
517
+
| c ->
518
+
let rest = atom r in
519
+
let tag = String.make 1 c ^ rest in
520
+
sp r;
521
+
tagged_response r tag
522
+
523
+
let responses_until_tagged r expected_tag =
524
+
let rec loop untagged =
525
+
let resp = response r in
526
+
match resp with
527
+
| Response.Ok { tag = Some t; _ }
528
+
| Response.No { tag = Some t; _ }
529
+
| Response.Bad { tag = Some t; _ }
530
+
when t = expected_tag ->
531
+
(List.rev untagged, resp)
532
+
| _ -> loop (resp :: untagged)
533
+
in
534
+
loop []
+37
lib/imap/read.mli
+37
lib/imap/read.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Response Parsing
7
+
8
+
Parses IMAP responses from the wire format using Eio.Buf_read. *)
9
+
10
+
(** {1 Reader} *)
11
+
12
+
type t = Eio.Buf_read.t
13
+
(** A response reader. *)
14
+
15
+
val pp : Format.formatter -> t -> unit
16
+
val to_string : t -> string
17
+
18
+
(** {1 Low-level Parsers} *)
19
+
20
+
val atom : t -> string
21
+
val number : t -> int
22
+
val number32 : t -> int32
23
+
val number64 : t -> int64
24
+
val quoted_string : t -> string
25
+
val literal : t -> string
26
+
val nstring : t -> string option
27
+
val astring : t -> string
28
+
29
+
(** {1 Flags} *)
30
+
31
+
val flag : t -> Flag.t
32
+
val flag_list : t -> Flag.t list
33
+
34
+
(** {1 Response Parsing} *)
35
+
36
+
val response : t -> Response.t
37
+
val responses_until_tagged : t -> string -> Response.t list * Response.t
+87
lib/imap/response.ml
+87
lib/imap/response.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Responses
7
+
8
+
Server-to-client responses as specified in RFC 9051. *)
9
+
10
+
(** {1 Namespace} *)
11
+
12
+
type namespace_entry = { prefix : string; delimiter : char option }
13
+
14
+
type namespace = {
15
+
personal : namespace_entry list option;
16
+
other : namespace_entry list option;
17
+
shared : namespace_entry list option;
18
+
}
19
+
20
+
(** {1 ESEARCH Results} *)
21
+
22
+
type esearch_result =
23
+
| Esearch_min of int
24
+
| Esearch_max of int
25
+
| Esearch_count of int
26
+
| Esearch_all of Seq.t
27
+
28
+
(** {1 Response Type} *)
29
+
30
+
type t =
31
+
| Ok of { tag : string option; code : Code.t option; text : string }
32
+
| No of { tag : string option; code : Code.t option; text : string }
33
+
| Bad of { tag : string option; code : Code.t option; text : string }
34
+
| Preauth of { code : Code.t option; text : string }
35
+
| Bye of { code : Code.t option; text : string }
36
+
| Capability of string list
37
+
| Enabled of string list
38
+
| List of {
39
+
flags : List_attr.t list;
40
+
delimiter : char option;
41
+
name : Mailbox.t;
42
+
}
43
+
| Namespace of namespace
44
+
| Status of { mailbox : Mailbox.t; items : (Status.item * int64) list }
45
+
| Esearch of { tag : string option; uid : bool; results : esearch_result list }
46
+
| Flags of Flag.t list
47
+
| Exists of int
48
+
| Expunge of int
49
+
| Fetch of { seq : int; items : Fetch.response list }
50
+
| Continuation of string option
51
+
| Id of (string * string) list option
52
+
53
+
let pp ppf = function
54
+
| Ok { tag; code; text } ->
55
+
Fmt.pf ppf "%a OK %a%s"
56
+
Fmt.(option ~none:(any "*") string)
57
+
tag
58
+
Fmt.(option (brackets Code.pp))
59
+
code text
60
+
| No { tag; code; text } ->
61
+
Fmt.pf ppf "%a NO %a%s"
62
+
Fmt.(option ~none:(any "*") string)
63
+
tag
64
+
Fmt.(option (brackets Code.pp))
65
+
code text
66
+
| Bad { tag; code; text } ->
67
+
Fmt.pf ppf "%a BAD %a%s"
68
+
Fmt.(option ~none:(any "*") string)
69
+
tag
70
+
Fmt.(option (brackets Code.pp))
71
+
code text
72
+
| Preauth { text; _ } -> Fmt.pf ppf "* PREAUTH %s" text
73
+
| Bye { text; _ } -> Fmt.pf ppf "* BYE %s" text
74
+
| Capability caps -> Fmt.pf ppf "* CAPABILITY %a" Fmt.(list ~sep:sp string) caps
75
+
| Enabled exts -> Fmt.pf ppf "* ENABLED %a" Fmt.(list ~sep:sp string) exts
76
+
| List { name; _ } -> Fmt.pf ppf "* LIST ... %s" name
77
+
| Namespace _ -> Fmt.string ppf "* NAMESPACE ..."
78
+
| Status { mailbox; _ } -> Fmt.pf ppf "* STATUS %s (...)" mailbox
79
+
| Esearch _ -> Fmt.string ppf "* ESEARCH ..."
80
+
| Flags flags -> Fmt.pf ppf "* FLAGS (%a)" Fmt.(list ~sep:sp Flag.pp) flags
81
+
| Exists n -> Fmt.pf ppf "* %d EXISTS" n
82
+
| Expunge n -> Fmt.pf ppf "* %d EXPUNGE" n
83
+
| Fetch { seq; _ } -> Fmt.pf ppf "* %d FETCH (...)" seq
84
+
| Continuation text -> Fmt.pf ppf "+ %a" Fmt.(option string) text
85
+
| Id _ -> Fmt.string ppf "* ID ..."
86
+
87
+
let to_string r = Fmt.str "%a" pp r
+54
lib/imap/response.mli
+54
lib/imap/response.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Responses
7
+
8
+
Server-to-client responses as specified in RFC 9051. *)
9
+
10
+
(** {1 Namespace} *)
11
+
12
+
type namespace_entry = { prefix : string; delimiter : char option }
13
+
14
+
type namespace = {
15
+
personal : namespace_entry list option;
16
+
other : namespace_entry list option;
17
+
shared : namespace_entry list option;
18
+
}
19
+
20
+
(** {1 ESEARCH Results} *)
21
+
22
+
type esearch_result =
23
+
| Esearch_min of int
24
+
| Esearch_max of int
25
+
| Esearch_count of int
26
+
| Esearch_all of Seq.t
27
+
28
+
(** {1 Response Type} *)
29
+
30
+
type t =
31
+
| Ok of { tag : string option; code : Code.t option; text : string }
32
+
| No of { tag : string option; code : Code.t option; text : string }
33
+
| Bad of { tag : string option; code : Code.t option; text : string }
34
+
| Preauth of { code : Code.t option; text : string }
35
+
| Bye of { code : Code.t option; text : string }
36
+
| Capability of string list
37
+
| Enabled of string list
38
+
| List of {
39
+
flags : List_attr.t list;
40
+
delimiter : char option;
41
+
name : Mailbox.t;
42
+
}
43
+
| Namespace of namespace
44
+
| Status of { mailbox : Mailbox.t; items : (Status.item * int64) list }
45
+
| Esearch of { tag : string option; uid : bool; results : esearch_result list }
46
+
| Flags of Flag.t list
47
+
| Exists of int
48
+
| Expunge of int
49
+
| Fetch of { seq : int; items : Fetch.response list }
50
+
| Continuation of string option
51
+
| Id of (string * string) list option
52
+
53
+
val pp : Format.formatter -> t -> unit
54
+
val to_string : t -> string
+46
lib/imap/search.ml
+46
lib/imap/search.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** SEARCH Criteria
7
+
8
+
Search keys for the SEARCH command as specified in RFC 9051 Section 6.4.4. *)
9
+
10
+
type t =
11
+
| All
12
+
| Answered
13
+
| Bcc of string
14
+
| Before of string
15
+
| Body of string
16
+
| Cc of string
17
+
| Deleted
18
+
| Flagged
19
+
| From of string
20
+
| Keyword of string
21
+
| New
22
+
| Not of t
23
+
| Old
24
+
| On of string
25
+
| Or of t * t
26
+
| Seen
27
+
| Since of string
28
+
| Subject of string
29
+
| Text of string
30
+
| To of string
31
+
| Unanswered
32
+
| Undeleted
33
+
| Unflagged
34
+
| Unkeyword of string
35
+
| Unseen
36
+
| Draft
37
+
| Undraft
38
+
| Header of string * string
39
+
| Larger of int64
40
+
| Smaller of int64
41
+
| Uid of Seq.t
42
+
| Sequence_set of Seq.t
43
+
| And of t list
44
+
| Sentbefore of string
45
+
| Senton of string
46
+
| Sentsince of string
+46
lib/imap/search.mli
+46
lib/imap/search.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** SEARCH Criteria
7
+
8
+
Search keys for the SEARCH command as specified in RFC 9051 Section 6.4.4. *)
9
+
10
+
type t =
11
+
| All
12
+
| Answered
13
+
| Bcc of string
14
+
| Before of string
15
+
| Body of string
16
+
| Cc of string
17
+
| Deleted
18
+
| Flagged
19
+
| From of string
20
+
| Keyword of string
21
+
| New
22
+
| Not of t
23
+
| Old
24
+
| On of string
25
+
| Or of t * t
26
+
| Seen
27
+
| Since of string
28
+
| Subject of string
29
+
| Text of string
30
+
| To of string
31
+
| Unanswered
32
+
| Undeleted
33
+
| Unflagged
34
+
| Unkeyword of string
35
+
| Unseen
36
+
| Draft
37
+
| Undraft
38
+
| Header of string * string
39
+
| Larger of int64
40
+
| Smaller of int64
41
+
| Uid of Seq.t
42
+
| Sequence_set of Seq.t
43
+
| And of t list
44
+
| Sentbefore of string
45
+
| Senton of string
46
+
| Sentsince of string
+31
lib/imap/seq.ml
+31
lib/imap/seq.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Sequence Sets
7
+
8
+
IMAP sequence sets for addressing messages by sequence number or UID.
9
+
See RFC 9051 Section 9. *)
10
+
11
+
type range =
12
+
| Single of int (** A single message number *)
13
+
| Range of int * int (** An inclusive range [a:b] *)
14
+
| From of int (** From n to the end [n:*] *)
15
+
| All (** All messages [*] *)
16
+
17
+
let pp_range ppf = function
18
+
| Single n -> Fmt.int ppf n
19
+
| Range (a, b) -> Fmt.pf ppf "%d:%d" a b
20
+
| From n -> Fmt.pf ppf "%d:*" n
21
+
| All -> Fmt.string ppf "*"
22
+
23
+
type t = range list
24
+
25
+
let pp ppf set = Fmt.(list ~sep:comma pp_range) ppf set
26
+
let to_string set = Fmt.str "%a" pp set
27
+
28
+
let single n = [ Single n ]
29
+
let range a b = [ Range (a, b) ]
30
+
let from n = [ From n ]
31
+
let all = [ All ]
+29
lib/imap/seq.mli
+29
lib/imap/seq.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Sequence Sets
7
+
8
+
IMAP sequence sets for addressing messages by sequence number or UID.
9
+
See RFC 9051 Section 9. *)
10
+
11
+
type range =
12
+
| Single of int (** A single message number *)
13
+
| Range of int * int (** An inclusive range [a:b] *)
14
+
| From of int (** From n to the end [n:*] *)
15
+
| All (** All messages [*] *)
16
+
17
+
val pp_range : Format.formatter -> range -> unit
18
+
19
+
type t = range list
20
+
21
+
val pp : Format.formatter -> t -> unit
22
+
val to_string : t -> string
23
+
24
+
(** {1 Constructors} *)
25
+
26
+
val single : int -> t
27
+
val range : int -> int -> t
28
+
val from : int -> t
29
+
val all : t
+43
lib/imap/status.ml
+43
lib/imap/status.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** STATUS Command Items
7
+
8
+
Status items for the STATUS command as specified in RFC 9051 Section 6.3.11. *)
9
+
10
+
type item =
11
+
| Messages
12
+
| Uidnext
13
+
| Uidvalidity
14
+
| Unseen
15
+
| Deleted
16
+
| Size
17
+
18
+
let pp_item ppf = function
19
+
| Messages -> Fmt.string ppf "MESSAGES"
20
+
| Uidnext -> Fmt.string ppf "UIDNEXT"
21
+
| Uidvalidity -> Fmt.string ppf "UIDVALIDITY"
22
+
| Unseen -> Fmt.string ppf "UNSEEN"
23
+
| Deleted -> Fmt.string ppf "DELETED"
24
+
| Size -> Fmt.string ppf "SIZE"
25
+
26
+
type t = {
27
+
mailbox : string;
28
+
messages : int64 option;
29
+
uidnext : int64 option;
30
+
uidvalidity : int64 option;
31
+
unseen : int64 option;
32
+
}
33
+
34
+
let pp ppf s =
35
+
Fmt.pf ppf "@[<v>%s:@,messages=%a@,uidnext=%a@,uidvalidity=%a@,unseen=%a@]"
36
+
s.mailbox
37
+
Fmt.(option int64) s.messages
38
+
Fmt.(option int64) s.uidnext
39
+
Fmt.(option int64) s.uidvalidity
40
+
Fmt.(option int64) s.unseen
41
+
42
+
let empty mailbox =
43
+
{ mailbox; messages = None; uidnext = None; uidvalidity = None; unseen = None }
+29
lib/imap/status.mli
+29
lib/imap/status.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** STATUS Command Items
7
+
8
+
Status items for the STATUS command as specified in RFC 9051 Section 6.3.11. *)
9
+
10
+
type item =
11
+
| Messages
12
+
| Uidnext
13
+
| Uidvalidity
14
+
| Unseen
15
+
| Deleted
16
+
| Size
17
+
18
+
val pp_item : Format.formatter -> item -> unit
19
+
20
+
type t = {
21
+
mailbox : string;
22
+
messages : int64 option;
23
+
uidnext : int64 option;
24
+
uidvalidity : int64 option;
25
+
unseen : int64 option;
26
+
}
27
+
28
+
val pp : Format.formatter -> t -> unit
29
+
val empty : string -> t
+21
lib/imap/store.ml
+21
lib/imap/store.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** STORE Command Actions
7
+
8
+
Store actions for modifying message flags.
9
+
See RFC 9051 Section 6.4.6. *)
10
+
11
+
type t =
12
+
| Set (** Replace flags *)
13
+
| Add (** Add flags *)
14
+
| Remove (** Remove flags *)
15
+
16
+
let pp ppf = function
17
+
| Set -> Fmt.string ppf "FLAGS"
18
+
| Add -> Fmt.string ppf "+FLAGS"
19
+
| Remove -> Fmt.string ppf "-FLAGS"
20
+
21
+
let to_string a = Fmt.str "%a" pp a
+17
lib/imap/store.mli
+17
lib/imap/store.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** STORE Command Actions
7
+
8
+
Store actions for modifying message flags.
9
+
See RFC 9051 Section 6.4.6. *)
10
+
11
+
type t =
12
+
| Set (** Replace flags *)
13
+
| Add (** Add flags *)
14
+
| Remove (** Remove flags *)
15
+
16
+
val pp : Format.formatter -> t -> unit
17
+
val to_string : t -> string
+445
lib/imap/write.ml
+445
lib/imap/write.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Command Serialization
7
+
8
+
Serializes IMAP commands to the wire format using Eio.Buf_write. *)
9
+
10
+
module W = Eio.Buf_write
11
+
12
+
(** {1 Abstract Type} *)
13
+
14
+
type t = W.t
15
+
(** A command writer backed by Eio.Buf_write. *)
16
+
17
+
let pp ppf _ = Fmt.string ppf "<Imap.Write.t>"
18
+
let to_string _ = "<Imap.Write.t>"
19
+
20
+
(** {1 Low-level Writers} *)
21
+
22
+
let sp w = W.char w ' '
23
+
let crlf w = W.string w "\r\n"
24
+
25
+
let is_atom_char = function
26
+
| '(' | ')' | '{' | ' ' | '\x00' .. '\x1f' | '\x7f' | '%' | '*' | '"' | '\\'
27
+
| ']' ->
28
+
false
29
+
| c -> c >= '\x21' && c <= '\x7e'
30
+
31
+
let is_atom s = String.length s > 0 && String.for_all is_atom_char s
32
+
33
+
let atom w s = W.string w s
34
+
35
+
let quoted_string w s =
36
+
W.char w '"';
37
+
String.iter
38
+
(fun c ->
39
+
match c with
40
+
| '"' | '\\' ->
41
+
W.char w '\\';
42
+
W.char w c
43
+
| _ -> W.char w c)
44
+
s;
45
+
W.char w '"'
46
+
47
+
let literal w s =
48
+
W.char w '{';
49
+
W.string w (string_of_int (String.length s));
50
+
W.string w "}\r\n";
51
+
W.string w s
52
+
53
+
let literal_plus w s =
54
+
W.char w '{';
55
+
W.string w (string_of_int (String.length s));
56
+
W.string w "+}\r\n";
57
+
W.string w s
58
+
59
+
let needs_literal s =
60
+
String.exists (function '\r' | '\n' | '\x00' -> true | _ -> false) s
61
+
62
+
let astring w s =
63
+
if is_atom s then atom w s
64
+
else if needs_literal s then literal w s
65
+
else quoted_string w s
66
+
67
+
let nstring w = function
68
+
| None -> W.string w "NIL"
69
+
| Some s -> if needs_literal s then literal w s else quoted_string w s
70
+
71
+
let number w n = W.string w (string_of_int n)
72
+
let number32 w n = W.string w (Int32.to_string n)
73
+
let number64 w n = W.string w (Int64.to_string n)
74
+
75
+
(** {1 Sequence Sets} *)
76
+
77
+
let sequence_range w = function
78
+
| Seq.Single n -> number w n
79
+
| Seq.Range (a, b) ->
80
+
number w a;
81
+
W.char w ':';
82
+
number w b
83
+
| Seq.From n ->
84
+
number w n;
85
+
W.string w ":*"
86
+
| Seq.All -> W.char w '*'
87
+
88
+
let sequence_set w set =
89
+
List.iteri
90
+
(fun i r ->
91
+
if i > 0 then W.char w ',';
92
+
sequence_range w r)
93
+
set
94
+
95
+
(** {1 Flags} *)
96
+
97
+
let system_flag w = function
98
+
| Flag.Seen -> W.string w "\\Seen"
99
+
| Flag.Answered -> W.string w "\\Answered"
100
+
| Flag.Flagged -> W.string w "\\Flagged"
101
+
| Flag.Deleted -> W.string w "\\Deleted"
102
+
| Flag.Draft -> W.string w "\\Draft"
103
+
104
+
let flag w = function
105
+
| Flag.System f -> system_flag w f
106
+
| Flag.Keyword k ->
107
+
W.char w '$';
108
+
W.string w k
109
+
110
+
let flag_list w flags =
111
+
W.char w '(';
112
+
List.iteri
113
+
(fun i f ->
114
+
if i > 0 then sp w;
115
+
flag w f)
116
+
flags;
117
+
W.char w ')'
118
+
119
+
(** {1 Search Keys} *)
120
+
121
+
let rec search_key w = function
122
+
| Search.All -> W.string w "ALL"
123
+
| Search.Answered -> W.string w "ANSWERED"
124
+
| Search.Bcc s ->
125
+
W.string w "BCC ";
126
+
astring w s
127
+
| Search.Before s ->
128
+
W.string w "BEFORE ";
129
+
atom w s
130
+
| Search.Body s ->
131
+
W.string w "BODY ";
132
+
astring w s
133
+
| Search.Cc s ->
134
+
W.string w "CC ";
135
+
astring w s
136
+
| Search.Deleted -> W.string w "DELETED"
137
+
| Search.Flagged -> W.string w "FLAGGED"
138
+
| Search.From s ->
139
+
W.string w "FROM ";
140
+
astring w s
141
+
| Search.Keyword s ->
142
+
W.string w "KEYWORD ";
143
+
atom w s
144
+
| Search.New -> W.string w "NEW"
145
+
| Search.Not k ->
146
+
W.string w "NOT ";
147
+
search_key w k
148
+
| Search.Old -> W.string w "OLD"
149
+
| Search.On s ->
150
+
W.string w "ON ";
151
+
atom w s
152
+
| Search.Or (k1, k2) ->
153
+
W.string w "OR ";
154
+
search_key w k1;
155
+
sp w;
156
+
search_key w k2
157
+
| Search.Seen -> W.string w "SEEN"
158
+
| Search.Since s ->
159
+
W.string w "SINCE ";
160
+
atom w s
161
+
| Search.Subject s ->
162
+
W.string w "SUBJECT ";
163
+
astring w s
164
+
| Search.Text s ->
165
+
W.string w "TEXT ";
166
+
astring w s
167
+
| Search.To s ->
168
+
W.string w "TO ";
169
+
astring w s
170
+
| Search.Unanswered -> W.string w "UNANSWERED"
171
+
| Search.Undeleted -> W.string w "UNDELETED"
172
+
| Search.Unflagged -> W.string w "UNFLAGGED"
173
+
| Search.Unkeyword s ->
174
+
W.string w "UNKEYWORD ";
175
+
atom w s
176
+
| Search.Unseen -> W.string w "UNSEEN"
177
+
| Search.Draft -> W.string w "DRAFT"
178
+
| Search.Undraft -> W.string w "UNDRAFT"
179
+
| Search.Header (field, value) ->
180
+
W.string w "HEADER ";
181
+
astring w field;
182
+
sp w;
183
+
astring w value
184
+
| Search.Larger n ->
185
+
W.string w "LARGER ";
186
+
number64 w n
187
+
| Search.Smaller n ->
188
+
W.string w "SMALLER ";
189
+
number64 w n
190
+
| Search.Uid set ->
191
+
W.string w "UID ";
192
+
sequence_set w set
193
+
| Search.Sequence_set set -> sequence_set w set
194
+
| Search.And keys ->
195
+
W.char w '(';
196
+
List.iteri
197
+
(fun i k ->
198
+
if i > 0 then sp w;
199
+
search_key w k)
200
+
keys;
201
+
W.char w ')'
202
+
| Search.Sentbefore s ->
203
+
W.string w "SENTBEFORE ";
204
+
atom w s
205
+
| Search.Senton s ->
206
+
W.string w "SENTON ";
207
+
atom w s
208
+
| Search.Sentsince s ->
209
+
W.string w "SENTSINCE ";
210
+
atom w s
211
+
212
+
(** {1 Fetch Items} *)
213
+
214
+
let write_partial w = function
215
+
| Some (offset, len) ->
216
+
W.char w '<';
217
+
number w offset;
218
+
W.char w '.';
219
+
number w len;
220
+
W.char w '>'
221
+
| None -> ()
222
+
223
+
let fetch_item w = function
224
+
| Fetch.Envelope -> W.string w "ENVELOPE"
225
+
| Fetch.Flags -> W.string w "FLAGS"
226
+
| Fetch.Internaldate -> W.string w "INTERNALDATE"
227
+
| Fetch.Rfc822 -> W.string w "RFC822"
228
+
| Fetch.Rfc822_size -> W.string w "RFC822.SIZE"
229
+
| Fetch.Rfc822_header -> W.string w "RFC822.HEADER"
230
+
| Fetch.Rfc822_text -> W.string w "RFC822.TEXT"
231
+
| Fetch.Uid -> W.string w "UID"
232
+
| Fetch.Body -> W.string w "BODY"
233
+
| Fetch.Bodystructure -> W.string w "BODYSTRUCTURE"
234
+
| Fetch.Body_section (section, partial) ->
235
+
W.string w "BODY["; W.string w section; W.char w ']';
236
+
write_partial w partial
237
+
| Fetch.Body_peek (section, partial) ->
238
+
W.string w "BODY.PEEK["; W.string w section; W.char w ']';
239
+
write_partial w partial
240
+
| Fetch.Binary (section, partial) ->
241
+
W.string w "BINARY["; W.string w section; W.char w ']';
242
+
write_partial w partial
243
+
| Fetch.Binary_peek (section, partial) ->
244
+
W.string w "BINARY.PEEK["; W.string w section; W.char w ']';
245
+
write_partial w partial
246
+
| Fetch.Binary_size section ->
247
+
W.string w "BINARY.SIZE["; W.string w section; W.char w ']'
248
+
249
+
let fetch_items w = function
250
+
| [ item ] -> fetch_item w item
251
+
| items ->
252
+
W.char w '(';
253
+
List.iteri
254
+
(fun i item ->
255
+
if i > 0 then sp w;
256
+
fetch_item w item)
257
+
items;
258
+
W.char w ')'
259
+
260
+
(** {1 Status Items} *)
261
+
262
+
let status_item w = function
263
+
| Status.Messages -> W.string w "MESSAGES"
264
+
| Status.Uidnext -> W.string w "UIDNEXT"
265
+
| Status.Uidvalidity -> W.string w "UIDVALIDITY"
266
+
| Status.Unseen -> W.string w "UNSEEN"
267
+
| Status.Deleted -> W.string w "DELETED"
268
+
| Status.Size -> W.string w "SIZE"
269
+
270
+
let status_items w items =
271
+
W.char w '(';
272
+
List.iteri
273
+
(fun i item ->
274
+
if i > 0 then sp w;
275
+
status_item w item)
276
+
items;
277
+
W.char w ')'
278
+
279
+
(** {1 Store Actions} *)
280
+
281
+
let store_action w = function
282
+
| Store.Set -> W.string w "FLAGS"
283
+
| Store.Add -> W.string w "+FLAGS"
284
+
| Store.Remove -> W.string w "-FLAGS"
285
+
286
+
(** {1 ID Parameters} *)
287
+
288
+
let id_params w = function
289
+
| None -> W.string w "NIL"
290
+
| Some pairs ->
291
+
W.char w '(';
292
+
List.iteri
293
+
(fun i (k, v) ->
294
+
if i > 0 then sp w;
295
+
quoted_string w k;
296
+
sp w;
297
+
quoted_string w v)
298
+
pairs;
299
+
W.char w ')'
300
+
301
+
(** {1 Commands} *)
302
+
303
+
let write_search w charset criteria =
304
+
W.string w "SEARCH";
305
+
Option.iter (fun cs -> W.string w " CHARSET "; astring w cs) charset;
306
+
sp w;
307
+
search_key w criteria
308
+
309
+
let command_body w = function
310
+
| Command.Capability -> W.string w "CAPABILITY"
311
+
| Command.Noop -> W.string w "NOOP"
312
+
| Command.Logout -> W.string w "LOGOUT"
313
+
| Command.Starttls -> W.string w "STARTTLS"
314
+
| Command.Login { username; password } ->
315
+
W.string w "LOGIN ";
316
+
astring w username;
317
+
sp w;
318
+
astring w password
319
+
| Command.Authenticate { mechanism; initial_response } ->
320
+
W.string w "AUTHENTICATE ";
321
+
atom w mechanism;
322
+
Option.iter (fun r -> sp w; W.string w r) initial_response
323
+
| Command.Enable caps ->
324
+
W.string w "ENABLE";
325
+
List.iter (fun c -> sp w; atom w c) caps
326
+
| Command.Select mailbox ->
327
+
W.string w "SELECT ";
328
+
astring w mailbox
329
+
| Command.Examine mailbox ->
330
+
W.string w "EXAMINE ";
331
+
astring w mailbox
332
+
| Command.Create mailbox ->
333
+
W.string w "CREATE ";
334
+
astring w mailbox
335
+
| Command.Delete mailbox ->
336
+
W.string w "DELETE ";
337
+
astring w mailbox
338
+
| Command.Rename { old_name; new_name } ->
339
+
W.string w "RENAME ";
340
+
astring w old_name;
341
+
sp w;
342
+
astring w new_name
343
+
| Command.Subscribe mailbox ->
344
+
W.string w "SUBSCRIBE ";
345
+
astring w mailbox
346
+
| Command.Unsubscribe mailbox ->
347
+
W.string w "UNSUBSCRIBE ";
348
+
astring w mailbox
349
+
| Command.List { reference; pattern } ->
350
+
W.string w "LIST ";
351
+
astring w reference;
352
+
sp w;
353
+
astring w pattern
354
+
| Command.Namespace -> W.string w "NAMESPACE"
355
+
| Command.Status { mailbox; items } ->
356
+
W.string w "STATUS ";
357
+
astring w mailbox;
358
+
sp w;
359
+
status_items w items
360
+
| Command.Append { mailbox; flags; date; message } ->
361
+
W.string w "APPEND ";
362
+
astring w mailbox;
363
+
(match flags with
364
+
| [] -> ()
365
+
| flags -> sp w; flag_list w flags);
366
+
Option.iter (fun d -> sp w; quoted_string w d) date;
367
+
sp w;
368
+
literal w message
369
+
| Command.Idle -> W.string w "IDLE"
370
+
| Command.Close -> W.string w "CLOSE"
371
+
| Command.Unselect -> W.string w "UNSELECT"
372
+
| Command.Expunge -> W.string w "EXPUNGE"
373
+
| Command.Search { charset; criteria } ->
374
+
write_search w charset criteria
375
+
| Command.Fetch { sequence; items } ->
376
+
W.string w "FETCH ";
377
+
sequence_set w sequence;
378
+
sp w;
379
+
fetch_items w items
380
+
| Command.Store { sequence; silent; action; flags } ->
381
+
W.string w "STORE ";
382
+
sequence_set w sequence;
383
+
sp w;
384
+
store_action w action;
385
+
if silent then W.string w ".SILENT";
386
+
sp w;
387
+
flag_list w flags
388
+
| Command.Copy { sequence; mailbox } ->
389
+
W.string w "COPY ";
390
+
sequence_set w sequence;
391
+
sp w;
392
+
astring w mailbox
393
+
| Command.Move { sequence; mailbox } ->
394
+
W.string w "MOVE ";
395
+
sequence_set w sequence;
396
+
sp w;
397
+
astring w mailbox
398
+
| Command.Uid cmd -> (
399
+
W.string w "UID ";
400
+
match cmd with
401
+
| Command.Uid_fetch { sequence; items } ->
402
+
W.string w "FETCH ";
403
+
sequence_set w sequence;
404
+
sp w;
405
+
fetch_items w items
406
+
| Command.Uid_store { sequence; silent; action; flags } ->
407
+
W.string w "STORE ";
408
+
sequence_set w sequence;
409
+
sp w;
410
+
store_action w action;
411
+
if silent then W.string w ".SILENT";
412
+
sp w;
413
+
flag_list w flags
414
+
| Command.Uid_copy { sequence; mailbox } ->
415
+
W.string w "COPY ";
416
+
sequence_set w sequence;
417
+
sp w;
418
+
astring w mailbox
419
+
| Command.Uid_move { sequence; mailbox } ->
420
+
W.string w "MOVE ";
421
+
sequence_set w sequence;
422
+
sp w;
423
+
astring w mailbox
424
+
| Command.Uid_search { charset; criteria } ->
425
+
write_search w charset criteria
426
+
| Command.Uid_expunge set ->
427
+
W.string w "EXPUNGE ";
428
+
sequence_set w set)
429
+
| Command.Id params ->
430
+
W.string w "ID ";
431
+
id_params w params
432
+
433
+
let command w ~tag cmd =
434
+
atom w tag;
435
+
sp w;
436
+
command_body w cmd;
437
+
crlf w
438
+
439
+
let idle_done w =
440
+
W.string w "DONE";
441
+
crlf w
442
+
443
+
let authenticate_response w data =
444
+
W.string w data;
445
+
crlf w
+50
lib/imap/write.mli
+50
lib/imap/write.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Command Serialization
7
+
8
+
Serializes IMAP commands to the wire format using Eio.Buf_write. *)
9
+
10
+
(** {1 Writer} *)
11
+
12
+
type t = Eio.Buf_write.t
13
+
(** A command writer. *)
14
+
15
+
val pp : Format.formatter -> t -> unit
16
+
val to_string : t -> string
17
+
18
+
(** {1 Low-level Writers} *)
19
+
20
+
val atom : t -> string -> unit
21
+
val quoted_string : t -> string -> unit
22
+
val literal : t -> string -> unit
23
+
val literal_plus : t -> string -> unit
24
+
val astring : t -> string -> unit
25
+
val nstring : t -> string option -> unit
26
+
val number : t -> int -> unit
27
+
val number32 : t -> int32 -> unit
28
+
val number64 : t -> int64 -> unit
29
+
30
+
(** {1 Sequence Sets} *)
31
+
32
+
val sequence_range : t -> Seq.range -> unit
33
+
val sequence_set : t -> Seq.t -> unit
34
+
35
+
(** {1 Flags} *)
36
+
37
+
val flag : t -> Flag.t -> unit
38
+
val flag_list : t -> Flag.t list -> unit
39
+
40
+
(** {1 Search and Fetch} *)
41
+
42
+
val search_key : t -> Search.t -> unit
43
+
val fetch_item : t -> Fetch.request -> unit
44
+
val fetch_items : t -> Fetch.request list -> unit
45
+
46
+
(** {1 Commands} *)
47
+
48
+
val command : t -> tag:string -> Command.t -> unit
49
+
val idle_done : t -> unit
50
+
val authenticate_response : t -> string -> unit
-8
lib/imap_auth/dune
-8
lib/imap_auth/dune
+2
-1
lib/imap_auth/imap_auth.ml
lib/imapd/auth.ml
+2
-1
lib/imap_auth/imap_auth.ml
lib/imapd/auth.ml
···
35
35
module Mock_auth = struct
36
36
type t = {
37
37
mutable users : (string * string) list;
38
-
service_name : string;
38
+
service_name : string; [@warning "-69"]
39
+
(** Kept for API compatibility with [Pam_auth] *)
39
40
}
40
41
41
42
let create ~service_name = { users = []; service_name }
lib/imap_auth/imap_auth.mli
lib/imapd/auth.mli
lib/imap_auth/imap_auth.mli
lib/imapd/auth.mli
lib/imap_auth/pam_stubs.c
lib/imapd/pam_stubs.c
lib/imap_auth/pam_stubs.c
lib/imapd/pam_stubs.c
-9
lib/imap_parser/dune
-9
lib/imap_parser/dune
-29
lib/imap_parser/imap_grammar.conflicts
-29
lib/imap_parser/imap_grammar.conflicts
···
1
-
2
-
** Conflict (reduce/reduce) in state 310.
3
-
** Tokens involved: EOF CRLF
4
-
** The following explanations concentrate on token EOF.
5
-
** This state is reached from command after reading:
6
-
7
-
tag SP LIST SP astring SP QUOTED_STRING
8
-
9
-
** The derivations that appear below have the following common factor:
10
-
** (The question mark symbol (?) represents the spot where the derivations begin to differ.)
11
-
12
-
command
13
-
tag SP command_body EOF // lookahead token appears
14
-
command_auth // lookahead token is inherited
15
-
LIST SP astring SP list_mailbox // lookahead token is inherited
16
-
(?)
17
-
18
-
** In state 310, looking ahead at EOF, reducing production
19
-
** astring -> QUOTED_STRING
20
-
** is permitted because of the following sub-derivation:
21
-
22
-
astring // lookahead token is inherited
23
-
QUOTED_STRING .
24
-
25
-
** In state 310, looking ahead at EOF, reducing production
26
-
** list_mailbox -> QUOTED_STRING
27
-
** is permitted because of the following sub-derivation:
28
-
29
-
QUOTED_STRING .
+3
-3
lib/imap_parser/imap_grammar.mly
lib/imapd/grammar.mly
+3
-3
lib/imap_parser/imap_grammar.mly
lib/imapd/grammar.mly
···
9
9
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-9}RFC 9051 Section 9}. *)
10
10
11
11
%{
12
-
open Imap_types
12
+
open Protocol
13
13
%}
14
14
15
15
(* Tokens *)
···
62
62
%token RETURN SUBSCRIBED CHILDREN REMOTE RECURSIVEMATCH DONE
63
63
64
64
(* Entry point *)
65
-
%start <Imap_types.tagged_command> command
66
-
%start <Imap_types.response> response_parser
65
+
%start <Protocol.tagged_command> command
66
+
%start <Protocol.response> response_parser
67
67
68
68
%%
69
69
+1
-1
lib/imap_parser/imap_lexer.mll
lib/imapd/lexer.mll
+1
-1
lib/imap_parser/imap_lexer.mll
lib/imapd/lexer.mll
+9
-9
lib/imap_parser/imap_parser.ml
lib/imapd/parser.ml
+9
-9
lib/imap_parser/imap_parser.ml
lib/imapd/parser.ml
···
9
9
10
10
This module uses Menhir for parsing and Faraday for response serialization. *)
11
11
12
-
open Imap_types
12
+
open Protocol
13
13
14
-
(* Re-export types from Imap_types for backward compatibility *)
15
-
type command = Imap_types.command =
14
+
(* Re-export types from Types for backward compatibility *)
15
+
type command = Protocol.command =
16
16
| Capability
17
17
| Noop
18
18
| Logout
···
43
43
| Uid of uid_command
44
44
| Id of (string * string) list option
45
45
46
-
type uid_command = Imap_types.uid_command =
46
+
type uid_command = Protocol.uid_command =
47
47
| Uid_fetch of { sequence : sequence_set; items : fetch_item list }
48
48
| Uid_store of { sequence : sequence_set; silent : bool; action : store_action; flags : flag list }
49
49
| Uid_copy of { sequence : sequence_set; mailbox : mailbox_name }
···
51
51
| Uid_search of { charset : string option; criteria : search_key }
52
52
| Uid_expunge of sequence_set
53
53
54
-
type tagged_command = Imap_types.tagged_command = {
54
+
type tagged_command = Protocol.tagged_command = {
55
55
tag : string;
56
56
command : command;
57
57
}
58
58
59
-
type response = Imap_types.response =
59
+
type response = Protocol.response =
60
60
| Ok of { tag : string option; code : response_code option; text : string }
61
61
| No of { tag : string option; code : response_code option; text : string }
62
62
| Bad of { tag : string option; code : response_code option; text : string }
···
80
80
let parse_command input =
81
81
let lexbuf = Lexing.from_string input in
82
82
try
83
-
Result.Ok (Imap_grammar.command Imap_lexer.token lexbuf)
83
+
Result.Ok (Grammar.command Lexer.token lexbuf)
84
84
with
85
-
| Imap_lexer.Lexer_error msg -> Result.Error ("Lexer error: " ^ msg)
86
-
| Imap_grammar.Error ->
85
+
| Lexer.Lexer_error msg -> Result.Error ("Lexer error: " ^ msg)
86
+
| Grammar.Error ->
87
87
let pos = lexbuf.Lexing.lex_curr_p in
88
88
Result.Error (Printf.sprintf "Parse error at line %d, column %d"
89
89
pos.Lexing.pos_lnum
+6
-6
lib/imap_parser/imap_parser.mli
lib/imapd/parser.mli
+6
-6
lib/imap_parser/imap_parser.mli
lib/imapd/parser.mli
···
9
9
10
10
This module uses Menhir for parsing and Faraday for response serialization. *)
11
11
12
-
open Imap_types
12
+
open Protocol
13
13
14
14
(** {1 Type Re-exports}
15
15
16
-
Types are defined in {!Imap_types} and re-exported here for convenience. *)
16
+
Types are defined in {!Types} and re-exported here for convenience. *)
17
17
18
-
type command = Imap_types.command =
18
+
type command = Protocol.command =
19
19
| Capability
20
20
| Noop
21
21
| Logout
···
46
46
| Uid of uid_command
47
47
| Id of (string * string) list option
48
48
49
-
type uid_command = Imap_types.uid_command =
49
+
type uid_command = Protocol.uid_command =
50
50
| Uid_fetch of { sequence : sequence_set; items : fetch_item list }
51
51
| Uid_store of { sequence : sequence_set; silent : bool; action : store_action; flags : flag list }
52
52
| Uid_copy of { sequence : sequence_set; mailbox : mailbox_name }
···
54
54
| Uid_search of { charset : string option; criteria : search_key }
55
55
| Uid_expunge of sequence_set
56
56
57
-
type tagged_command = Imap_types.tagged_command = {
57
+
type tagged_command = Protocol.tagged_command = {
58
58
tag : string;
59
59
command : command;
60
60
}
61
61
62
-
type response = Imap_types.response =
62
+
type response = Protocol.response =
63
63
| Ok of { tag : string option; code : response_code option; text : string }
64
64
| No of { tag : string option; code : response_code option; text : string }
65
65
| Bad of { tag : string option; code : response_code option; text : string }
-4
lib/imap_server/dune
-4
lib/imap_server/dune
+26
-23
lib/imap_server/imap_server.ml
lib/imapd/server.ml
+26
-23
lib/imap_server/imap_server.ml
lib/imapd/server.ml
···
7
7
8
8
Implements {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} state machine. *)
9
9
10
-
open Imap_types
11
-
open Imap_parser
10
+
open Protocol
11
+
open Parser
12
+
13
+
(* Module alias to access Storage types without conflicting with functor parameter *)
14
+
module Storage_types = Storage
12
15
13
16
(* Base capabilities per RFC 9051 *)
14
17
let base_capabilities_pre_tls = [
···
56
59
}
57
60
58
61
module Make
59
-
(Storage : Imap_storage.STORAGE)
60
-
(Auth : Imap_auth.AUTH) = struct
62
+
(Storage : Storage.STORAGE)
63
+
(Auth : Auth.AUTH) = struct
61
64
62
65
type connection_state =
63
66
| Not_authenticated
···
134
137
match state with
135
138
| Not_authenticated ->
136
139
(* Security: Validate username before authentication *)
137
-
if not (Imap_types.is_safe_username username) then begin
140
+
if not (Protocol.is_safe_username username) then begin
138
141
send_response flow (No {
139
142
tag = Some tag;
140
143
code = Some Code_authenticationfailed;
···
182
185
state
183
186
| Some username ->
184
187
(* Security: Validate mailbox name *)
185
-
if not (Imap_types.is_safe_mailbox_name mailbox) then begin
188
+
if not (Protocol.is_safe_mailbox_name mailbox) then begin
186
189
send_response flow (No {
187
190
tag = Some tag;
188
191
code = None;
···
243
246
state
244
247
| Some username ->
245
248
let mailboxes = Storage.list_mailboxes t.storage ~username ~reference ~pattern in
246
-
List.iter (fun (mb : Imap_storage.mailbox_info) ->
249
+
List.iter (fun (mb : Storage_types.mailbox_info) ->
247
250
send_response flow (List_response {
248
251
flags = mb.flags;
249
252
delimiter = mb.delimiter;
···
256
259
(* Process STATUS command *)
257
260
let handle_status t flow tag mailbox ~items state =
258
261
(* Security: Validate mailbox name *)
259
-
if not (Imap_types.is_safe_mailbox_name mailbox) then begin
262
+
if not (Protocol.is_safe_mailbox_name mailbox) then begin
260
263
send_response flow (No { tag = Some tag; code = None; text = "Invalid mailbox name" });
261
264
state
262
265
end else
···
404
407
(* Process CREATE command *)
405
408
let handle_create t flow tag mailbox state =
406
409
(* Security: Validate mailbox name *)
407
-
if not (Imap_types.is_safe_mailbox_name mailbox) then begin
410
+
if not (Protocol.is_safe_mailbox_name mailbox) then begin
408
411
send_response flow (No { tag = Some tag; code = None; text = "Invalid mailbox name" });
409
412
state
410
413
end else
···
426
429
| Ok () ->
427
430
send_response flow (Ok { tag = Some tag; code = None; text = "CREATE completed" });
428
431
state
429
-
| Error Imap_storage.Mailbox_already_exists ->
432
+
| Error Storage_types.Mailbox_already_exists ->
430
433
send_response flow (No {
431
434
tag = Some tag;
432
435
code = Some Code_alreadyexists;
···
440
443
(* Process DELETE command *)
441
444
let handle_delete t flow tag mailbox state =
442
445
(* Security: Validate mailbox name *)
443
-
if not (Imap_types.is_safe_mailbox_name mailbox) then begin
446
+
if not (Protocol.is_safe_mailbox_name mailbox) then begin
444
447
send_response flow (No { tag = Some tag; code = None; text = "Invalid mailbox name" });
445
448
state
446
449
end else
···
462
465
| Ok () ->
463
466
send_response flow (Ok { tag = Some tag; code = None; text = "DELETE completed" });
464
467
state
465
-
| Error Imap_storage.Permission_denied ->
468
+
| Error Storage_types.Permission_denied ->
466
469
send_response flow (No {
467
470
tag = Some tag;
468
471
code = Some Code_cannot;
···
476
479
(* Process RENAME command *)
477
480
let handle_rename t flow tag ~old_name ~new_name state =
478
481
(* Security: Validate both mailbox names *)
479
-
if not (Imap_types.is_safe_mailbox_name old_name) ||
480
-
not (Imap_types.is_safe_mailbox_name new_name) then begin
482
+
if not (Protocol.is_safe_mailbox_name old_name) ||
483
+
not (Protocol.is_safe_mailbox_name new_name) then begin
481
484
send_response flow (No { tag = Some tag; code = None; text = "Invalid mailbox name" });
482
485
state
483
486
end else
···
499
502
| Result.Ok () ->
500
503
send_response flow (Ok { tag = Some tag; code = None; text = "RENAME completed" });
501
504
state
502
-
| Result.Error Imap_storage.Mailbox_not_found ->
505
+
| Result.Error Storage_types.Mailbox_not_found ->
503
506
send_response flow (No {
504
507
tag = Some tag;
505
508
code = Some Code_nonexistent;
506
509
text = "Mailbox does not exist"
507
510
});
508
511
state
509
-
| Result.Error Imap_storage.Mailbox_already_exists ->
512
+
| Result.Error Storage_types.Mailbox_already_exists ->
510
513
send_response flow (No {
511
514
tag = Some tag;
512
515
code = Some Code_alreadyexists;
···
520
523
(* Process COPY command *)
521
524
let handle_copy t flow tag ~sequence ~mailbox state =
522
525
(* Security: Validate destination mailbox name *)
523
-
if not (Imap_types.is_safe_mailbox_name mailbox) then begin
526
+
if not (Protocol.is_safe_mailbox_name mailbox) then begin
524
527
send_response flow (No { tag = Some tag; code = None; text = "Invalid mailbox name" });
525
528
state
526
529
end else
527
530
match state with
528
531
| Selected { username; mailbox = src_mailbox; _ } ->
529
532
(match Storage.copy t.storage ~username ~src_mailbox ~sequence ~dst_mailbox:mailbox with
530
-
| Result.Error Imap_storage.Mailbox_not_found ->
533
+
| Result.Error Storage_types.Mailbox_not_found ->
531
534
send_response flow (No {
532
535
tag = Some tag;
533
536
code = Some Code_trycreate;
···
559
562
(* Process MOVE command - RFC 6851 *)
560
563
let handle_move t flow tag ~sequence ~mailbox state =
561
564
(* Security: Validate destination mailbox name *)
562
-
if not (Imap_types.is_safe_mailbox_name mailbox) then begin
565
+
if not (Protocol.is_safe_mailbox_name mailbox) then begin
563
566
send_response flow (No { tag = Some tag; code = None; text = "Invalid mailbox name" });
564
567
state
565
568
end else
···
570
573
state
571
574
end else begin
572
575
match Storage.move t.storage ~username ~src_mailbox ~sequence ~dst_mailbox:mailbox with
573
-
| Result.Error Imap_storage.Mailbox_not_found ->
576
+
| Result.Error Storage_types.Mailbox_not_found ->
574
577
send_response flow (No {
575
578
tag = Some tag;
576
579
code = Some Code_trycreate;
···
630
633
(* Process APPEND command *)
631
634
let handle_append t flow tag ~mailbox ~flags ~date ~message state =
632
635
(* Security: Validate mailbox name *)
633
-
if not (Imap_types.is_safe_mailbox_name mailbox) then begin
636
+
if not (Protocol.is_safe_mailbox_name mailbox) then begin
634
637
send_response flow (No { tag = Some tag; code = None; text = "Invalid mailbox name" });
635
638
state
636
639
end else
···
649
652
state
650
653
| Some username ->
651
654
match Storage.append t.storage ~username ~mailbox ~flags ~date ~message with
652
-
| Result.Error Imap_storage.Mailbox_not_found ->
655
+
| Result.Error Storage_types.Mailbox_not_found ->
653
656
send_response flow (No {
654
657
tag = Some tag;
655
658
code = Some Code_trycreate;
···
970
973
| Result.Ok cmd ->
971
974
match cmd.command with
972
975
| Login { username; password } ->
973
-
if not (Imap_types.is_safe_username username) then begin
976
+
if not (Protocol.is_safe_username username) then begin
974
977
send_response flow (No {
975
978
tag = Some cmd.tag;
976
979
code = Some Code_authenticationfailed;
+2
-2
lib/imap_server/imap_server.mli
lib/imapd/server.mli
+2
-2
lib/imap_server/imap_server.mli
lib/imapd/server.mli
-4
lib/imap_storage/dune
-4
lib/imap_storage/dune
+9
-7
lib/imap_storage/imap_storage.ml
lib/imapd/storage.ml
+9
-7
lib/imap_storage/imap_storage.ml
lib/imapd/storage.ml
···
7
7
8
8
Implements storage for {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051}. *)
9
9
10
-
open Imap_types
10
+
open Protocol
11
11
12
12
(* Storage errors *)
13
13
type error =
···
91
91
(* Internal mailbox representation *)
92
92
type mailbox = {
93
93
mutable messages : message list;
94
-
mutable uidvalidity : uidvalidity;
94
+
uidvalidity : uidvalidity;
95
95
mutable uidnext : uid;
96
-
mutable flags : flag list;
96
+
flags : flag list;
97
97
}
98
98
99
99
(* User data *)
100
100
type user_data = {
101
-
mutable mailboxes : (mailbox_name, mailbox) Hashtbl.t;
102
-
mutable subscriptions : mailbox_name list;
101
+
mailboxes : (mailbox_name, mailbox) Hashtbl.t;
102
+
subscriptions : mailbox_name list; [@warning "-69"]
103
+
(** Placeholder for LSUB/SUBSCRIBE support per RFC 9051 Section 6.3.6 *)
103
104
}
104
105
105
106
type t = {
106
107
users : (string, user_data) Hashtbl.t;
107
-
mutable lock : unit; (* Placeholder for future mutex *)
108
+
lock : unit; [@warning "-69"]
109
+
(** Placeholder for future Eio mutex for concurrent access *)
108
110
}
109
111
110
112
let create () = {
···
474
476
(* UID mapping file stores: filename -> uid *)
475
477
type uid_map = {
476
478
mutable next_uid : int32;
477
-
mutable uidvalidity : int32;
479
+
uidvalidity : int32;
478
480
entries : (string, int32) Hashtbl.t; (* filename -> uid *)
479
481
}
480
482
+1
-1
lib/imap_storage/imap_storage.mli
lib/imapd/storage.mli
+1
-1
lib/imap_storage/imap_storage.mli
lib/imapd/storage.mli
lib/imap_types/imap_types.ml
lib/imapd/protocol.ml
lib/imap_types/imap_types.ml
lib/imapd/protocol.ml
lib/imap_types/imap_types.mli
lib/imapd/protocol.mli
lib/imap_types/imap_types.mli
lib/imapd/protocol.mli
+757
lib/imapd/client.ml
+757
lib/imapd/client.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Protocol
7
+
8
+
type connection_state =
9
+
| Not_authenticated
10
+
| Authenticated of { username : string }
11
+
| Selected of {
12
+
username : string;
13
+
mailbox : string;
14
+
readonly : bool;
15
+
}
16
+
| Logout
17
+
18
+
type mailbox_info = {
19
+
name : string;
20
+
exists : int;
21
+
recent : int;
22
+
uidvalidity : int32;
23
+
uidnext : int32;
24
+
flags : flag list;
25
+
permanent_flags : flag list;
26
+
readonly : bool;
27
+
}
28
+
29
+
type message_info = {
30
+
seq : int;
31
+
uid : int32 option;
32
+
flags : flag list option;
33
+
envelope : envelope option;
34
+
body_structure : body_structure option;
35
+
internaldate : string option;
36
+
size : int64 option;
37
+
body_section : string option;
38
+
}
39
+
40
+
type list_entry = {
41
+
flags : list_flag list;
42
+
delimiter : char option;
43
+
name : string;
44
+
}
45
+
46
+
type status_info = {
47
+
mailbox : string;
48
+
messages : int64 option;
49
+
uidnext : int64 option;
50
+
uidvalidity : int64 option;
51
+
unseen : int64 option;
52
+
}
53
+
54
+
type idle_event =
55
+
| Idle_exists of int
56
+
| Idle_expunge of int
57
+
| Idle_fetch of { seq : int; flags : flag list }
58
+
59
+
type t = {
60
+
reader : Eio.Buf_read.t;
61
+
writer : Eio.Buf_write.t;
62
+
close_fn : unit -> unit;
63
+
mutable state : connection_state;
64
+
mutable capabilities : string list;
65
+
mutable tag_counter : int;
66
+
sw : Eio.Switch.t; [@warning "-69"]
67
+
}
68
+
69
+
let state t = t.state
70
+
let capabilities t = t.capabilities
71
+
72
+
let has_capability t cap =
73
+
let upper = String.uppercase_ascii cap in
74
+
List.exists (fun c -> String.uppercase_ascii c = upper) t.capabilities
75
+
76
+
let next_tag t =
77
+
t.tag_counter <- t.tag_counter + 1;
78
+
Printf.sprintf "A%04d" t.tag_counter
79
+
80
+
let send_command t cmd =
81
+
let tag = next_tag t in
82
+
Write.command t.writer ~tag cmd;
83
+
tag
84
+
85
+
let require_state t expected =
86
+
let actual =
87
+
match t.state with
88
+
| Not_authenticated -> "Not_authenticated"
89
+
| Authenticated _ -> "Authenticated"
90
+
| Selected _ -> "Selected"
91
+
| Logout -> "Logout"
92
+
in
93
+
if actual <> expected then
94
+
raise (Client_error.err (State_error { expected; actual }))
95
+
96
+
let require_authenticated t =
97
+
match t.state with
98
+
| Authenticated _ | Selected _ -> ()
99
+
| _ -> raise (Client_error.err (State_error { expected = "Authenticated"; actual = "Not_authenticated" }))
100
+
101
+
let require_selected t =
102
+
match t.state with
103
+
| Selected _ -> ()
104
+
| _ -> raise (Client_error.err (State_error { expected = "Selected"; actual = "not Selected" }))
105
+
106
+
let require_capability t cap =
107
+
if not (has_capability t cap) then
108
+
raise (Client_error.err (Capability_missing { capability = cap }))
109
+
110
+
(* Process untagged responses and extract relevant data *)
111
+
let process_untagged responses =
112
+
let exists = ref 0 in
113
+
let recent = ref 0 in
114
+
let uidvalidity = ref 0l in
115
+
let uidnext = ref 0l in
116
+
let flags = ref [] in
117
+
let permanent_flags = ref [] in
118
+
let readonly = ref false in
119
+
let caps = ref [] in
120
+
let list_entries = ref [] in
121
+
let fetch_items = ref [] in
122
+
let expunged = ref [] in
123
+
let search_results = ref [] in
124
+
let namespace = ref None in
125
+
let status = ref None in
126
+
let id_result = ref None in
127
+
let enabled = ref [] in
128
+
129
+
List.iter
130
+
(function
131
+
| Exists n -> exists := n
132
+
| Flags_response f -> flags := f
133
+
| Capability_response c -> caps := c
134
+
| Enabled e -> enabled := e
135
+
| List_response { flags = f; delimiter; name } ->
136
+
list_entries := { flags = f; delimiter; name } :: !list_entries
137
+
| Status_response { mailbox; items } ->
138
+
let messages =
139
+
List.find_map
140
+
(function Status_messages, v -> Some v | _ -> None)
141
+
items
142
+
in
143
+
let uidnext =
144
+
List.find_map
145
+
(function Status_uidnext, v -> Some v | _ -> None)
146
+
items
147
+
in
148
+
let uidvalidity =
149
+
List.find_map
150
+
(function Status_uidvalidity, v -> Some v | _ -> None)
151
+
items
152
+
in
153
+
let unseen =
154
+
List.find_map
155
+
(function Status_unseen, v -> Some v | _ -> None)
156
+
items
157
+
in
158
+
status := Some { mailbox; messages; uidnext; uidvalidity; unseen }
159
+
| Namespace_response ns -> namespace := Some ns
160
+
| Fetch_response { seq; items } ->
161
+
let uid =
162
+
List.find_map
163
+
(function Fetch_item_uid u -> Some u | _ -> None)
164
+
items
165
+
in
166
+
let flags =
167
+
List.find_map
168
+
(function Fetch_item_flags f -> Some f | _ -> None)
169
+
items
170
+
in
171
+
let envelope =
172
+
List.find_map
173
+
(function Fetch_item_envelope e -> Some e | _ -> None)
174
+
items
175
+
in
176
+
let body_structure =
177
+
List.find_map
178
+
(function
179
+
| Fetch_item_body b | Fetch_item_bodystructure b -> Some b
180
+
| _ -> None)
181
+
items
182
+
in
183
+
let internaldate =
184
+
List.find_map
185
+
(function Fetch_item_internaldate d -> Some d | _ -> None)
186
+
items
187
+
in
188
+
let size =
189
+
List.find_map
190
+
(function Fetch_item_rfc822_size s -> Some s | _ -> None)
191
+
items
192
+
in
193
+
let body_section =
194
+
List.find_map
195
+
(function
196
+
| Fetch_item_body_section { data; _ } -> data
197
+
| _ -> None)
198
+
items
199
+
in
200
+
fetch_items :=
201
+
{ seq; uid; flags; envelope; body_structure; internaldate; size; body_section }
202
+
:: !fetch_items
203
+
| Expunge_response n -> expunged := n :: !expunged
204
+
| Esearch { results; _ } ->
205
+
List.iter
206
+
(function
207
+
| Esearch_all set ->
208
+
List.iter
209
+
(function
210
+
| Single n -> search_results := n :: !search_results
211
+
| Range (a, b) ->
212
+
for i = a to b do
213
+
search_results := i :: !search_results
214
+
done
215
+
| From _ | All -> ())
216
+
set
217
+
| _ -> ())
218
+
results
219
+
| Id_response r -> id_result := r
220
+
| Ok { code; _ } -> (
221
+
match code with
222
+
| Some (Code_permanentflags f) -> permanent_flags := f
223
+
| Some (Code_uidvalidity v) -> uidvalidity := v
224
+
| Some (Code_uidnext u) -> uidnext := u
225
+
| Some Code_readonly -> readonly := true
226
+
| Some Code_readwrite -> readonly := false
227
+
| Some (Code_capability c) -> caps := c
228
+
| _ -> ())
229
+
| _ -> ())
230
+
responses;
231
+
232
+
( !exists,
233
+
!recent,
234
+
!uidvalidity,
235
+
!uidnext,
236
+
!flags,
237
+
!permanent_flags,
238
+
!readonly,
239
+
!caps,
240
+
List.rev !list_entries,
241
+
List.rev !fetch_items,
242
+
List.rev !expunged,
243
+
List.rev !search_results,
244
+
!namespace,
245
+
!status,
246
+
!id_result,
247
+
!enabled )
248
+
249
+
let check_response tag responses =
250
+
let final =
251
+
List.find_opt
252
+
(function
253
+
| Ok { tag = Some t; _ }
254
+
| No { tag = Some t; _ }
255
+
| Bad { tag = Some t; _ }
256
+
when t = tag ->
257
+
true
258
+
| Bye _ -> true
259
+
| _ -> false)
260
+
responses
261
+
in
262
+
match final with
263
+
| Some (Ok _) -> ()
264
+
| Some (No { code; text; _ }) ->
265
+
raise (Client_error.err (Protocol_error { code; text }))
266
+
| Some (Bad { code; text; _ }) ->
267
+
raise (Client_error.err (Protocol_error { code; text }))
268
+
| Some (Bye { text; _ }) ->
269
+
raise (Client_error.err (Protocol_error { code = None; text }))
270
+
| _ ->
271
+
raise
272
+
(Client_error.err
273
+
(Protocol_error { code = None; text = "No tagged response" }))
274
+
275
+
let run_command t cmd =
276
+
let tag = send_command t cmd in
277
+
let responses = Read.responses_until_tagged t.reader tag in
278
+
check_response tag responses;
279
+
responses
280
+
281
+
let connect ~sw ~env ~host ?(port = 993) ?tls_config () =
282
+
let net = env#net in
283
+
284
+
(* Resolve hostname *)
285
+
let addrs =
286
+
try Eio.Net.getaddrinfo_stream net host ~service:(string_of_int port)
287
+
with _ ->
288
+
raise
289
+
(Client_error.err
290
+
(Connection_error { reason = "DNS resolution failed for " ^ host }))
291
+
in
292
+
293
+
let addr =
294
+
match addrs with
295
+
| [] ->
296
+
raise
297
+
(Client_error.err
298
+
(Connection_error { reason = "No addresses found for " ^ host }))
299
+
| a :: _ -> a
300
+
in
301
+
302
+
(* Connect *)
303
+
let flow =
304
+
try Eio.Net.connect ~sw net addr
305
+
with exn ->
306
+
raise
307
+
(Client_error.err
308
+
(Connection_error { reason = Printexc.to_string exn }))
309
+
in
310
+
311
+
(* Wrap in TLS *)
312
+
let tls_config =
313
+
match tls_config with
314
+
| Some c -> c
315
+
| None -> (
316
+
match
317
+
Tls.Config.client ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) ()
318
+
with
319
+
| Ok c -> c
320
+
| Error _ ->
321
+
raise
322
+
(Client_error.err
323
+
(Connection_error { reason = "Failed to create TLS config" })))
324
+
in
325
+
326
+
let tls_flow =
327
+
try Tls_eio.client_of_flow tls_config flow
328
+
with exn ->
329
+
raise
330
+
(Client_error.err
331
+
(Connection_error { reason = "TLS handshake failed: " ^ Printexc.to_string exn }))
332
+
in
333
+
334
+
let reader = Eio.Buf_read.of_flow tls_flow ~max_size:(10 * 1024 * 1024) in
335
+
336
+
(* We need to create the client inside Buf_write.with_flow *)
337
+
let client_ref = ref None in
338
+
339
+
Eio.Buf_write.with_flow tls_flow (fun writer ->
340
+
let client =
341
+
{
342
+
reader;
343
+
writer;
344
+
close_fn = (fun () -> Eio.Flow.close tls_flow);
345
+
state = Not_authenticated;
346
+
capabilities = [];
347
+
tag_counter = 0;
348
+
sw;
349
+
}
350
+
in
351
+
ignore (env : < net : _ Eio.Net.t ; .. >); (* used for connect only *)
352
+
353
+
(* Read greeting *)
354
+
let greeting = Read.response reader in
355
+
(match greeting with
356
+
| Ok { code; _ } -> (
357
+
match code with
358
+
| Some (Code_capability caps) -> client.capabilities <- caps
359
+
| _ -> ())
360
+
| Preauth { code; _ } -> (
361
+
client.state <- Authenticated { username = "" };
362
+
match code with
363
+
| Some (Code_capability caps) -> client.capabilities <- caps
364
+
| _ -> ())
365
+
| Bye { text; _ } ->
366
+
raise (Client_error.err (Protocol_error { code = None; text }))
367
+
| _ ->
368
+
raise
369
+
(Client_error.err
370
+
(Protocol_error { code = None; text = "Unexpected greeting" })));
371
+
372
+
(* Get capabilities if not in greeting *)
373
+
if client.capabilities = [] then (
374
+
let responses = run_command client Capability in
375
+
let _, _, _, _, _, _, _, caps, _, _, _, _, _, _, _, _ =
376
+
process_untagged responses
377
+
in
378
+
client.capabilities <- caps);
379
+
380
+
client_ref := Some client;
381
+
382
+
(* Keep writer alive - main loop would go here in a real app *)
383
+
(* For now, we return immediately but the writer stays valid *)
384
+
());
385
+
386
+
match !client_ref with
387
+
| Some c -> c
388
+
| None ->
389
+
raise
390
+
(Client_error.err
391
+
(Connection_error { reason = "Failed to initialize client" }))
392
+
393
+
let disconnect t =
394
+
t.state <- Logout;
395
+
try t.close_fn () with _ -> ()
396
+
397
+
let capability t =
398
+
let responses = run_command t Capability in
399
+
let _, _, _, _, _, _, _, caps, _, _, _, _, _, _, _, _ =
400
+
process_untagged responses
401
+
in
402
+
t.capabilities <- caps;
403
+
caps
404
+
405
+
let noop t = ignore (run_command t Noop)
406
+
407
+
let logout t =
408
+
(try ignore (run_command t Logout) with _ -> ());
409
+
t.state <- Logout
410
+
411
+
let id t params =
412
+
let responses = run_command t (Id params) in
413
+
let _, _, _, _, _, _, _, _, _, _, _, _, _, _, id_result, _ =
414
+
process_untagged responses
415
+
in
416
+
id_result
417
+
418
+
let starttls t config =
419
+
require_capability t "STARTTLS";
420
+
require_state t "Not_authenticated";
421
+
ignore (run_command t Starttls);
422
+
(* Would need to upgrade connection here - complex to implement *)
423
+
ignore config;
424
+
failwith "STARTTLS not yet implemented"
425
+
426
+
let login t ~username ~password =
427
+
(match t.state with
428
+
| Not_authenticated -> ()
429
+
| _ ->
430
+
raise
431
+
(Client_error.err
432
+
(State_error { expected = "Not_authenticated"; actual = "Authenticated" })));
433
+
let responses = run_command t (Login { username; password }) in
434
+
let _, _, _, _, _, _, _, caps, _, _, _, _, _, _, _, _ =
435
+
process_untagged responses
436
+
in
437
+
if caps <> [] then t.capabilities <- caps;
438
+
t.state <- Authenticated { username }
439
+
440
+
let authenticate t ~mechanism ?initial_response ~respond () =
441
+
(match t.state with
442
+
| Not_authenticated -> ()
443
+
| _ ->
444
+
raise
445
+
(Client_error.err
446
+
(State_error { expected = "Not_authenticated"; actual = "Authenticated" })));
447
+
let tag = send_command t (Authenticate { mechanism; initial_response }) in
448
+
449
+
let rec handle_challenges () =
450
+
let resp = Read.response t.reader in
451
+
match resp with
452
+
| Continuation (Some challenge) ->
453
+
let response = respond challenge in
454
+
Write.authenticate_response t.writer response;
455
+
handle_challenges ()
456
+
| Continuation None ->
457
+
let response = respond "" in
458
+
Write.authenticate_response t.writer response;
459
+
handle_challenges ()
460
+
| Ok { tag = Some t; _ } when t = tag -> ()
461
+
| No { tag = Some t; text; _ } when t = tag ->
462
+
raise
463
+
(Client_error.err
464
+
(Authentication_error { mechanism; reason = text }))
465
+
| Bad { tag = Some t; text; _ } when t = tag ->
466
+
raise
467
+
(Client_error.err
468
+
(Authentication_error { mechanism; reason = text }))
469
+
| Bye { text; _ } ->
470
+
raise
471
+
(Client_error.err
472
+
(Authentication_error { mechanism; reason = "Server disconnected: " ^ text }))
473
+
| _ -> handle_challenges ()
474
+
in
475
+
handle_challenges ();
476
+
t.state <- Authenticated { username = "" }
477
+
478
+
let authenticate_plain t ~username ~password =
479
+
let ir =
480
+
Base64.encode_string (Printf.sprintf "\x00%s\x00%s" username password)
481
+
in
482
+
authenticate t ~mechanism:"PLAIN" ~initial_response:ir ~respond:(fun _ -> "") ();
483
+
t.state <- Authenticated { username }
484
+
485
+
let select t mailbox =
486
+
require_authenticated t;
487
+
let responses = run_command t (Select mailbox) in
488
+
let exists, recent, uidvalidity, uidnext, flags, permanent_flags, readonly, caps, _, _, _, _, _, _, _, _ =
489
+
process_untagged responses
490
+
in
491
+
if caps <> [] then t.capabilities <- caps;
492
+
let username =
493
+
match t.state with
494
+
| Authenticated { username } -> username
495
+
| Selected { username; _ } -> username
496
+
| _ -> ""
497
+
in
498
+
t.state <- Selected { username; mailbox; readonly };
499
+
{
500
+
name = mailbox;
501
+
exists;
502
+
recent;
503
+
uidvalidity;
504
+
uidnext;
505
+
flags;
506
+
permanent_flags;
507
+
readonly;
508
+
}
509
+
510
+
let examine t mailbox =
511
+
require_authenticated t;
512
+
let responses = run_command t (Examine mailbox) in
513
+
let exists, recent, uidvalidity, uidnext, flags, permanent_flags, _, caps, _, _, _, _, _, _, _, _ =
514
+
process_untagged responses
515
+
in
516
+
if caps <> [] then t.capabilities <- caps;
517
+
let username =
518
+
match t.state with
519
+
| Authenticated { username } -> username
520
+
| Selected { username; _ } -> username
521
+
| _ -> ""
522
+
in
523
+
t.state <- Selected { username; mailbox; readonly = true };
524
+
{
525
+
name = mailbox;
526
+
exists;
527
+
recent;
528
+
uidvalidity;
529
+
uidnext;
530
+
flags;
531
+
permanent_flags;
532
+
readonly = true;
533
+
}
534
+
535
+
let create t mailbox =
536
+
require_authenticated t;
537
+
ignore (run_command t (Create mailbox))
538
+
539
+
let delete t mailbox =
540
+
require_authenticated t;
541
+
ignore (run_command t (Delete mailbox))
542
+
543
+
let rename t ~old_name ~new_name =
544
+
require_authenticated t;
545
+
ignore (run_command t (Rename { old_name; new_name }))
546
+
547
+
let subscribe t mailbox =
548
+
require_authenticated t;
549
+
ignore (run_command t (Subscribe mailbox))
550
+
551
+
let unsubscribe t mailbox =
552
+
require_authenticated t;
553
+
ignore (run_command t (Unsubscribe mailbox))
554
+
555
+
let list t ~reference ~pattern =
556
+
require_authenticated t;
557
+
let responses = run_command t (List { reference; pattern }) in
558
+
let _, _, _, _, _, _, _, _, entries, _, _, _, _, _, _, _ =
559
+
process_untagged responses
560
+
in
561
+
entries
562
+
563
+
let namespace t =
564
+
require_authenticated t;
565
+
require_capability t "NAMESPACE";
566
+
let responses = run_command t Namespace in
567
+
let _, _, _, _, _, _, _, _, _, _, _, _, ns, _, _, _ = process_untagged responses in
568
+
match ns with
569
+
| Some n -> n
570
+
| None -> { personal = None; other = None; shared = None }
571
+
572
+
let status t mailbox items =
573
+
require_authenticated t;
574
+
let responses = run_command t (Status { mailbox; items }) in
575
+
let _, _, _, _, _, _, _, _, _, _, _, _, _, status, _, _ =
576
+
process_untagged responses
577
+
in
578
+
match status with
579
+
| Some s -> s
580
+
| None ->
581
+
{ mailbox; messages = None; uidnext = None; uidvalidity = None; unseen = None }
582
+
583
+
let close t =
584
+
require_selected t;
585
+
ignore (run_command t Close);
586
+
let username =
587
+
match t.state with Selected { username; _ } -> username | _ -> ""
588
+
in
589
+
t.state <- Authenticated { username }
590
+
591
+
let unselect t =
592
+
require_selected t;
593
+
require_capability t "UNSELECT";
594
+
ignore (run_command t Unselect);
595
+
let username =
596
+
match t.state with Selected { username; _ } -> username | _ -> ""
597
+
in
598
+
t.state <- Authenticated { username }
599
+
600
+
let fetch t ~sequence ~items =
601
+
require_selected t;
602
+
let responses = run_command t (Fetch { sequence; items }) in
603
+
let _, _, _, _, _, _, _, _, _, fetch_items, _, _, _, _, _, _ =
604
+
process_untagged responses
605
+
in
606
+
fetch_items
607
+
608
+
let uid_fetch t ~sequence ~items =
609
+
require_selected t;
610
+
let responses = run_command t (Uid (Uid_fetch { sequence; items })) in
611
+
let _, _, _, _, _, _, _, _, _, fetch_items, _, _, _, _, _, _ =
612
+
process_untagged responses
613
+
in
614
+
fetch_items
615
+
616
+
let store t ~sequence ~action ~flags ?(silent = false) () =
617
+
require_selected t;
618
+
let responses = run_command t (Store { sequence; silent; action; flags }) in
619
+
let _, _, _, _, _, _, _, _, _, fetch_items, _, _, _, _, _, _ =
620
+
process_untagged responses
621
+
in
622
+
fetch_items
623
+
624
+
let uid_store t ~sequence ~action ~flags ?(silent = false) () =
625
+
require_selected t;
626
+
let responses =
627
+
run_command t (Uid (Uid_store { sequence; silent; action; flags }))
628
+
in
629
+
let _, _, _, _, _, _, _, _, _, fetch_items, _, _, _, _, _, _ =
630
+
process_untagged responses
631
+
in
632
+
fetch_items
633
+
634
+
let copy t ~sequence ~mailbox =
635
+
require_selected t;
636
+
ignore (run_command t (Copy { sequence; mailbox }))
637
+
638
+
let uid_copy t ~sequence ~mailbox =
639
+
require_selected t;
640
+
ignore (run_command t (Uid (Uid_copy { sequence; mailbox })))
641
+
642
+
let move t ~sequence ~mailbox =
643
+
require_selected t;
644
+
require_capability t "MOVE";
645
+
ignore (run_command t (Move { sequence; mailbox }))
646
+
647
+
let uid_move t ~sequence ~mailbox =
648
+
require_selected t;
649
+
require_capability t "MOVE";
650
+
ignore (run_command t (Uid (Uid_move { sequence; mailbox })))
651
+
652
+
let expunge t =
653
+
require_selected t;
654
+
let responses = run_command t Expunge in
655
+
let _, _, _, _, _, _, _, _, _, _, expunged, _, _, _, _, _ =
656
+
process_untagged responses
657
+
in
658
+
expunged
659
+
660
+
let uid_expunge t uids =
661
+
require_selected t;
662
+
require_capability t "UIDPLUS";
663
+
let responses = run_command t (Uid (Uid_expunge uids)) in
664
+
let _, _, _, _, _, _, _, _, _, _, expunged, _, _, _, _, _ =
665
+
process_untagged responses
666
+
in
667
+
expunged
668
+
669
+
let search t ?charset criteria =
670
+
require_selected t;
671
+
let responses = run_command t (Search { charset; criteria }) in
672
+
let _, _, _, _, _, _, _, _, _, _, _, results, _, _, _, _ =
673
+
process_untagged responses
674
+
in
675
+
results
676
+
677
+
let uid_search t ?charset criteria =
678
+
require_selected t;
679
+
let responses = run_command t (Uid (Uid_search { charset; criteria })) in
680
+
let _, _, _, _, _, _, _, _, _, _, _, results, _, _, _, _ =
681
+
process_untagged responses
682
+
in
683
+
List.map Int32.of_int results
684
+
685
+
let append t ~mailbox ~message ?flags ?date () =
686
+
require_authenticated t;
687
+
let flags = Option.value ~default:[] flags in
688
+
let responses = run_command t (Append { mailbox; flags; date; message }) in
689
+
(* Check for APPENDUID response code *)
690
+
let uid =
691
+
List.find_map
692
+
(function
693
+
| Ok { code = Some (Code_appenduid (_, uid)); _ } -> Some uid
694
+
| _ -> None)
695
+
responses
696
+
in
697
+
uid
698
+
699
+
let idle t ~timeout =
700
+
require_selected t;
701
+
require_capability t "IDLE";
702
+
let tag = send_command t Idle in
703
+
704
+
(* Wait for continuation *)
705
+
let cont = Read.response t.reader in
706
+
(match cont with
707
+
| Continuation _ -> ()
708
+
| _ ->
709
+
raise
710
+
(Client_error.err
711
+
(Protocol_error { code = None; text = "Expected continuation for IDLE" })));
712
+
713
+
(* Collect events with timeout *)
714
+
let events = ref [] in
715
+
let start = Unix.gettimeofday () in
716
+
717
+
let rec collect () =
718
+
let elapsed = Unix.gettimeofday () -. start in
719
+
if elapsed >= timeout then (
720
+
Write.idle_done t.writer;
721
+
let _ = Read.responses_until_tagged t.reader tag in
722
+
List.rev !events)
723
+
else
724
+
(* Try to read response with remaining timeout *)
725
+
let resp = Read.response t.reader in
726
+
match resp with
727
+
| Exists n ->
728
+
events := Idle_exists n :: !events;
729
+
collect ()
730
+
| Expunge_response n ->
731
+
events := Idle_expunge n :: !events;
732
+
collect ()
733
+
| Fetch_response { seq; items } ->
734
+
let flags =
735
+
List.find_map
736
+
(function Fetch_item_flags f -> Some f | _ -> None)
737
+
items
738
+
in
739
+
(match flags with
740
+
| Some f -> events := Idle_fetch { seq; flags = f } :: !events
741
+
| None -> ());
742
+
collect ()
743
+
| Ok { tag = Some t; _ } when t = tag -> List.rev !events
744
+
| _ -> collect ()
745
+
in
746
+
collect ()
747
+
748
+
let idle_done t =
749
+
Write.idle_done t.writer
750
+
751
+
let enable t extensions =
752
+
require_authenticated t;
753
+
let responses = run_command t (Enable extensions) in
754
+
let _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, enabled =
755
+
process_untagged responses
756
+
in
757
+
enabled
+473
lib/imapd/client.mli
+473
lib/imapd/client.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP4rev2 Client Library
7
+
8
+
This module provides a comprehensive IMAP client for OCaml applications.
9
+
It implements the client side of
10
+
{{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051 IMAP4rev2}.
11
+
12
+
{2 Quick Start}
13
+
14
+
{[
15
+
Eio_main.run @@ fun env ->
16
+
Eio.Switch.run @@ fun sw ->
17
+
18
+
let client =
19
+
Client.connect ~sw ~env ~host:"imap.example.com" ~port:993 ()
20
+
in
21
+
22
+
Client.login client ~username:"user" ~password:"pass";
23
+
24
+
let mailbox = Client.select client "INBOX" in
25
+
Printf.printf "You have %d messages\n" mailbox.exists;
26
+
27
+
let messages =
28
+
Client.fetch client
29
+
~sequence:[ Protocol.Range (1, 10) ]
30
+
~items:[ Protocol.Fetch_envelope; Protocol.Fetch_flags ]
31
+
in
32
+
List.iter
33
+
(fun msg ->
34
+
Printf.printf "[%ld] %s\n" msg.uid
35
+
(Option.value ~default:"<no subject>" msg.envelope.subject))
36
+
messages;
37
+
38
+
Client.logout client
39
+
]}
40
+
41
+
{2 Connection States}
42
+
43
+
The IMAP protocol has strict state requirements:
44
+
{ul
45
+
{- {b Not authenticated}: After connect, before login/authenticate}
46
+
{- {b Authenticated}: After successful login, can access mailboxes}
47
+
{- {b Selected}: After SELECT/EXAMINE, can access messages}}
48
+
49
+
Commands that require a specific state will raise {!Client_error.State_error}
50
+
if called in the wrong state.
51
+
52
+
{2 Error Handling}
53
+
54
+
All errors are raised as [Eio.Io] exceptions wrapping {!Client_error.error}.
55
+
Use pattern matching to handle specific error cases:
56
+
57
+
{[
58
+
try
59
+
Client.login client ~username ~password
60
+
with
61
+
| Eio.Io (Client_error.E err, _) -> (
62
+
match err with
63
+
| Protocol_error { code = Some Code_authenticationfailed; _ } ->
64
+
Printf.eprintf "Bad username or password\n"
65
+
| Connection_error { reason } ->
66
+
Printf.eprintf "Connection lost: %s\n" reason
67
+
| _ -> raise (Client_error.err err))
68
+
]}
69
+
70
+
{2 References}
71
+
{ul
72
+
{- {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} - IMAP4rev2}
73
+
{- {{:https://datatracker.ietf.org/doc/html/rfc2177}RFC 2177} - IDLE}
74
+
{- {{:https://datatracker.ietf.org/doc/html/rfc6851}RFC 6851} - MOVE}
75
+
{- {{:https://datatracker.ietf.org/doc/html/rfc7888}RFC 7888} - LITERAL+}
76
+
{- {{:https://datatracker.ietf.org/doc/html/rfc2971}RFC 2971} - ID}} *)
77
+
78
+
(** {1 Types} *)
79
+
80
+
type t
81
+
(** An IMAP client connection. *)
82
+
83
+
type connection_state =
84
+
| Not_authenticated
85
+
| Authenticated of { username : string }
86
+
| Selected of {
87
+
username : string;
88
+
mailbox : string;
89
+
readonly : bool;
90
+
}
91
+
| Logout
92
+
(** Connection state. See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-3}
93
+
RFC 9051 Section 3}. *)
94
+
95
+
type mailbox_info = {
96
+
name : string;
97
+
exists : int;
98
+
recent : int;
99
+
uidvalidity : int32;
100
+
uidnext : int32;
101
+
flags : Protocol.flag list;
102
+
permanent_flags : Protocol.flag list;
103
+
readonly : bool;
104
+
}
105
+
(** Information about a selected mailbox. *)
106
+
107
+
type message_info = {
108
+
seq : int;
109
+
uid : int32 option;
110
+
flags : Protocol.flag list option;
111
+
envelope : Protocol.envelope option;
112
+
body_structure : Protocol.body_structure option;
113
+
internaldate : string option;
114
+
size : int64 option;
115
+
body_section : string option;
116
+
}
117
+
(** Information about a fetched message. *)
118
+
119
+
type list_entry = {
120
+
flags : Protocol.list_flag list;
121
+
delimiter : char option;
122
+
name : string;
123
+
}
124
+
(** A mailbox from LIST response. *)
125
+
126
+
type status_info = {
127
+
mailbox : string;
128
+
messages : int64 option;
129
+
uidnext : int64 option;
130
+
uidvalidity : int64 option;
131
+
unseen : int64 option;
132
+
}
133
+
(** STATUS response information. *)
134
+
135
+
type idle_event =
136
+
| Idle_exists of int
137
+
| Idle_expunge of int
138
+
| Idle_fetch of { seq : int; flags : Protocol.flag list }
139
+
(** Events that can occur during IDLE. *)
140
+
141
+
(** {1 Connection Management} *)
142
+
143
+
val connect :
144
+
sw:Eio.Switch.t ->
145
+
env:< net : _ Eio.Net.t ; .. > ->
146
+
host:string ->
147
+
?port:int ->
148
+
?tls_config:Tls.Config.client ->
149
+
unit ->
150
+
t
151
+
(** [connect ~sw ~env ~host ?port ?tls_config ()] establishes an IMAP connection.
152
+
153
+
@param sw Switch for resource management. Connection is closed when switch exits.
154
+
@param env Eio environment providing network access.
155
+
@param host Server hostname.
156
+
@param port Server port. Default is 993 (IMAPS).
157
+
@param tls_config TLS configuration. If not provided, uses default with
158
+
permissive certificate validation (not recommended for production).
159
+
160
+
@raise Client_error.Connection_error if connection fails.
161
+
@raise Client_error.Protocol_error if server greeting is not OK/PREAUTH. *)
162
+
163
+
val disconnect : t -> unit
164
+
(** [disconnect client] closes the connection immediately without LOGOUT.
165
+
Prefer {!logout} for graceful disconnection. *)
166
+
167
+
val state : t -> connection_state
168
+
(** [state client] returns the current connection state. *)
169
+
170
+
val capabilities : t -> string list
171
+
(** [capabilities client] returns the server's advertised capabilities. *)
172
+
173
+
val has_capability : t -> string -> bool
174
+
(** [has_capability client cap] checks if server advertises capability [cap]. *)
175
+
176
+
(** {1 Any-State Commands}
177
+
178
+
These commands can be issued in any connection state. *)
179
+
180
+
val capability : t -> string list
181
+
(** [capability client] requests capability list from server.
182
+
Updates cached capabilities and returns the list. *)
183
+
184
+
val noop : t -> unit
185
+
(** [noop client] does nothing but may trigger unsolicited responses.
186
+
Useful for keeping connection alive or checking for new messages. *)
187
+
188
+
val logout : t -> unit
189
+
(** [logout client] gracefully terminates the session.
190
+
After logout, the client should not be used. *)
191
+
192
+
val id : t -> (string * string) list option -> (string * string) list option
193
+
(** [id client params] exchanges client/server identification (RFC 2971).
194
+
195
+
@param params Client identification parameters, or [None] for NIL.
196
+
@return Server identification parameters. *)
197
+
198
+
(** {1 Authentication}
199
+
200
+
Commands for authenticating to the server. *)
201
+
202
+
val starttls : t -> Tls.Config.client -> unit
203
+
(** [starttls client config] upgrades connection to TLS (port 143 only).
204
+
205
+
@raise Client_error.Capability_missing if STARTTLS not available.
206
+
@raise Client_error.State_error if already authenticated.
207
+
@raise Client_error.Protocol_error if STARTTLS fails. *)
208
+
209
+
val login : t -> username:string -> password:string -> unit
210
+
(** [login client ~username ~password] authenticates using LOGIN command.
211
+
212
+
@raise Client_error.State_error if already authenticated.
213
+
@raise Client_error.Protocol_error if login fails. *)
214
+
215
+
val authenticate :
216
+
t ->
217
+
mechanism:string ->
218
+
?initial_response:string ->
219
+
respond:(string -> string) ->
220
+
unit ->
221
+
unit
222
+
(** [authenticate client ~mechanism ?initial_response ~respond] performs
223
+
SASL authentication.
224
+
225
+
@param mechanism SASL mechanism name (e.g., "PLAIN", "XOAUTH2").
226
+
@param initial_response Optional initial response (IR capability).
227
+
@param respond Callback to provide responses to server challenges.
228
+
229
+
@raise Client_error.State_error if already authenticated.
230
+
@raise Client_error.Authentication_error if authentication fails. *)
231
+
232
+
val authenticate_plain : t -> username:string -> password:string -> unit
233
+
(** [authenticate_plain client ~username ~password] authenticates using
234
+
SASL PLAIN mechanism. Equivalent to:
235
+
{[
236
+
let ir = Printf.sprintf "\x00%s\x00%s" username password in
237
+
authenticate client ~mechanism:"PLAIN" ~initial_response:(Base64.encode_string ir)
238
+
~respond:(fun _ -> "")
239
+
]} *)
240
+
241
+
(** {1 Mailbox Commands}
242
+
243
+
Commands for working with mailboxes. Require Authenticated state. *)
244
+
245
+
val select : t -> string -> mailbox_info
246
+
(** [select client mailbox] selects a mailbox for read-write access.
247
+
248
+
@raise Client_error.State_error if not authenticated.
249
+
@raise Client_error.Protocol_error if mailbox doesn't exist. *)
250
+
251
+
val examine : t -> string -> mailbox_info
252
+
(** [examine client mailbox] selects a mailbox for read-only access.
253
+
Same as {!select} but changes cannot be made. *)
254
+
255
+
val create : t -> string -> unit
256
+
(** [create client mailbox] creates a new mailbox.
257
+
258
+
@raise Client_error.Protocol_error if mailbox exists or is invalid. *)
259
+
260
+
val delete : t -> string -> unit
261
+
(** [delete client mailbox] deletes a mailbox.
262
+
263
+
@raise Client_error.Protocol_error if mailbox doesn't exist. *)
264
+
265
+
val rename : t -> old_name:string -> new_name:string -> unit
266
+
(** [rename client ~old_name ~new_name] renames a mailbox. *)
267
+
268
+
val subscribe : t -> string -> unit
269
+
(** [subscribe client mailbox] adds mailbox to subscription list. *)
270
+
271
+
val unsubscribe : t -> string -> unit
272
+
(** [unsubscribe client mailbox] removes mailbox from subscription list. *)
273
+
274
+
val list : t -> reference:string -> pattern:string -> list_entry list
275
+
(** [list client ~reference ~pattern] lists mailboxes matching pattern.
276
+
277
+
@param reference Reference name (usually "").
278
+
@param pattern Mailbox name pattern with wildcards (asterisk matches all, percent matches one level).
279
+
280
+
Example:
281
+
{[
282
+
let boxes = Client.list client ~reference:"" ~pattern:"*" in
283
+
List.iter (fun e -> Printf.printf "%s\n" e.name) boxes
284
+
]} *)
285
+
286
+
val namespace : t -> Protocol.namespace_data
287
+
(** [namespace client] returns the server's namespace configuration. *)
288
+
289
+
val status : t -> string -> Protocol.status_item list -> status_info
290
+
(** [status client mailbox items] returns status of a mailbox without selecting it.
291
+
292
+
Example:
293
+
{[
294
+
let info =
295
+
Client.status client "INBOX"
296
+
[ Status_messages; Status_unseen ]
297
+
in
298
+
Printf.printf "Messages: %Ld, Unseen: %Ld\n"
299
+
(Option.get info.messages) (Option.get info.unseen)
300
+
]} *)
301
+
302
+
val close : t -> unit
303
+
(** [close client] closes the selected mailbox, expunging deleted messages. *)
304
+
305
+
val unselect : t -> unit
306
+
(** [unselect client] closes the selected mailbox without expunging. *)
307
+
308
+
(** {1 Message Commands}
309
+
310
+
Commands for working with messages. Require Selected state. *)
311
+
312
+
val fetch :
313
+
t ->
314
+
sequence:Protocol.sequence_set ->
315
+
items:Protocol.fetch_item list ->
316
+
message_info list
317
+
(** [fetch client ~sequence ~items] retrieves message data.
318
+
319
+
@param sequence Message sequence numbers to fetch.
320
+
@param items Data items to retrieve.
321
+
322
+
Example:
323
+
{[
324
+
let msgs =
325
+
Client.fetch client
326
+
~sequence:[ Range (1, 10) ]
327
+
~items:[ Fetch_uid; Fetch_flags; Fetch_envelope ]
328
+
in
329
+
List.iter
330
+
(fun m ->
331
+
Printf.printf "[%ld] %s\n"
332
+
(Option.get m.uid)
333
+
(Option.value ~default:"(no subject)"
334
+
(Option.bind m.envelope (fun e -> e.subject))))
335
+
msgs
336
+
]} *)
337
+
338
+
val uid_fetch :
339
+
t ->
340
+
sequence:Protocol.sequence_set ->
341
+
items:Protocol.fetch_item list ->
342
+
message_info list
343
+
(** [uid_fetch client ~sequence ~items] fetches by UID instead of sequence number. *)
344
+
345
+
val store :
346
+
t ->
347
+
sequence:Protocol.sequence_set ->
348
+
action:Protocol.store_action ->
349
+
flags:Protocol.flag list ->
350
+
?silent:bool ->
351
+
unit ->
352
+
message_info list
353
+
(** [store client ~sequence ~action ?silent ~flags] modifies message flags.
354
+
355
+
@param action [Store_set], [Store_add], or [Store_remove].
356
+
@param silent If true, don't return updated flags (default: false).
357
+
358
+
Example:
359
+
{[
360
+
(* Mark messages 1-5 as seen *)
361
+
Client.store client
362
+
~sequence:[ Range (1, 5) ]
363
+
~action:Store_add
364
+
~flags:[ System Seen ]
365
+
]} *)
366
+
367
+
val uid_store :
368
+
t ->
369
+
sequence:Protocol.sequence_set ->
370
+
action:Protocol.store_action ->
371
+
flags:Protocol.flag list ->
372
+
?silent:bool ->
373
+
unit ->
374
+
message_info list
375
+
(** [uid_store client ~sequence ~action ~flags ?silent ()] stores by UID. *)
376
+
377
+
val copy : t -> sequence:Protocol.sequence_set -> mailbox:string -> unit
378
+
(** [copy client ~sequence ~mailbox] copies messages to another mailbox. *)
379
+
380
+
val uid_copy : t -> sequence:Protocol.sequence_set -> mailbox:string -> unit
381
+
(** [uid_copy client ~sequence ~mailbox] copies by UID. *)
382
+
383
+
val move : t -> sequence:Protocol.sequence_set -> mailbox:string -> unit
384
+
(** [move client ~sequence ~mailbox] moves messages to another mailbox (RFC 6851).
385
+
386
+
@raise Client_error.Capability_missing if MOVE not supported. *)
387
+
388
+
val uid_move : t -> sequence:Protocol.sequence_set -> mailbox:string -> unit
389
+
(** [uid_move client ~sequence ~mailbox] moves by UID. *)
390
+
391
+
val expunge : t -> int list
392
+
(** [expunge client] permanently removes messages marked as Deleted.
393
+
Returns list of expunged sequence numbers. *)
394
+
395
+
val uid_expunge : t -> Protocol.sequence_set -> int list
396
+
(** [uid_expunge client uids] expunges only the specified UIDs. *)
397
+
398
+
val search : t -> ?charset:string -> Protocol.search_key -> int list
399
+
(** [search client ?charset criteria] searches for messages.
400
+
Returns list of matching sequence numbers.
401
+
402
+
Example:
403
+
{[
404
+
(* Find unseen messages from "alice@example.com" *)
405
+
let results =
406
+
Client.search client
407
+
(Search_and [ Search_unseen; Search_from "alice@example.com" ])
408
+
in
409
+
Printf.printf "Found %d messages\n" (List.length results)
410
+
]} *)
411
+
412
+
val uid_search : t -> ?charset:string -> Protocol.search_key -> int32 list
413
+
(** [uid_search client ?charset criteria] searches and returns UIDs. *)
414
+
415
+
val append :
416
+
t ->
417
+
mailbox:string ->
418
+
message:string ->
419
+
?flags:Protocol.flag list ->
420
+
?date:string ->
421
+
unit ->
422
+
int32 option
423
+
(** [append client ~mailbox ?flags ?date ~message] appends a message.
424
+
425
+
@param mailbox Destination mailbox.
426
+
@param flags Initial flags for the message.
427
+
@param date Internal date (RFC 2822 format).
428
+
@param message Complete RFC 5322 message.
429
+
@return UID of appended message if UIDPLUS is supported. *)
430
+
431
+
(** {1 IDLE Support}
432
+
433
+
IDLE allows the client to receive real-time notifications. *)
434
+
435
+
val idle : t -> timeout:float -> idle_event list
436
+
(** [idle client ~timeout] enters IDLE mode and waits for events.
437
+
438
+
@param timeout Maximum time to wait in seconds.
439
+
@return Events received during IDLE.
440
+
441
+
@raise Client_error.Capability_missing if IDLE not supported.
442
+
443
+
Example:
444
+
{[
445
+
let rec watch () =
446
+
let events = Client.idle client ~timeout:300.0 in
447
+
List.iter
448
+
(function
449
+
| Idle_exists n -> Printf.printf "New message! Total: %d\n" n
450
+
| Idle_expunge n -> Printf.printf "Message %d expunged\n" n
451
+
| Idle_fetch { seq; flags } ->
452
+
Printf.printf "Message %d flags changed\n" seq)
453
+
events;
454
+
watch ()
455
+
in
456
+
watch ()
457
+
]} *)
458
+
459
+
val idle_done : t -> unit
460
+
(** [idle_done client] exits IDLE mode early.
461
+
Only valid while in IDLE state. *)
462
+
463
+
(** {1 Extensions} *)
464
+
465
+
val enable : t -> string list -> string list
466
+
(** [enable client extensions] enables protocol extensions.
467
+
Returns list of successfully enabled extensions.
468
+
469
+
Common extensions:
470
+
- ["CONDSTORE"] - Conditional STORE and FETCH
471
+
- ["QRESYNC"] - Quick resynchronization
472
+
473
+
@raise Client_error.State_error if not authenticated. *)
+87
lib/imapd/client_error.ml
+87
lib/imapd/client_error.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type error =
7
+
| Connection_error of { reason : string }
8
+
| Protocol_error of { code : Protocol.response_code option; text : string }
9
+
| Parse_error of { reason : string; data : string option }
10
+
| State_error of { expected : string; actual : string }
11
+
| Timeout of { operation : string }
12
+
| Capability_missing of { capability : string }
13
+
| Authentication_error of { mechanism : string; reason : string }
14
+
15
+
type Eio.Exn.err += E of error
16
+
17
+
let err e = Eio.Exn.create (E e)
18
+
19
+
let is_retryable = function
20
+
| Connection_error _ | Timeout _ -> true
21
+
| Protocol_error _ | Parse_error _ | State_error _ | Capability_missing _
22
+
| Authentication_error _ ->
23
+
false
24
+
25
+
let is_auth_error = function
26
+
| Authentication_error _ -> true
27
+
| Protocol_error { code = Some code; _ } -> (
28
+
match code with
29
+
| Protocol.Code_authenticationfailed
30
+
| Protocol.Code_authorizationfailed ->
31
+
true
32
+
| _ -> false)
33
+
| Protocol_error { code = None; _ }
34
+
| Connection_error _ | Parse_error _ | State_error _ | Timeout _
35
+
| Capability_missing _ ->
36
+
false
37
+
38
+
let is_state_error = function State_error _ -> true | _ -> false
39
+
let of_eio_exn = function Eio.Io (E e, _) -> Some e | _ -> None
40
+
41
+
let pp_response_code ppf code =
42
+
match code with
43
+
| Protocol.Code_alert -> Fmt.pf ppf "ALERT"
44
+
| Protocol.Code_alreadyexists -> Fmt.pf ppf "ALREADYEXISTS"
45
+
| Protocol.Code_authenticationfailed -> Fmt.pf ppf "AUTHENTICATIONFAILED"
46
+
| Protocol.Code_authorizationfailed -> Fmt.pf ppf "AUTHORIZATIONFAILED"
47
+
| Protocol.Code_cannot -> Fmt.pf ppf "CANNOT"
48
+
| Protocol.Code_closed -> Fmt.pf ppf "CLOSED"
49
+
| Protocol.Code_nonexistent -> Fmt.pf ppf "NONEXISTENT"
50
+
| Protocol.Code_noperm -> Fmt.pf ppf "NOPERM"
51
+
| Protocol.Code_overquota -> Fmt.pf ppf "OVERQUOTA"
52
+
| Protocol.Code_readonly -> Fmt.pf ppf "READ-ONLY"
53
+
| Protocol.Code_readwrite -> Fmt.pf ppf "READ-WRITE"
54
+
| Protocol.Code_trycreate -> Fmt.pf ppf "TRYCREATE"
55
+
| Protocol.Code_uidvalidity v -> Fmt.pf ppf "UIDVALIDITY %ld" v
56
+
| Protocol.Code_uidnext u -> Fmt.pf ppf "UIDNEXT %ld" u
57
+
| Protocol.Code_other (name, _) -> Fmt.pf ppf "%s" name
58
+
| _ -> Fmt.pf ppf "<code>"
59
+
60
+
let pp ppf = function
61
+
| Connection_error { reason } -> Fmt.pf ppf "connection error: %s" reason
62
+
| Protocol_error { code; text } -> (
63
+
match code with
64
+
| Some c -> Fmt.pf ppf "protocol error [%a]: %s" pp_response_code c text
65
+
| None -> Fmt.pf ppf "protocol error: %s" text)
66
+
| Parse_error { reason; data } -> (
67
+
match data with
68
+
| Some d ->
69
+
let preview = if String.length d > 50 then String.sub d 0 50 ^ "..." else d in
70
+
Fmt.pf ppf "parse error: %s (data: %s)" reason preview
71
+
| None -> Fmt.pf ppf "parse error: %s" reason)
72
+
| State_error { expected; actual } ->
73
+
Fmt.pf ppf "state error: expected %s, in %s" expected actual
74
+
| Timeout { operation } -> Fmt.pf ppf "timeout: %s" operation
75
+
| Capability_missing { capability } ->
76
+
Fmt.pf ppf "capability missing: %s" capability
77
+
| Authentication_error { mechanism; reason } ->
78
+
Fmt.pf ppf "authentication error (%s): %s" mechanism reason
79
+
80
+
let to_string e = Fmt.str "%a" pp e
81
+
82
+
let () =
83
+
Eio.Exn.register_pp (fun ppf -> function
84
+
| E e ->
85
+
Fmt.pf ppf "Client_error.E(%a)" pp e;
86
+
true
87
+
| _ -> false)
+97
lib/imapd/client_error.mli
+97
lib/imapd/client_error.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Client Error Types
7
+
8
+
Errors from IMAP client operations are wrapped as [Eio.Io] exceptions for
9
+
consistency with other Eio-based libraries. The error type provides
10
+
structured access to IMAP-specific error details.
11
+
12
+
{2 Error Handling}
13
+
14
+
{[
15
+
try
16
+
let mailbox = Client.select client "INBOX" in
17
+
(* ... *)
18
+
with
19
+
| Eio.Io (Client_error.E err, _) ->
20
+
match err with
21
+
| Protocol_error { code; text } ->
22
+
Printf.eprintf "Server error: %s\n" text
23
+
| Connection_error { reason } ->
24
+
Printf.eprintf "Connection failed: %s\n" reason
25
+
| _ -> (* Handle other errors *)
26
+
]}
27
+
28
+
{2 References}
29
+
{ul
30
+
{- {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} - IMAP4rev2}} *)
31
+
32
+
(** {1 Error Types} *)
33
+
34
+
type error =
35
+
| Connection_error of { reason : string }
36
+
(** Network-level failure (connection refused, timeout, DNS failure, etc.) *)
37
+
| Protocol_error of { code : Protocol.response_code option; text : string }
38
+
(** Server returned NO or BAD response to a command. *)
39
+
| Parse_error of { reason : string; data : string option }
40
+
(** Failed to parse server response. *)
41
+
| State_error of { expected : string; actual : string }
42
+
(** Command not valid in current connection state. *)
43
+
| Timeout of { operation : string }
44
+
(** Operation timed out. *)
45
+
| Capability_missing of { capability : string }
46
+
(** Required capability not advertised by server. *)
47
+
| Authentication_error of { mechanism : string; reason : string }
48
+
(** SASL authentication failed. *)
49
+
50
+
(** {1 Eio Exception Integration} *)
51
+
52
+
type Eio.Exn.err +=
53
+
| E of error
54
+
(** Eio exception wrapper for IMAP client errors.
55
+
56
+
Raise with: [raise (Eio.Exn.create (E error))]
57
+
Catch with: [Eio.Io (E error, _)] *)
58
+
59
+
val err : error -> exn
60
+
(** [err e] creates an Eio exception from an error.
61
+
Equivalent to [Eio.Exn.create (E e)]. *)
62
+
63
+
(** {1 Error Properties} *)
64
+
65
+
val is_retryable : error -> bool
66
+
(** [is_retryable e] returns [true] if the error is transient and the operation
67
+
may succeed on retry.
68
+
69
+
Retryable errors include:
70
+
- Connection errors (network issues)
71
+
- Timeouts *)
72
+
73
+
val is_auth_error : error -> bool
74
+
(** [is_auth_error e] returns [true] if the error indicates an authentication
75
+
problem that requires re-authentication.
76
+
77
+
Auth errors include:
78
+
- [Authentication_error]
79
+
- Protocol errors with [AUTHENTICATIONFAILED] or [AUTHORIZATIONFAILED] codes *)
80
+
81
+
val is_state_error : error -> bool
82
+
(** [is_state_error e] returns [true] if the error indicates the command was
83
+
issued in the wrong connection state. *)
84
+
85
+
(** {1 Error Extraction} *)
86
+
87
+
val of_eio_exn : exn -> error option
88
+
(** [of_eio_exn exn] extracts an IMAP error from an Eio exception.
89
+
Returns [None] if the exception is not an IMAP client error. *)
90
+
91
+
(** {1 Formatting} *)
92
+
93
+
val pp : error Fmt.t
94
+
(** Pretty-print an error. *)
95
+
96
+
val to_string : error -> string
97
+
(** Convert error to human-readable string. *)
+181
lib/imapd/client_pool.ml
+181
lib/imapd/client_pool.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type config = {
7
+
min_connections : int;
8
+
max_connections : int;
9
+
idle_timeout : float;
10
+
health_check_interval : float;
11
+
}
12
+
13
+
let default_config =
14
+
{
15
+
min_connections = 1;
16
+
max_connections = 10;
17
+
idle_timeout = 300.0;
18
+
health_check_interval = 60.0;
19
+
}
20
+
21
+
type stats = {
22
+
total : int;
23
+
active : int;
24
+
idle : int;
25
+
created : int;
26
+
reused : int;
27
+
failed : int;
28
+
}
29
+
30
+
type t = {
31
+
connect_fn : unit -> Client.t option;
32
+
config : config;
33
+
mutable connections : Client.t list;
34
+
mutable active : Client.t list;
35
+
mutex : Eio.Mutex.t;
36
+
condition : Eio.Condition.t;
37
+
mutable closed : bool;
38
+
mutable stats_created : int;
39
+
mutable stats_reused : int;
40
+
mutable stats_failed : int;
41
+
}
42
+
43
+
let create_connection t =
44
+
match t.connect_fn () with
45
+
| Some client ->
46
+
t.stats_created <- t.stats_created + 1;
47
+
Some client
48
+
| None ->
49
+
t.stats_failed <- t.stats_failed + 1;
50
+
None
51
+
52
+
let is_healthy client =
53
+
try
54
+
Client.noop client;
55
+
true
56
+
with _ -> false
57
+
58
+
let create ~sw ~env ~host ?(port = 993) ~username ~password ?tls_config
59
+
?(config = default_config) () =
60
+
let connect_fn () =
61
+
try
62
+
let client =
63
+
Client.connect ~sw ~env ~host ~port ?tls_config ()
64
+
in
65
+
Client.login client ~username ~password;
66
+
Some client
67
+
with _ -> None
68
+
in
69
+
let t =
70
+
{
71
+
connect_fn;
72
+
config;
73
+
connections = [];
74
+
active = [];
75
+
mutex = Eio.Mutex.create ();
76
+
condition = Eio.Condition.create ();
77
+
closed = false;
78
+
stats_created = 0;
79
+
stats_reused = 0;
80
+
stats_failed = 0;
81
+
}
82
+
in
83
+
84
+
(* Create minimum connections *)
85
+
for _ = 1 to config.min_connections do
86
+
match create_connection t with
87
+
| Some client -> t.connections <- client :: t.connections
88
+
| None -> ()
89
+
done;
90
+
91
+
t
92
+
93
+
let close t =
94
+
Eio.Mutex.use_rw ~protect:false t.mutex (fun () ->
95
+
t.closed <- true;
96
+
List.iter Client.disconnect t.connections;
97
+
List.iter Client.disconnect t.active;
98
+
t.connections <- [];
99
+
t.active <- []);
100
+
Eio.Condition.broadcast t.condition
101
+
102
+
let acquire t =
103
+
Eio.Mutex.use_rw ~protect:false t.mutex (fun () ->
104
+
if t.closed then
105
+
raise
106
+
(Client_error.err
107
+
(Connection_error { reason = "Pool is closed" }));
108
+
109
+
(* Try to get an existing healthy connection *)
110
+
let rec find_healthy = function
111
+
| [] -> None
112
+
| client :: rest ->
113
+
if is_healthy client then (
114
+
t.connections <- rest;
115
+
t.active <- client :: t.active;
116
+
t.stats_reused <- t.stats_reused + 1;
117
+
Some client)
118
+
else (
119
+
Client.disconnect client;
120
+
find_healthy rest)
121
+
in
122
+
123
+
match find_healthy t.connections with
124
+
| Some client -> client
125
+
| None ->
126
+
(* No healthy connection available *)
127
+
let total = List.length t.connections + List.length t.active in
128
+
if total < t.config.max_connections then
129
+
(* Create new connection *)
130
+
match create_connection t with
131
+
| Some client ->
132
+
t.active <- client :: t.active;
133
+
client
134
+
| None ->
135
+
raise
136
+
(Client_error.err
137
+
(Connection_error { reason = "Failed to create connection" }))
138
+
else
139
+
raise
140
+
(Client_error.err
141
+
(Connection_error { reason = "Pool exhausted" })))
142
+
143
+
let release t client =
144
+
Eio.Mutex.use_rw ~protect:false t.mutex (fun () ->
145
+
t.active <- List.filter (fun c -> c != client) t.active;
146
+
if t.closed || not (is_healthy client) then Client.disconnect client
147
+
else (
148
+
(* Unselect any mailbox before returning to pool *)
149
+
(try
150
+
match Client.state client with
151
+
| Client.Selected _ -> Client.close client
152
+
| _ -> ()
153
+
with _ -> ());
154
+
t.connections <- client :: t.connections));
155
+
Eio.Condition.broadcast t.condition
156
+
157
+
let with_client t fn =
158
+
let client = acquire t in
159
+
match fn client with
160
+
| result ->
161
+
release t client;
162
+
result
163
+
| exception exn ->
164
+
(* On exception, close the connection instead of returning it *)
165
+
Eio.Mutex.use_rw ~protect:false t.mutex (fun () ->
166
+
t.active <- List.filter (fun c -> c != client) t.active);
167
+
(try Client.disconnect client with _ -> ());
168
+
raise exn
169
+
170
+
let stats t =
171
+
Eio.Mutex.use_rw ~protect:false t.mutex (fun () ->
172
+
let idle = List.length t.connections in
173
+
let active = List.length t.active in
174
+
{
175
+
total = idle + active;
176
+
active;
177
+
idle;
178
+
created = t.stats_created;
179
+
reused = t.stats_reused;
180
+
failed = t.stats_failed;
181
+
})
+139
lib/imapd/client_pool.mli
+139
lib/imapd/client_pool.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Connection Pool
7
+
8
+
This module provides connection pooling for IMAP clients using
9
+
{{:https://github.com/avsm/ocaml-conpool}conpool}.
10
+
11
+
{2 Why Pool Connections?}
12
+
13
+
IMAP connections are expensive to establish (TCP handshake, TLS negotiation,
14
+
authentication). A connection pool maintains authenticated connections ready
15
+
for reuse, significantly improving performance for applications that make
16
+
frequent IMAP requests.
17
+
18
+
{2 Example}
19
+
20
+
{[
21
+
Eio_main.run @@ fun env ->
22
+
Eio.Switch.run @@ fun sw ->
23
+
24
+
let pool =
25
+
Client_pool.create ~sw ~env ~host:"imap.example.com" ~port:993
26
+
~username:"user" ~password:"pass" ()
27
+
in
28
+
29
+
(* Connections are borrowed from the pool and automatically returned *)
30
+
Client_pool.with_client pool (fun client ->
31
+
let inbox = Client.select client "INBOX" in
32
+
Printf.printf "INBOX has %d messages\n" inbox.exists)
33
+
]}
34
+
35
+
{2 Health Checking}
36
+
37
+
The pool periodically validates connections using NOOP. Unhealthy connections
38
+
are automatically removed and replaced.
39
+
40
+
{2 References}
41
+
{ul
42
+
{- {{:https://github.com/avsm/ocaml-conpool}conpool} - Connection pooling library}} *)
43
+
44
+
(** {1 Types} *)
45
+
46
+
type t
47
+
(** An IMAP connection pool. *)
48
+
49
+
type config = {
50
+
min_connections : int; (** Minimum connections to maintain (default: 1) *)
51
+
max_connections : int; (** Maximum connections allowed (default: 10) *)
52
+
idle_timeout : float; (** Seconds before idle connection is closed (default: 300.0) *)
53
+
health_check_interval : float; (** Seconds between health checks (default: 60.0) *)
54
+
}
55
+
(** Pool configuration. *)
56
+
57
+
val default_config : config
58
+
(** Default configuration:
59
+
- [min_connections = 1]
60
+
- [max_connections = 10]
61
+
- [idle_timeout = 300.0]
62
+
- [health_check_interval = 60.0] *)
63
+
64
+
(** {1 Pool Management} *)
65
+
66
+
val create :
67
+
sw:Eio.Switch.t ->
68
+
env:< net : _ Eio.Net.t ; clock : _ Eio.Time.clock ; .. > ->
69
+
host:string ->
70
+
?port:int ->
71
+
username:string ->
72
+
password:string ->
73
+
?tls_config:Tls.Config.client ->
74
+
?config:config ->
75
+
unit ->
76
+
t
77
+
(** [create ~sw ~env ~host ?port ~username ~password ?tls_config ?config ()]
78
+
creates a new connection pool.
79
+
80
+
All connections in the pool use the same credentials. The pool is
81
+
automatically closed when [sw] exits.
82
+
83
+
@param sw Switch for resource management.
84
+
@param env Eio environment with network and clock.
85
+
@param host IMAP server hostname.
86
+
@param port Server port (default: 993).
87
+
@param username Authentication username.
88
+
@param password Authentication password.
89
+
@param tls_config Optional TLS configuration.
90
+
@param config Pool configuration (default: {!default_config}). *)
91
+
92
+
val close : t -> unit
93
+
(** [close pool] closes all connections in the pool.
94
+
The pool should not be used after calling close. *)
95
+
96
+
(** {1 Using Connections} *)
97
+
98
+
val acquire : t -> Client.t
99
+
(** [acquire pool] gets a connection from the pool.
100
+
The connection is already authenticated.
101
+
102
+
@raise Client_error.Connection_error if pool is exhausted and
103
+
cannot create new connection. *)
104
+
105
+
val release : t -> Client.t -> unit
106
+
(** [release pool client] returns a connection to the pool.
107
+
If the connection is unhealthy, it is closed instead. *)
108
+
109
+
val with_client : t -> (Client.t -> 'a) -> 'a
110
+
(** [with_client pool fn] borrows a connection, runs [fn], and returns it.
111
+
112
+
This is the recommended way to use pooled connections:
113
+
{[
114
+
let messages =
115
+
Client_pool.with_client pool (fun client ->
116
+
Client.select client "INBOX" |> ignore;
117
+
Client.fetch client ~sequence:[ All ] ~items:[ Fetch_uid ])
118
+
in
119
+
List.iter (fun m -> Printf.printf "UID: %ld\n" (Option.get m.uid)) messages
120
+
]}
121
+
122
+
The connection is automatically returned to the pool even if [fn] raises
123
+
an exception. If an exception occurs, the connection is closed rather
124
+
than returned (it may be in an inconsistent state). *)
125
+
126
+
(** {1 Pool Statistics} *)
127
+
128
+
type stats = {
129
+
total : int; (** Total connections (active + idle) *)
130
+
active : int; (** Connections currently in use *)
131
+
idle : int; (** Connections waiting in pool *)
132
+
created : int; (** Total connections created since pool creation *)
133
+
reused : int; (** Total connection reuses *)
134
+
failed : int; (** Total connection failures *)
135
+
}
136
+
(** Pool statistics. *)
137
+
138
+
val stats : t -> stats
139
+
(** [stats pool] returns current pool statistics. *)
+24
lib/imapd/dune
+24
lib/imapd/dune
···
1
+
(library
2
+
(name imapd)
3
+
(public_name imapd)
4
+
(libraries
5
+
eio
6
+
eio_main
7
+
eio.unix
8
+
tls
9
+
tls-eio
10
+
cstruct
11
+
faraday
12
+
fmt
13
+
base64
14
+
unix)
15
+
(foreign_stubs
16
+
(language c)
17
+
(names pam_stubs)
18
+
(flags (:standard)))
19
+
(c_library_flags (-lpam)))
20
+
21
+
(ocamllex lexer)
22
+
23
+
(menhir
24
+
(modules grammar))
+979
lib/imapd/read.ml
+979
lib/imapd/read.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Protocol
7
+
module R = Eio.Buf_read
8
+
9
+
let is_atom_char = function
10
+
| '(' | ')' | '{' | ' ' | '\x00' .. '\x1f' | '\x7f' | '%' | '*' | '"' | '\\'
11
+
| '[' | ']' ->
12
+
false
13
+
| _ -> true
14
+
15
+
let is_digit c = c >= '0' && c <= '9'
16
+
let[@warning "-32"] is_space c = c = ' '
17
+
18
+
let sp r =
19
+
let c = R.any_char r in
20
+
if c <> ' ' then failwith (Printf.sprintf "expected SP, got %C" c)
21
+
22
+
let crlf r =
23
+
let c1 = R.any_char r in
24
+
let c2 = R.any_char r in
25
+
if c1 <> '\r' || c2 <> '\n' then
26
+
failwith (Printf.sprintf "expected CRLF, got %C%C" c1 c2)
27
+
28
+
let peek_char r = R.peek_char r
29
+
30
+
let[@warning "-32"] skip_while p r =
31
+
while
32
+
match peek_char r with Some c when p c -> true | _ -> false
33
+
do
34
+
ignore (R.any_char r)
35
+
done
36
+
37
+
let take_while p r =
38
+
let buf = Buffer.create 32 in
39
+
while
40
+
match peek_char r with
41
+
| Some c when p c ->
42
+
Buffer.add_char buf c;
43
+
ignore (R.any_char r);
44
+
true
45
+
| _ -> false
46
+
do
47
+
()
48
+
done;
49
+
Buffer.contents buf
50
+
51
+
let atom r =
52
+
let s = take_while is_atom_char r in
53
+
if String.length s = 0 then failwith "expected atom";
54
+
s
55
+
56
+
let number r =
57
+
let s = take_while is_digit r in
58
+
if String.length s = 0 then failwith "expected number";
59
+
int_of_string s
60
+
61
+
let number32 r = Int32.of_string (take_while is_digit r)
62
+
let number64 r = Int64.of_string (take_while is_digit r)
63
+
64
+
let quoted_string r =
65
+
let c = R.any_char r in
66
+
if c <> '"' then failwith (Printf.sprintf "expected '\"', got %C" c);
67
+
let buf = Buffer.create 64 in
68
+
let rec loop () =
69
+
match R.any_char r with
70
+
| '"' -> Buffer.contents buf
71
+
| '\\' ->
72
+
let c = R.any_char r in
73
+
Buffer.add_char buf c;
74
+
loop ()
75
+
| c ->
76
+
Buffer.add_char buf c;
77
+
loop ()
78
+
in
79
+
loop ()
80
+
81
+
let literal r =
82
+
let c = R.any_char r in
83
+
if c <> '{' then failwith (Printf.sprintf "expected '{', got %C" c);
84
+
let len = number r in
85
+
(* Handle optional '+' for LITERAL+ *)
86
+
(match peek_char r with Some '+' -> ignore (R.any_char r) | _ -> ());
87
+
let c = R.any_char r in
88
+
if c <> '}' then failwith (Printf.sprintf "expected '}', got %C" c);
89
+
crlf r;
90
+
R.take len r
91
+
92
+
let is_nil r =
93
+
(* Check if the next 3 characters spell "NIL" (case-insensitive) *)
94
+
R.ensure r 3;
95
+
let buf = R.peek r in
96
+
if Cstruct.length buf >= 3 then
97
+
let c1 = Cstruct.get_char buf 0 in
98
+
let c2 = Cstruct.get_char buf 1 in
99
+
let c3 = Cstruct.get_char buf 2 in
100
+
(c1 = 'N' || c1 = 'n') && (c2 = 'I' || c2 = 'i') && (c3 = 'L' || c3 = 'l')
101
+
else false
102
+
103
+
let nil r =
104
+
ignore (R.take 3 r);
105
+
(* Consume "NIL" *)
106
+
()
107
+
108
+
let astring r =
109
+
match peek_char r with
110
+
| Some '"' -> quoted_string r
111
+
| Some '{' -> literal r
112
+
| _ -> atom r
113
+
114
+
let nstring r =
115
+
if is_nil r then (
116
+
nil r;
117
+
None)
118
+
else Some (astring r)
119
+
120
+
(* Parse a flag *)
121
+
let flag r =
122
+
match peek_char r with
123
+
| Some '\\' ->
124
+
ignore (R.any_char r);
125
+
let name = atom r in
126
+
let upper = String.uppercase_ascii name in
127
+
let sf =
128
+
match upper with
129
+
| "SEEN" -> Some Seen
130
+
| "ANSWERED" -> Some Answered
131
+
| "FLAGGED" -> Some Flagged
132
+
| "DELETED" -> Some Deleted
133
+
| "DRAFT" -> Some Draft
134
+
| _ -> None
135
+
in
136
+
(match sf with Some f -> System f | None -> Keyword name)
137
+
| Some '$' ->
138
+
ignore (R.any_char r);
139
+
let name = atom r in
140
+
Keyword name
141
+
| _ ->
142
+
let name = atom r in
143
+
Keyword name
144
+
145
+
let flag_list r =
146
+
let c = R.any_char r in
147
+
if c <> '(' then failwith (Printf.sprintf "expected '(', got %C" c);
148
+
let rec loop acc =
149
+
match peek_char r with
150
+
| Some ')' ->
151
+
ignore (R.any_char r);
152
+
List.rev acc
153
+
| Some ' ' ->
154
+
ignore (R.any_char r);
155
+
loop acc
156
+
| Some _ ->
157
+
let f = flag r in
158
+
loop (f :: acc)
159
+
| None -> failwith "unexpected EOF in flag list"
160
+
in
161
+
loop []
162
+
163
+
(* Parse address: (name adl mailbox host) *)
164
+
let address r =
165
+
let c = R.any_char r in
166
+
if c <> '(' then failwith (Printf.sprintf "expected '(' for address, got %C" c);
167
+
let name = nstring r in
168
+
sp r;
169
+
let adl = nstring r in
170
+
sp r;
171
+
let mailbox = nstring r in
172
+
sp r;
173
+
let host = nstring r in
174
+
let c = R.any_char r in
175
+
if c <> ')' then failwith (Printf.sprintf "expected ')' for address, got %C" c);
176
+
{ name; adl; mailbox; host }
177
+
178
+
let address_list r =
179
+
if is_nil r then (
180
+
nil r;
181
+
[])
182
+
else
183
+
let c = R.any_char r in
184
+
if c <> '(' then
185
+
failwith (Printf.sprintf "expected '(' for address list, got %C" c);
186
+
let rec loop acc =
187
+
match peek_char r with
188
+
| Some ')' ->
189
+
ignore (R.any_char r);
190
+
List.rev acc
191
+
| Some ' ' ->
192
+
ignore (R.any_char r);
193
+
loop acc
194
+
| Some '(' ->
195
+
let addr = address r in
196
+
loop (addr :: acc)
197
+
| Some c -> failwith (Printf.sprintf "unexpected %C in address list" c)
198
+
| None -> failwith "unexpected EOF in address list"
199
+
in
200
+
loop []
201
+
202
+
let envelope r =
203
+
let c = R.any_char r in
204
+
if c <> '(' then failwith (Printf.sprintf "expected '(' for envelope, got %C" c);
205
+
let date = nstring r in
206
+
sp r;
207
+
let subject = nstring r in
208
+
sp r;
209
+
let from = address_list r in
210
+
sp r;
211
+
let sender = address_list r in
212
+
sp r;
213
+
let reply_to = address_list r in
214
+
sp r;
215
+
let to_ = address_list r in
216
+
sp r;
217
+
let cc = address_list r in
218
+
sp r;
219
+
let bcc = address_list r in
220
+
sp r;
221
+
let in_reply_to = nstring r in
222
+
sp r;
223
+
let message_id = nstring r in
224
+
let c = R.any_char r in
225
+
if c <> ')' then failwith (Printf.sprintf "expected ')' for envelope, got %C" c);
226
+
{ date; subject; from; sender; reply_to; to_; cc; bcc; in_reply_to; message_id }
227
+
228
+
(* Parse body extension data - skip over complex nested structures *)
229
+
let rec skip_body_ext r =
230
+
match peek_char r with
231
+
| Some '(' ->
232
+
ignore (R.any_char r);
233
+
let rec loop () =
234
+
match peek_char r with
235
+
| Some ')' ->
236
+
ignore (R.any_char r);
237
+
()
238
+
| Some ' ' ->
239
+
ignore (R.any_char r);
240
+
loop ()
241
+
| _ ->
242
+
skip_body_ext r;
243
+
loop ()
244
+
in
245
+
loop ()
246
+
| Some '"' ->
247
+
ignore (quoted_string r);
248
+
()
249
+
| Some '{' ->
250
+
ignore (literal r);
251
+
()
252
+
| Some c when is_digit c ->
253
+
ignore (take_while is_digit r);
254
+
()
255
+
| Some 'N' | Some 'n' when is_nil r ->
256
+
nil r;
257
+
()
258
+
| _ ->
259
+
ignore (take_while is_atom_char r);
260
+
()
261
+
262
+
(* Parse body parameters: NIL or ((key value) ...) *)
263
+
let body_params r =
264
+
if is_nil r then (
265
+
nil r;
266
+
[])
267
+
else
268
+
let c = R.any_char r in
269
+
if c <> '(' then
270
+
failwith (Printf.sprintf "expected '(' for params, got %C" c);
271
+
let rec loop acc =
272
+
match peek_char r with
273
+
| Some ')' ->
274
+
ignore (R.any_char r);
275
+
List.rev acc
276
+
| Some ' ' ->
277
+
ignore (R.any_char r);
278
+
loop acc
279
+
| Some '(' ->
280
+
ignore (R.any_char r);
281
+
let key = astring r in
282
+
sp r;
283
+
let value = astring r in
284
+
let c = R.any_char r in
285
+
if c <> ')' then
286
+
failwith (Printf.sprintf "expected ')' for param pair, got %C" c);
287
+
loop ((key, value) :: acc)
288
+
| Some c -> failwith (Printf.sprintf "unexpected %C in params" c)
289
+
| None -> failwith "unexpected EOF in params"
290
+
in
291
+
loop []
292
+
293
+
let body_fields r =
294
+
let params = body_params r in
295
+
sp r;
296
+
let content_id = nstring r in
297
+
sp r;
298
+
let description = nstring r in
299
+
sp r;
300
+
let encoding = astring r in
301
+
sp r;
302
+
let size = number64 r in
303
+
{ params; content_id; description; encoding; size }
304
+
305
+
(* Forward declaration for recursive parsing *)
306
+
let rec body_structure r =
307
+
let c = R.any_char r in
308
+
if c <> '(' then
309
+
failwith (Printf.sprintf "expected '(' for body structure, got %C" c);
310
+
match peek_char r with
311
+
| Some '(' ->
312
+
(* Multipart *)
313
+
let rec read_parts acc =
314
+
match peek_char r with
315
+
| Some '(' ->
316
+
let part = body_structure r in
317
+
read_parts (part :: acc)
318
+
| _ -> List.rev acc
319
+
in
320
+
let parts = read_parts [] in
321
+
sp r;
322
+
let subtype = astring r in
323
+
(* Optional extension data *)
324
+
let params =
325
+
match peek_char r with
326
+
| Some ' ' ->
327
+
sp r;
328
+
body_params r
329
+
| _ -> []
330
+
in
331
+
(* Skip remaining extension data *)
332
+
while
333
+
match peek_char r with
334
+
| Some ' ' ->
335
+
sp r;
336
+
skip_body_ext r;
337
+
true
338
+
| _ -> false
339
+
do
340
+
()
341
+
done;
342
+
let c = R.any_char r in
343
+
if c <> ')' then
344
+
failwith (Printf.sprintf "expected ')' for multipart, got %C" c);
345
+
{
346
+
body_type = Multipart { subtype; parts; params };
347
+
disposition = None;
348
+
language = None;
349
+
location = None;
350
+
}
351
+
| _ ->
352
+
(* Single part *)
353
+
let media_type = astring r in
354
+
sp r;
355
+
let subtype = astring r in
356
+
sp r;
357
+
let fields = body_fields r in
358
+
let body_type, extra_fields =
359
+
let upper = String.uppercase_ascii media_type in
360
+
if upper = "TEXT" then (
361
+
sp r;
362
+
let lines = number64 r in
363
+
(Text { subtype; fields; lines }, 0))
364
+
else if upper = "MESSAGE" && String.uppercase_ascii subtype = "RFC822"
365
+
then (
366
+
sp r;
367
+
let env = envelope r in
368
+
sp r;
369
+
let body = body_structure r in
370
+
sp r;
371
+
let lines = number64 r in
372
+
(Message_rfc822 { fields; envelope = env; body; lines }, 0))
373
+
else (Basic { media_type; subtype; fields }, 0)
374
+
in
375
+
ignore extra_fields;
376
+
(* Skip optional extension data *)
377
+
while
378
+
match peek_char r with
379
+
| Some ' ' ->
380
+
sp r;
381
+
skip_body_ext r;
382
+
true
383
+
| _ -> false
384
+
do
385
+
()
386
+
done;
387
+
let c = R.any_char r in
388
+
if c <> ')' then
389
+
failwith (Printf.sprintf "expected ')' for body part, got %C" c);
390
+
{ body_type; disposition = None; language = None; location = None }
391
+
392
+
(* Parse sequence set *)
393
+
let sequence_range r =
394
+
let n = number r in
395
+
match peek_char r with
396
+
| Some ':' ->
397
+
ignore (R.any_char r);
398
+
(match peek_char r with
399
+
| Some '*' ->
400
+
ignore (R.any_char r);
401
+
From n
402
+
| _ ->
403
+
let m = number r in
404
+
Range (n, m))
405
+
| _ -> Single n
406
+
407
+
let sequence_set r =
408
+
let rec loop acc =
409
+
let range = sequence_range r in
410
+
match peek_char r with
411
+
| Some ',' ->
412
+
ignore (R.any_char r);
413
+
loop (range :: acc)
414
+
| _ -> List.rev (range :: acc)
415
+
in
416
+
loop []
417
+
418
+
(* Parse response code *)
419
+
let response_code r =
420
+
let c = R.any_char r in
421
+
if c <> '[' then failwith (Printf.sprintf "expected '[', got %C" c);
422
+
let name = atom r in
423
+
let upper = String.uppercase_ascii name in
424
+
let code =
425
+
match upper with
426
+
| "ALERT" -> Code_alert
427
+
| "ALREADYEXISTS" -> Code_alreadyexists
428
+
| "AUTHENTICATIONFAILED" -> Code_authenticationfailed
429
+
| "AUTHORIZATIONFAILED" -> Code_authorizationfailed
430
+
| "CANNOT" -> Code_cannot
431
+
| "CLIENTBUG" -> Code_clientbug
432
+
| "CLOSED" -> Code_closed
433
+
| "CONTACTADMIN" -> Code_contactadmin
434
+
| "CORRUPTION" -> Code_corruption
435
+
| "EXPIRED" -> Code_expired
436
+
| "EXPUNGEISSUED" -> Code_expungeissued
437
+
| "HASCHILDREN" -> Code_haschildren
438
+
| "INUSE" -> Code_inuse
439
+
| "LIMIT" -> Code_limit
440
+
| "NONEXISTENT" -> Code_nonexistent
441
+
| "NOPERM" -> Code_noperm
442
+
| "OVERQUOTA" -> Code_overquota
443
+
| "PARSE" -> Code_parse
444
+
| "PRIVACYREQUIRED" -> Code_privacyrequired
445
+
| "READ-ONLY" -> Code_readonly
446
+
| "READ-WRITE" -> Code_readwrite
447
+
| "SERVERBUG" -> Code_serverbug
448
+
| "TRYCREATE" -> Code_trycreate
449
+
| "UIDNOTSTICKY" -> Code_uidnotsticky
450
+
| "UNAVAILABLE" -> Code_unavailable
451
+
| "UNKNOWN-CTE" -> Code_unknown_cte
452
+
| "UIDVALIDITY" ->
453
+
sp r;
454
+
Code_uidvalidity (number32 r)
455
+
| "UIDNEXT" ->
456
+
sp r;
457
+
Code_uidnext (number32 r)
458
+
| "APPENDUID" ->
459
+
sp r;
460
+
let v = number32 r in
461
+
sp r;
462
+
let u = number32 r in
463
+
Code_appenduid (v, u)
464
+
| "COPYUID" ->
465
+
sp r;
466
+
let v = number32 r in
467
+
sp r;
468
+
let src = sequence_set r in
469
+
sp r;
470
+
let dst = sequence_set r in
471
+
Code_copyuid (v, src, dst)
472
+
| "CAPABILITY" ->
473
+
let rec loop acc =
474
+
match peek_char r with
475
+
| Some ' ' ->
476
+
sp r;
477
+
let cap = atom r in
478
+
loop (cap :: acc)
479
+
| _ -> List.rev acc
480
+
in
481
+
Code_capability (loop [])
482
+
| "PERMANENTFLAGS" ->
483
+
sp r;
484
+
Code_permanentflags (flag_list r)
485
+
| "BADCHARSET" ->
486
+
let charsets =
487
+
match peek_char r with
488
+
| Some ' ' ->
489
+
sp r;
490
+
let c = R.any_char r in
491
+
if c <> '(' then [] (* Malformed, return empty *)
492
+
else
493
+
let rec loop acc =
494
+
match peek_char r with
495
+
| Some ')' ->
496
+
ignore (R.any_char r);
497
+
List.rev acc
498
+
| Some ' ' ->
499
+
sp r;
500
+
loop acc
501
+
| _ ->
502
+
let cs = astring r in
503
+
loop (cs :: acc)
504
+
in
505
+
loop []
506
+
| _ -> []
507
+
in
508
+
Code_badcharset charsets
509
+
| _ ->
510
+
(* Unknown code, possibly with a value *)
511
+
let value =
512
+
match peek_char r with
513
+
| Some ' ' ->
514
+
sp r;
515
+
Some (take_while (fun c -> c <> ']') r)
516
+
| _ -> None
517
+
in
518
+
Code_other (name, value)
519
+
in
520
+
let c = R.any_char r in
521
+
if c <> ']' then failwith (Printf.sprintf "expected ']', got %C" c);
522
+
code
523
+
524
+
(* Parse a list flag *)
525
+
let list_flag r =
526
+
match peek_char r with
527
+
| Some '\\' ->
528
+
ignore (R.any_char r);
529
+
let name = atom r in
530
+
let upper = String.uppercase_ascii name in
531
+
(match upper with
532
+
| "NOINFERIORS" -> List_noinferiors
533
+
| "NOSELECT" -> List_noselect
534
+
| "MARKED" -> List_marked
535
+
| "UNMARKED" -> List_unmarked
536
+
| "SUBSCRIBED" -> List_subscribed
537
+
| "HASCHILDREN" -> List_haschildren
538
+
| "HASNOCHILDREN" -> List_hasnochildren
539
+
| "ALL" -> List_all
540
+
| "ARCHIVE" -> List_archive
541
+
| "DRAFTS" -> List_drafts
542
+
| "FLAGGED" -> List_flagged
543
+
| "JUNK" -> List_junk
544
+
| "SENT" -> List_sent
545
+
| "TRASH" -> List_trash
546
+
| _ -> List_extension ("\\" ^ name))
547
+
| _ ->
548
+
let name = atom r in
549
+
List_extension name
550
+
551
+
let list_flag_list r =
552
+
let c = R.any_char r in
553
+
if c <> '(' then failwith (Printf.sprintf "expected '(', got %C" c);
554
+
let rec loop acc =
555
+
match peek_char r with
556
+
| Some ')' ->
557
+
ignore (R.any_char r);
558
+
List.rev acc
559
+
| Some ' ' ->
560
+
ignore (R.any_char r);
561
+
loop acc
562
+
| _ ->
563
+
let f = list_flag r in
564
+
loop (f :: acc)
565
+
in
566
+
loop []
567
+
568
+
(* Parse fetch response items *)
569
+
let fetch_item r =
570
+
let name = atom r in
571
+
let upper = String.uppercase_ascii name in
572
+
match upper with
573
+
| "FLAGS" ->
574
+
sp r;
575
+
Fetch_item_flags (flag_list r)
576
+
| "UID" ->
577
+
sp r;
578
+
Fetch_item_uid (number32 r)
579
+
| "INTERNALDATE" ->
580
+
sp r;
581
+
Fetch_item_internaldate (quoted_string r)
582
+
| "RFC822.SIZE" ->
583
+
sp r;
584
+
Fetch_item_rfc822_size (number64 r)
585
+
| "ENVELOPE" ->
586
+
sp r;
587
+
Fetch_item_envelope (envelope r)
588
+
| "BODY" -> (
589
+
match peek_char r with
590
+
| Some '[' ->
591
+
ignore (R.any_char r);
592
+
let _section = take_while (fun c -> c <> ']') r in
593
+
ignore (R.any_char r);
594
+
(* ] *)
595
+
let origin =
596
+
match peek_char r with
597
+
| Some '<' ->
598
+
ignore (R.any_char r);
599
+
let o = number r in
600
+
ignore (R.any_char r);
601
+
(* > *)
602
+
Some o
603
+
| _ -> None
604
+
in
605
+
sp r;
606
+
let data = nstring r in
607
+
Fetch_item_body_section { section = None; origin; data }
608
+
(* Simplified: we don't parse section spec *)
609
+
| Some ' ' ->
610
+
sp r;
611
+
Fetch_item_body (body_structure r)
612
+
| _ -> Fetch_item_body (body_structure r))
613
+
| "BODYSTRUCTURE" ->
614
+
sp r;
615
+
Fetch_item_bodystructure (body_structure r)
616
+
| _ -> failwith (Printf.sprintf "unknown fetch item: %s" name)
617
+
618
+
let fetch_items r =
619
+
let c = R.any_char r in
620
+
if c <> '(' then failwith (Printf.sprintf "expected '(' for fetch, got %C" c);
621
+
let rec loop acc =
622
+
match peek_char r with
623
+
| Some ')' ->
624
+
ignore (R.any_char r);
625
+
List.rev acc
626
+
| Some ' ' ->
627
+
sp r;
628
+
loop acc
629
+
| _ ->
630
+
let item = fetch_item r in
631
+
loop (item :: acc)
632
+
in
633
+
loop []
634
+
635
+
(* Parse status items *)
636
+
let status_items r =
637
+
let c = R.any_char r in
638
+
if c <> '(' then failwith (Printf.sprintf "expected '(' for status, got %C" c);
639
+
let rec loop acc =
640
+
match peek_char r with
641
+
| Some ')' ->
642
+
ignore (R.any_char r);
643
+
List.rev acc
644
+
| Some ' ' ->
645
+
sp r;
646
+
loop acc
647
+
| _ ->
648
+
let name = atom r in
649
+
sp r;
650
+
let value = number64 r in
651
+
let item =
652
+
match String.uppercase_ascii name with
653
+
| "MESSAGES" -> Status_messages
654
+
| "UIDNEXT" -> Status_uidnext
655
+
| "UIDVALIDITY" -> Status_uidvalidity
656
+
| "UNSEEN" -> Status_unseen
657
+
| "DELETED" -> Status_deleted
658
+
| "SIZE" -> Status_size
659
+
| _ -> Status_messages (* Unknown, default *)
660
+
in
661
+
loop ((item, value) :: acc)
662
+
in
663
+
loop []
664
+
665
+
(* Parse namespace entry *)
666
+
let namespace_entry r =
667
+
let c = R.any_char r in
668
+
if c <> '(' then
669
+
failwith (Printf.sprintf "expected '(' for namespace entry, got %C" c);
670
+
let prefix = quoted_string r in
671
+
sp r;
672
+
let delimiter =
673
+
if is_nil r then (
674
+
nil r;
675
+
None)
676
+
else
677
+
let s = quoted_string r in
678
+
if String.length s > 0 then Some s.[0] else None
679
+
in
680
+
(* Skip any extension data *)
681
+
while
682
+
match peek_char r with
683
+
| Some ' ' ->
684
+
sp r;
685
+
skip_body_ext r;
686
+
true
687
+
| _ -> false
688
+
do
689
+
()
690
+
done;
691
+
let c = R.any_char r in
692
+
if c <> ')' then
693
+
failwith (Printf.sprintf "expected ')' for namespace entry, got %C" c);
694
+
{ prefix; delimiter }
695
+
696
+
let namespace_list r =
697
+
if is_nil r then (
698
+
nil r;
699
+
None)
700
+
else
701
+
let c = R.any_char r in
702
+
if c <> '(' then
703
+
failwith (Printf.sprintf "expected '(' for namespace list, got %C" c);
704
+
let rec loop acc =
705
+
match peek_char r with
706
+
| Some ')' ->
707
+
ignore (R.any_char r);
708
+
Some (List.rev acc)
709
+
| Some ' ' ->
710
+
sp r;
711
+
loop acc
712
+
| Some '(' ->
713
+
let entry = namespace_entry r in
714
+
loop (entry :: acc)
715
+
| Some c -> failwith (Printf.sprintf "unexpected %C in namespace" c)
716
+
| None -> failwith "unexpected EOF in namespace"
717
+
in
718
+
loop []
719
+
720
+
(* Read until CRLF *)
721
+
let read_text r =
722
+
let buf = Buffer.create 64 in
723
+
let rec loop () =
724
+
match peek_char r with
725
+
| Some '\r' -> Buffer.contents buf
726
+
| Some c ->
727
+
Buffer.add_char buf c;
728
+
ignore (R.any_char r);
729
+
loop ()
730
+
| None -> Buffer.contents buf
731
+
in
732
+
loop ()
733
+
734
+
(* Parse response *)
735
+
let response r =
736
+
match peek_char r with
737
+
| Some '+' ->
738
+
(* Continuation *)
739
+
ignore (R.any_char r);
740
+
(match peek_char r with
741
+
| Some ' ' ->
742
+
sp r;
743
+
let text = read_text r in
744
+
crlf r;
745
+
Continuation (if String.length text > 0 then Some text else None)
746
+
| Some '\r' ->
747
+
crlf r;
748
+
Continuation None
749
+
| _ ->
750
+
let text = read_text r in
751
+
crlf r;
752
+
Continuation (Some text))
753
+
| Some '*' ->
754
+
(* Untagged response *)
755
+
ignore (R.any_char r);
756
+
sp r;
757
+
(* Check if it's a number (EXISTS, EXPUNGE, FETCH) *)
758
+
(match peek_char r with
759
+
| Some c when is_digit c ->
760
+
let n = number r in
761
+
sp r;
762
+
let kind = atom r in
763
+
let upper = String.uppercase_ascii kind in
764
+
(match upper with
765
+
| "EXISTS" ->
766
+
crlf r;
767
+
Exists n
768
+
| "EXPUNGE" ->
769
+
crlf r;
770
+
Expunge_response n
771
+
| "FETCH" ->
772
+
sp r;
773
+
let items = fetch_items r in
774
+
crlf r;
775
+
Fetch_response { seq = n; items }
776
+
| _ ->
777
+
(* Unknown numbered response, skip to end of line *)
778
+
ignore (read_text r);
779
+
crlf r;
780
+
Ok { tag = None; code = None; text = "" })
781
+
| _ ->
782
+
let keyword = atom r in
783
+
let upper = String.uppercase_ascii keyword in
784
+
(match upper with
785
+
| "OK" ->
786
+
sp r;
787
+
let code =
788
+
match peek_char r with
789
+
| Some '[' -> Some (response_code r)
790
+
| _ -> None
791
+
in
792
+
(match code with Some _ -> sp r | None -> ());
793
+
let text = read_text r in
794
+
crlf r;
795
+
Ok { tag = None; code; text }
796
+
| "NO" ->
797
+
sp r;
798
+
let code =
799
+
match peek_char r with
800
+
| Some '[' -> Some (response_code r)
801
+
| _ -> None
802
+
in
803
+
(match code with Some _ -> sp r | None -> ());
804
+
let text = read_text r in
805
+
crlf r;
806
+
No { tag = None; code; text }
807
+
| "BAD" ->
808
+
sp r;
809
+
let code =
810
+
match peek_char r with
811
+
| Some '[' -> Some (response_code r)
812
+
| _ -> None
813
+
in
814
+
(match code with Some _ -> sp r | None -> ());
815
+
let text = read_text r in
816
+
crlf r;
817
+
Bad { tag = None; code; text }
818
+
| "PREAUTH" ->
819
+
sp r;
820
+
let code =
821
+
match peek_char r with
822
+
| Some '[' -> Some (response_code r)
823
+
| _ -> None
824
+
in
825
+
(match code with Some _ -> sp r | None -> ());
826
+
let text = read_text r in
827
+
crlf r;
828
+
Preauth { code; text }
829
+
| "BYE" ->
830
+
sp r;
831
+
let code =
832
+
match peek_char r with
833
+
| Some '[' -> Some (response_code r)
834
+
| _ -> None
835
+
in
836
+
(match code with Some _ -> sp r | None -> ());
837
+
let text = read_text r in
838
+
crlf r;
839
+
Bye { code; text }
840
+
| "CAPABILITY" ->
841
+
let rec loop acc =
842
+
match peek_char r with
843
+
| Some ' ' ->
844
+
sp r;
845
+
let cap = atom r in
846
+
loop (cap :: acc)
847
+
| Some '\r' -> List.rev acc
848
+
| _ -> List.rev acc
849
+
in
850
+
let caps = loop [] in
851
+
crlf r;
852
+
Capability_response caps
853
+
| "FLAGS" ->
854
+
sp r;
855
+
let flags = flag_list r in
856
+
crlf r;
857
+
Flags_response flags
858
+
| "LIST" ->
859
+
sp r;
860
+
let flags = list_flag_list r in
861
+
sp r;
862
+
let delimiter =
863
+
if is_nil r then (
864
+
nil r;
865
+
None)
866
+
else
867
+
let s = quoted_string r in
868
+
if String.length s > 0 then Some s.[0] else None
869
+
in
870
+
sp r;
871
+
let name = astring r in
872
+
crlf r;
873
+
List_response { flags; delimiter; name }
874
+
| "STATUS" ->
875
+
sp r;
876
+
let mailbox = astring r in
877
+
sp r;
878
+
let items = status_items r in
879
+
crlf r;
880
+
Status_response { mailbox; items }
881
+
| "NAMESPACE" ->
882
+
sp r;
883
+
let personal = namespace_list r in
884
+
sp r;
885
+
let other = namespace_list r in
886
+
sp r;
887
+
let shared = namespace_list r in
888
+
crlf r;
889
+
Namespace_response { personal; other; shared }
890
+
| "ENABLED" ->
891
+
let rec loop acc =
892
+
match peek_char r with
893
+
| Some ' ' ->
894
+
sp r;
895
+
let cap = atom r in
896
+
loop (cap :: acc)
897
+
| Some '\r' -> List.rev acc
898
+
| _ -> List.rev acc
899
+
in
900
+
let caps = loop [] in
901
+
crlf r;
902
+
Enabled caps
903
+
| "ID" ->
904
+
sp r;
905
+
let params =
906
+
if is_nil r then (
907
+
nil r;
908
+
None)
909
+
else
910
+
let c = R.any_char r in
911
+
if c <> '(' then None
912
+
else
913
+
let rec loop acc =
914
+
match peek_char r with
915
+
| Some ')' ->
916
+
ignore (R.any_char r);
917
+
Some (List.rev acc)
918
+
| Some ' ' ->
919
+
sp r;
920
+
loop acc
921
+
| Some '"' ->
922
+
let key = quoted_string r in
923
+
sp r;
924
+
let value =
925
+
if is_nil r then (
926
+
nil r;
927
+
"")
928
+
else quoted_string r
929
+
in
930
+
loop ((key, value) :: acc)
931
+
| _ -> Some (List.rev acc)
932
+
in
933
+
loop []
934
+
in
935
+
crlf r;
936
+
Id_response params
937
+
| "ESEARCH" ->
938
+
(* Simplified ESEARCH parsing *)
939
+
ignore (read_text r);
940
+
crlf r;
941
+
Esearch { tag = None; uid = false; results = [] }
942
+
| _ ->
943
+
(* Unknown untagged response, skip to end of line *)
944
+
ignore (read_text r);
945
+
crlf r;
946
+
Ok { tag = None; code = None; text = "" }))
947
+
| _ ->
948
+
(* Tagged response *)
949
+
let tag = atom r in
950
+
sp r;
951
+
let status = atom r in
952
+
let upper = String.uppercase_ascii status in
953
+
sp r;
954
+
let code =
955
+
match peek_char r with Some '[' -> Some (response_code r) | _ -> None
956
+
in
957
+
(match code with Some _ -> sp r | None -> ());
958
+
let text = read_text r in
959
+
crlf r;
960
+
(match upper with
961
+
| "OK" -> Ok { tag = Some tag; code; text }
962
+
| "NO" -> No { tag = Some tag; code; text }
963
+
| "BAD" -> Bad { tag = Some tag; code; text }
964
+
| _ -> Bad { tag = Some tag; code = None; text = "Unknown status" })
965
+
966
+
let responses_until_tagged r expected_tag =
967
+
let rec loop acc =
968
+
let resp = response r in
969
+
let acc = resp :: acc in
970
+
match resp with
971
+
| Ok { tag = Some t; _ } | No { tag = Some t; _ } | Bad { tag = Some t; _ }
972
+
when t = expected_tag ->
973
+
List.rev acc
974
+
| Bye _ ->
975
+
(* Server disconnecting, return what we have *)
976
+
List.rev acc
977
+
| _ -> loop acc
978
+
in
979
+
loop []
+118
lib/imapd/read.mli
+118
lib/imapd/read.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Response Parsing
7
+
8
+
This module parses IMAP server responses for client-side use.
9
+
Uses [Eio.Buf_read] for efficient buffered input.
10
+
11
+
{2 Wire Format}
12
+
13
+
IMAP responses are parsed according to
14
+
{{:https://datatracker.ietf.org/doc/html/rfc9051#section-9}RFC 9051 Section 9}.
15
+
Each response line is terminated with CRLF.
16
+
17
+
{2 Example}
18
+
19
+
{[
20
+
let reader = Eio.Buf_read.of_flow flow ~max_size:1_000_000 in
21
+
let greeting = Read.response reader in
22
+
match greeting with
23
+
| Ok { tag = None; code; text } ->
24
+
Printf.printf "Server greeting: %s\n" text
25
+
| Bye { text; _ } ->
26
+
Printf.eprintf "Server disconnecting: %s\n" text
27
+
| _ -> failwith "Unexpected greeting"
28
+
]}
29
+
30
+
{2 References}
31
+
{ul
32
+
{- {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} - IMAP4rev2}} *)
33
+
34
+
(** {1 Primitive Parsers}
35
+
36
+
Low-level parsers for IMAP data types. *)
37
+
38
+
val atom : Eio.Buf_read.t -> string
39
+
(** [atom r] reads an atom (unquoted token). *)
40
+
41
+
val quoted_string : Eio.Buf_read.t -> string
42
+
(** [quoted_string r] reads a quoted string with escape handling. *)
43
+
44
+
val literal : Eio.Buf_read.t -> string
45
+
(** [literal r] reads a literal [{n}CRLF...] and returns the data. *)
46
+
47
+
val astring : Eio.Buf_read.t -> string
48
+
(** [astring r] reads an atom or string. *)
49
+
50
+
val nstring : Eio.Buf_read.t -> string option
51
+
(** [nstring r] reads NIL or a string. *)
52
+
53
+
val number : Eio.Buf_read.t -> int
54
+
(** [number r] reads a decimal number. *)
55
+
56
+
val number32 : Eio.Buf_read.t -> int32
57
+
(** [number32 r] reads a 32-bit number (for UIDs). *)
58
+
59
+
val number64 : Eio.Buf_read.t -> int64
60
+
(** [number64 r] reads a 64-bit number. *)
61
+
62
+
val sp : Eio.Buf_read.t -> unit
63
+
(** [sp r] reads and discards a single space. *)
64
+
65
+
val crlf : Eio.Buf_read.t -> unit
66
+
(** [crlf r] reads and discards CRLF line terminator. *)
67
+
68
+
(** {1 Structured Parsers}
69
+
70
+
Parsers for IMAP structured data types. *)
71
+
72
+
val flag : Eio.Buf_read.t -> Protocol.flag
73
+
(** [flag r] reads a message flag. *)
74
+
75
+
val flag_list : Eio.Buf_read.t -> Protocol.flag list
76
+
(** [flag_list r] reads a parenthesized flag list. *)
77
+
78
+
val address : Eio.Buf_read.t -> Protocol.address
79
+
(** [address r] reads an envelope address. *)
80
+
81
+
val envelope : Eio.Buf_read.t -> Protocol.envelope
82
+
(** [envelope r] reads a message envelope. *)
83
+
84
+
val body_structure : Eio.Buf_read.t -> Protocol.body_structure
85
+
(** [body_structure r] reads a BODYSTRUCTURE response. *)
86
+
87
+
val response_code : Eio.Buf_read.t -> Protocol.response_code
88
+
(** [response_code r] reads a bracketed response code. *)
89
+
90
+
val sequence_set : Eio.Buf_read.t -> Protocol.sequence_set
91
+
(** [sequence_set r] reads a sequence set like [1,3:5,10:*]. *)
92
+
93
+
(** {1 Response Parsers}
94
+
95
+
High-level response parsing. *)
96
+
97
+
val response : Eio.Buf_read.t -> Protocol.response
98
+
(** [response r] reads a complete IMAP response (one or more lines).
99
+
100
+
This handles:
101
+
- Tagged responses (OK/NO/BAD)
102
+
- Untagged responses (untagged, including PREAUTH, BYE, capabilities, etc.)
103
+
- Continuation requests
104
+
105
+
Example:
106
+
{[
107
+
let resp = response reader in
108
+
match resp with
109
+
| Ok { tag = Some t; text; _ } -> Printf.printf "%s OK: %s\n" t text
110
+
| Exists n -> Printf.printf "Mailbox has %d messages\n" n
111
+
| Continuation _ -> Printf.printf "Server ready for more data\n"
112
+
| _ -> ()
113
+
]} *)
114
+
115
+
val responses_until_tagged : Eio.Buf_read.t -> string -> Protocol.response list
116
+
(** [responses_until_tagged r tag] reads responses until a tagged response
117
+
matching [tag] is received. Returns all responses including the final
118
+
tagged response. *)
+469
lib/imapd/write.ml
+469
lib/imapd/write.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Protocol
7
+
module W = Eio.Buf_write
8
+
9
+
let sp w = W.char w ' '
10
+
let crlf w = W.string w "\r\n"
11
+
12
+
(* Check if character is safe for atoms (not a special) *)
13
+
let is_atom_char = function
14
+
| '(' | ')' | '{' | ' ' | '\x00' .. '\x1f' | '\x7f' | '%' | '*' | '"' | '\\'
15
+
| ']' ->
16
+
false
17
+
| c -> c >= '\x21' && c <= '\x7e'
18
+
19
+
(* Check if string can be written as atom *)
20
+
let is_atom s = String.length s > 0 && String.for_all is_atom_char s
21
+
22
+
let atom w s = W.string w s
23
+
24
+
let quoted_string w s =
25
+
W.char w '"';
26
+
String.iter
27
+
(fun c ->
28
+
match c with
29
+
| '"' | '\\' ->
30
+
W.char w '\\';
31
+
W.char w c
32
+
| _ -> W.char w c)
33
+
s;
34
+
W.char w '"'
35
+
36
+
let literal w s =
37
+
W.char w '{';
38
+
W.string w (string_of_int (String.length s));
39
+
W.string w "}\r\n";
40
+
W.string w s
41
+
42
+
let literal_plus w s =
43
+
W.char w '{';
44
+
W.string w (string_of_int (String.length s));
45
+
W.string w "+}\r\n";
46
+
W.string w s
47
+
48
+
(* Check if string needs to be a literal (contains CR, LF, or NUL) *)
49
+
let needs_literal s =
50
+
String.exists (function '\r' | '\n' | '\x00' -> true | _ -> false) s
51
+
52
+
let astring w s =
53
+
if is_atom s then atom w s
54
+
else if needs_literal s then literal w s
55
+
else quoted_string w s
56
+
57
+
let nstring w = function
58
+
| None -> W.string w "NIL"
59
+
| Some s -> if needs_literal s then literal w s else quoted_string w s
60
+
let number w n = W.string w (string_of_int n)
61
+
let number32 w n = W.string w (Int32.to_string n)
62
+
let number64 w n = W.string w (Int64.to_string n)
63
+
64
+
let sequence_range w = function
65
+
| Single n -> number w n
66
+
| Range (a, b) ->
67
+
number w a;
68
+
W.char w ':';
69
+
number w b
70
+
| From n ->
71
+
number w n;
72
+
W.string w ":*"
73
+
| All -> W.char w '*'
74
+
75
+
let sequence_set w set =
76
+
List.iteri
77
+
(fun i r ->
78
+
if i > 0 then W.char w ',';
79
+
sequence_range w r)
80
+
set
81
+
82
+
let system_flag w = function
83
+
| Seen -> W.string w "\\Seen"
84
+
| Answered -> W.string w "\\Answered"
85
+
| Flagged -> W.string w "\\Flagged"
86
+
| Deleted -> W.string w "\\Deleted"
87
+
| Draft -> W.string w "\\Draft"
88
+
89
+
let flag w = function
90
+
| System f -> system_flag w f
91
+
| Keyword k ->
92
+
W.char w '$';
93
+
W.string w k
94
+
95
+
let flag_list w flags =
96
+
W.char w '(';
97
+
List.iteri
98
+
(fun i f ->
99
+
if i > 0 then sp w;
100
+
flag w f)
101
+
flags;
102
+
W.char w ')'
103
+
104
+
let rec search_key w = function
105
+
| Search_all -> W.string w "ALL"
106
+
| Search_answered -> W.string w "ANSWERED"
107
+
| Search_bcc s ->
108
+
W.string w "BCC ";
109
+
astring w s
110
+
| Search_before s ->
111
+
W.string w "BEFORE ";
112
+
atom w s
113
+
| Search_body s ->
114
+
W.string w "BODY ";
115
+
astring w s
116
+
| Search_cc s ->
117
+
W.string w "CC ";
118
+
astring w s
119
+
| Search_deleted -> W.string w "DELETED"
120
+
| Search_flagged -> W.string w "FLAGGED"
121
+
| Search_from s ->
122
+
W.string w "FROM ";
123
+
astring w s
124
+
| Search_keyword s ->
125
+
W.string w "KEYWORD ";
126
+
atom w s
127
+
| Search_new -> W.string w "NEW"
128
+
| Search_not k ->
129
+
W.string w "NOT ";
130
+
search_key w k
131
+
| Search_old -> W.string w "OLD"
132
+
| Search_on s ->
133
+
W.string w "ON ";
134
+
atom w s
135
+
| Search_or (k1, k2) ->
136
+
W.string w "OR ";
137
+
search_key w k1;
138
+
sp w;
139
+
search_key w k2
140
+
| Search_seen -> W.string w "SEEN"
141
+
| Search_since s ->
142
+
W.string w "SINCE ";
143
+
atom w s
144
+
| Search_subject s ->
145
+
W.string w "SUBJECT ";
146
+
astring w s
147
+
| Search_text s ->
148
+
W.string w "TEXT ";
149
+
astring w s
150
+
| Search_to s ->
151
+
W.string w "TO ";
152
+
astring w s
153
+
| Search_unanswered -> W.string w "UNANSWERED"
154
+
| Search_undeleted -> W.string w "UNDELETED"
155
+
| Search_unflagged -> W.string w "UNFLAGGED"
156
+
| Search_unkeyword s ->
157
+
W.string w "UNKEYWORD ";
158
+
atom w s
159
+
| Search_unseen -> W.string w "UNSEEN"
160
+
| Search_draft -> W.string w "DRAFT"
161
+
| Search_undraft -> W.string w "UNDRAFT"
162
+
| Search_header (field, value) ->
163
+
W.string w "HEADER ";
164
+
astring w field;
165
+
sp w;
166
+
astring w value
167
+
| Search_larger n ->
168
+
W.string w "LARGER ";
169
+
number64 w n
170
+
| Search_smaller n ->
171
+
W.string w "SMALLER ";
172
+
number64 w n
173
+
| Search_uid set ->
174
+
W.string w "UID ";
175
+
sequence_set w set
176
+
| Search_sequence_set set -> sequence_set w set
177
+
| Search_and keys ->
178
+
W.char w '(';
179
+
List.iteri
180
+
(fun i k ->
181
+
if i > 0 then sp w;
182
+
search_key w k)
183
+
keys;
184
+
W.char w ')'
185
+
| Search_sentbefore s ->
186
+
W.string w "SENTBEFORE ";
187
+
atom w s
188
+
| Search_senton s ->
189
+
W.string w "SENTON ";
190
+
atom w s
191
+
| Search_sentsince s ->
192
+
W.string w "SENTSINCE ";
193
+
atom w s
194
+
195
+
let fetch_item w = function
196
+
| Fetch_envelope -> W.string w "ENVELOPE"
197
+
| Fetch_flags -> W.string w "FLAGS"
198
+
| Fetch_internaldate -> W.string w "INTERNALDATE"
199
+
| Fetch_rfc822 -> W.string w "RFC822"
200
+
| Fetch_rfc822_size -> W.string w "RFC822.SIZE"
201
+
| Fetch_rfc822_header -> W.string w "RFC822.HEADER"
202
+
| Fetch_rfc822_text -> W.string w "RFC822.TEXT"
203
+
| Fetch_uid -> W.string w "UID"
204
+
| Fetch_body -> W.string w "BODY"
205
+
| Fetch_bodystructure -> W.string w "BODYSTRUCTURE"
206
+
| Fetch_body_section (section, partial) ->
207
+
W.string w "BODY[";
208
+
W.string w section;
209
+
W.char w ']';
210
+
(match partial with
211
+
| Some (offset, len) ->
212
+
W.char w '<';
213
+
number w offset;
214
+
W.char w '.';
215
+
number w len;
216
+
W.char w '>'
217
+
| None -> ())
218
+
| Fetch_body_peek (section, partial) ->
219
+
W.string w "BODY.PEEK[";
220
+
W.string w section;
221
+
W.char w ']';
222
+
(match partial with
223
+
| Some (offset, len) ->
224
+
W.char w '<';
225
+
number w offset;
226
+
W.char w '.';
227
+
number w len;
228
+
W.char w '>'
229
+
| None -> ())
230
+
| Fetch_binary (section, partial) ->
231
+
W.string w "BINARY[";
232
+
W.string w section;
233
+
W.char w ']';
234
+
(match partial with
235
+
| Some (offset, len) ->
236
+
W.char w '<';
237
+
number w offset;
238
+
W.char w '.';
239
+
number w len;
240
+
W.char w '>'
241
+
| None -> ())
242
+
| Fetch_binary_peek (section, partial) ->
243
+
W.string w "BINARY.PEEK[";
244
+
W.string w section;
245
+
W.char w ']';
246
+
(match partial with
247
+
| Some (offset, len) ->
248
+
W.char w '<';
249
+
number w offset;
250
+
W.char w '.';
251
+
number w len;
252
+
W.char w '>'
253
+
| None -> ())
254
+
| Fetch_binary_size section ->
255
+
W.string w "BINARY.SIZE[";
256
+
W.string w section;
257
+
W.char w ']'
258
+
259
+
let fetch_items w = function
260
+
| [ item ] -> fetch_item w item
261
+
| items ->
262
+
W.char w '(';
263
+
List.iteri
264
+
(fun i item ->
265
+
if i > 0 then sp w;
266
+
fetch_item w item)
267
+
items;
268
+
W.char w ')'
269
+
270
+
let status_item w = function
271
+
| Status_messages -> W.string w "MESSAGES"
272
+
| Status_uidnext -> W.string w "UIDNEXT"
273
+
| Status_uidvalidity -> W.string w "UIDVALIDITY"
274
+
| Status_unseen -> W.string w "UNSEEN"
275
+
| Status_deleted -> W.string w "DELETED"
276
+
| Status_size -> W.string w "SIZE"
277
+
278
+
let status_items w items =
279
+
W.char w '(';
280
+
List.iteri
281
+
(fun i item ->
282
+
if i > 0 then sp w;
283
+
status_item w item)
284
+
items;
285
+
W.char w ')'
286
+
287
+
let store_action w = function
288
+
| Store_set -> W.string w "FLAGS"
289
+
| Store_add -> W.string w "+FLAGS"
290
+
| Store_remove -> W.string w "-FLAGS"
291
+
292
+
let id_params w = function
293
+
| None -> W.string w "NIL"
294
+
| Some pairs ->
295
+
W.char w '(';
296
+
List.iteri
297
+
(fun i (k, v) ->
298
+
if i > 0 then sp w;
299
+
quoted_string w k;
300
+
sp w;
301
+
quoted_string w v)
302
+
pairs;
303
+
W.char w ')'
304
+
305
+
let command_body w = function
306
+
| Capability -> W.string w "CAPABILITY"
307
+
| Noop -> W.string w "NOOP"
308
+
| Logout -> W.string w "LOGOUT"
309
+
| Starttls -> W.string w "STARTTLS"
310
+
| Login { username; password } ->
311
+
W.string w "LOGIN ";
312
+
astring w username;
313
+
sp w;
314
+
astring w password
315
+
| Authenticate { mechanism; initial_response } -> (
316
+
W.string w "AUTHENTICATE ";
317
+
atom w mechanism;
318
+
match initial_response with
319
+
| Some r ->
320
+
sp w;
321
+
W.string w r
322
+
| None -> ())
323
+
| Enable caps ->
324
+
W.string w "ENABLE";
325
+
List.iter
326
+
(fun c ->
327
+
sp w;
328
+
atom w c)
329
+
caps
330
+
| Select mailbox ->
331
+
W.string w "SELECT ";
332
+
astring w mailbox
333
+
| Examine mailbox ->
334
+
W.string w "EXAMINE ";
335
+
astring w mailbox
336
+
| Create mailbox ->
337
+
W.string w "CREATE ";
338
+
astring w mailbox
339
+
| Delete mailbox ->
340
+
W.string w "DELETE ";
341
+
astring w mailbox
342
+
| Rename { old_name; new_name } ->
343
+
W.string w "RENAME ";
344
+
astring w old_name;
345
+
sp w;
346
+
astring w new_name
347
+
| Subscribe mailbox ->
348
+
W.string w "SUBSCRIBE ";
349
+
astring w mailbox
350
+
| Unsubscribe mailbox ->
351
+
W.string w "UNSUBSCRIBE ";
352
+
astring w mailbox
353
+
| List { reference; pattern } ->
354
+
W.string w "LIST ";
355
+
astring w reference;
356
+
sp w;
357
+
astring w pattern
358
+
| Namespace -> W.string w "NAMESPACE"
359
+
| Status { mailbox; items } ->
360
+
W.string w "STATUS ";
361
+
astring w mailbox;
362
+
sp w;
363
+
status_items w items
364
+
| Append { mailbox; flags; date; message } ->
365
+
W.string w "APPEND ";
366
+
astring w mailbox;
367
+
(match flags with
368
+
| [] -> ()
369
+
| flags ->
370
+
sp w;
371
+
flag_list w flags);
372
+
(match date with
373
+
| Some d ->
374
+
sp w;
375
+
quoted_string w d
376
+
| None -> ());
377
+
sp w;
378
+
literal w message
379
+
| Idle -> W.string w "IDLE"
380
+
| Close -> W.string w "CLOSE"
381
+
| Unselect -> W.string w "UNSELECT"
382
+
| Expunge -> W.string w "EXPUNGE"
383
+
| Search { charset; criteria } -> (
384
+
W.string w "SEARCH";
385
+
(match charset with
386
+
| Some cs ->
387
+
W.string w " CHARSET ";
388
+
astring w cs
389
+
| None -> ());
390
+
sp w;
391
+
search_key w criteria)
392
+
| Fetch { sequence; items } ->
393
+
W.string w "FETCH ";
394
+
sequence_set w sequence;
395
+
sp w;
396
+
fetch_items w items
397
+
| Store { sequence; silent; action; flags } ->
398
+
W.string w "STORE ";
399
+
sequence_set w sequence;
400
+
sp w;
401
+
store_action w action;
402
+
if silent then W.string w ".SILENT";
403
+
sp w;
404
+
flag_list w flags
405
+
| Copy { sequence; mailbox } ->
406
+
W.string w "COPY ";
407
+
sequence_set w sequence;
408
+
sp w;
409
+
astring w mailbox
410
+
| Move { sequence; mailbox } ->
411
+
W.string w "MOVE ";
412
+
sequence_set w sequence;
413
+
sp w;
414
+
astring w mailbox
415
+
| Uid cmd -> (
416
+
W.string w "UID ";
417
+
match cmd with
418
+
| Uid_fetch { sequence; items } ->
419
+
W.string w "FETCH ";
420
+
sequence_set w sequence;
421
+
sp w;
422
+
fetch_items w items
423
+
| Uid_store { sequence; silent; action; flags } ->
424
+
W.string w "STORE ";
425
+
sequence_set w sequence;
426
+
sp w;
427
+
store_action w action;
428
+
if silent then W.string w ".SILENT";
429
+
sp w;
430
+
flag_list w flags
431
+
| Uid_copy { sequence; mailbox } ->
432
+
W.string w "COPY ";
433
+
sequence_set w sequence;
434
+
sp w;
435
+
astring w mailbox
436
+
| Uid_move { sequence; mailbox } ->
437
+
W.string w "MOVE ";
438
+
sequence_set w sequence;
439
+
sp w;
440
+
astring w mailbox
441
+
| Uid_search { charset; criteria } ->
442
+
W.string w "SEARCH";
443
+
(match charset with
444
+
| Some cs ->
445
+
W.string w " CHARSET ";
446
+
astring w cs
447
+
| None -> ());
448
+
sp w;
449
+
search_key w criteria
450
+
| Uid_expunge set ->
451
+
W.string w "EXPUNGE ";
452
+
sequence_set w set)
453
+
| Id params ->
454
+
W.string w "ID ";
455
+
id_params w params
456
+
457
+
let command w ~tag cmd =
458
+
atom w tag;
459
+
sp w;
460
+
command_body w cmd;
461
+
crlf w
462
+
463
+
let idle_done w =
464
+
W.string w "DONE";
465
+
crlf w
466
+
467
+
let authenticate_response w data =
468
+
W.string w data;
469
+
crlf w
+122
lib/imapd/write.mli
+122
lib/imapd/write.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** IMAP Command Serialization
7
+
8
+
This module serializes IMAP commands to the wire format for client-side use.
9
+
Uses [Eio.Buf_write] for efficient buffered output.
10
+
11
+
{2 Wire Format}
12
+
13
+
IMAP commands are serialized according to
14
+
{{:https://datatracker.ietf.org/doc/html/rfc9051#section-9}RFC 9051 Section 9}.
15
+
Each command is tagged and terminated with CRLF.
16
+
17
+
{2 Example}
18
+
19
+
{[
20
+
Eio.Buf_write.with_flow flow @@ fun w ->
21
+
Write.command w ~tag:"A001" Protocol.Capability;
22
+
Write.command w ~tag:"A002"
23
+
(Protocol.Login { username = "user"; password = "pass" })
24
+
]}
25
+
26
+
{2 References}
27
+
{ul
28
+
{- {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} - IMAP4rev2}
29
+
{- {{:https://datatracker.ietf.org/doc/html/rfc7888}RFC 7888} - LITERAL+}} *)
30
+
31
+
(** {1 Primitive Writers}
32
+
33
+
Low-level writers for IMAP data types. *)
34
+
35
+
val atom : Eio.Buf_write.t -> string -> unit
36
+
(** [atom w s] writes an atom (unquoted string).
37
+
Atoms must contain only printable US-ASCII characters excluding
38
+
specials like [(], [)], [open brace], [%], [*], [double-quote], [backslash]. *)
39
+
40
+
val quoted_string : Eio.Buf_write.t -> string -> unit
41
+
(** [quoted_string w s] writes a quoted string with proper escaping.
42
+
Backslash and double-quote are escaped with backslash. *)
43
+
44
+
val literal : Eio.Buf_write.t -> string -> unit
45
+
(** [literal w s] writes a synchronizing literal [{n}CRLF...].
46
+
Note: The server must send a continuation before the data. *)
47
+
48
+
val literal_plus : Eio.Buf_write.t -> string -> unit
49
+
(** [literal_plus w s] writes a non-synchronizing literal [{n+}CRLF...].
50
+
Requires LITERAL+ capability. Does not wait for server continuation. *)
51
+
52
+
val astring : Eio.Buf_write.t -> string -> unit
53
+
(** [astring w s] writes an astring (atom or string).
54
+
Chooses atom format if safe, otherwise quoted string. *)
55
+
56
+
val nstring : Eio.Buf_write.t -> string option -> unit
57
+
(** [nstring w s] writes NIL or a string. *)
58
+
59
+
val number : Eio.Buf_write.t -> int -> unit
60
+
(** [number w n] writes a decimal number. *)
61
+
62
+
val number32 : Eio.Buf_write.t -> int32 -> unit
63
+
(** [number32 w n] writes a 32-bit decimal number (for UIDs). *)
64
+
65
+
val number64 : Eio.Buf_write.t -> int64 -> unit
66
+
(** [number64 w n] writes a 64-bit decimal number. *)
67
+
68
+
val sp : Eio.Buf_write.t -> unit
69
+
(** [sp w] writes a single space. *)
70
+
71
+
val crlf : Eio.Buf_write.t -> unit
72
+
(** [crlf w] writes CRLF line terminator. *)
73
+
74
+
(** {1 Structured Writers}
75
+
76
+
Writers for IMAP structured data types. *)
77
+
78
+
val sequence_set : Eio.Buf_write.t -> Protocol.sequence_set -> unit
79
+
(** [sequence_set w set] writes a sequence set like [1,3:5,10:*]. *)
80
+
81
+
val flag : Eio.Buf_write.t -> Protocol.flag -> unit
82
+
(** [flag w f] writes a message flag like [\Seen] or [$Forwarded]. *)
83
+
84
+
val flag_list : Eio.Buf_write.t -> Protocol.flag list -> unit
85
+
(** [flag_list w flags] writes a parenthesized flag list. *)
86
+
87
+
val search_key : Eio.Buf_write.t -> Protocol.search_key -> unit
88
+
(** [search_key w key] writes a search criterion. *)
89
+
90
+
val fetch_item : Eio.Buf_write.t -> Protocol.fetch_item -> unit
91
+
(** [fetch_item w item] writes a fetch data item. *)
92
+
93
+
val fetch_items : Eio.Buf_write.t -> Protocol.fetch_item list -> unit
94
+
(** [fetch_items w items] writes a parenthesized list of fetch items,
95
+
or a single item without parentheses. *)
96
+
97
+
val status_item : Eio.Buf_write.t -> Protocol.status_item -> unit
98
+
(** [status_item w item] writes a STATUS data item. *)
99
+
100
+
val status_items : Eio.Buf_write.t -> Protocol.status_item list -> unit
101
+
(** [status_items w items] writes a parenthesized list of STATUS items. *)
102
+
103
+
(** {1 Command Writers}
104
+
105
+
High-level command serialization. *)
106
+
107
+
val command : Eio.Buf_write.t -> tag:string -> Protocol.command -> unit
108
+
(** [command w ~tag cmd] writes a complete tagged command with CRLF.
109
+
110
+
Example:
111
+
{[
112
+
command w ~tag:"A001" Protocol.Capability
113
+
(* writes: "A001 CAPABILITY\r\n" *)
114
+
]} *)
115
+
116
+
val idle_done : Eio.Buf_write.t -> unit
117
+
(** [idle_done w] writes "DONE" to exit IDLE mode.
118
+
Must be sent after receiving IDLE continuation. *)
119
+
120
+
val authenticate_response : Eio.Buf_write.t -> string -> unit
121
+
(** [authenticate_response w data] writes a base64-encoded SASL response
122
+
for AUTHENTICATE continuation. *)
+17
-5
test/dune
+17
-5
test/dune
···
1
1
(test
2
2
(name test_types)
3
-
(libraries imap_types alcotest))
3
+
(libraries imapd alcotest))
4
4
5
5
(test
6
6
(name test_parser)
7
-
(libraries imap_parser alcotest))
7
+
(libraries imapd alcotest))
8
8
9
9
(test
10
10
(name test_auth)
11
-
(libraries imap_auth alcotest))
11
+
(libraries imapd alcotest))
12
12
13
13
(test
14
14
(name test_storage)
15
-
(libraries imap_storage alcotest eio_main))
15
+
(libraries imapd alcotest eio_main))
16
16
17
17
(test
18
18
(name test_server)
19
-
(libraries imap_types imap_parser alcotest))
19
+
(libraries imapd alcotest))
20
+
21
+
(test
22
+
(name test_write)
23
+
(libraries imap alcotest eio eio_main))
24
+
25
+
(test
26
+
(name test_read)
27
+
(libraries imap alcotest eio eio_main))
28
+
29
+
(test
30
+
(name test_client)
31
+
(libraries imap alcotest eio eio_main))
+1
-1
test/test_auth.ml
+1
-1
test/test_auth.ml
+169
test/test_client.ml
+169
test/test_client.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Imap.Client module *)
7
+
8
+
let test_error_types () =
9
+
(* Test error construction and properties *)
10
+
let conn_err = Imap.Error.Connection_error { reason = "test" } in
11
+
Alcotest.(check bool) "conn error retryable" true
12
+
(Imap.Error.is_retryable conn_err);
13
+
14
+
let auth_err =
15
+
Imap.Error.Protocol_error
16
+
{ code = Some Imap.Code.Authenticationfailed; text = "bad password" }
17
+
in
18
+
Alcotest.(check bool) "auth error is_auth" true
19
+
(Imap.Error.is_auth_error auth_err);
20
+
21
+
let state_err =
22
+
Imap.Error.State_error
23
+
{ expected = "Selected"; actual = "Authenticated" }
24
+
in
25
+
Alcotest.(check bool) "state error is_state" true
26
+
(Imap.Error.is_state_error state_err);
27
+
28
+
let timeout_err = Imap.Error.Timeout { operation = "fetch" } in
29
+
Alcotest.(check bool) "timeout retryable" true
30
+
(Imap.Error.is_retryable timeout_err);
31
+
32
+
(* Test pp and to_string *)
33
+
let s = Imap.Error.to_string conn_err in
34
+
Alcotest.(check bool) "to_string works" true (String.length s > 0)
35
+
36
+
let test_error_extraction () =
37
+
let err = Imap.Error.Connection_error { reason = "network down" } in
38
+
let exn = Imap.Error.err err in
39
+
let extracted = Imap.Error.of_eio_exn exn in
40
+
match extracted with
41
+
| Some (Connection_error { reason = "network down" }) -> ()
42
+
| _ -> Alcotest.fail "expected to extract connection error"
43
+
44
+
let test_mailbox_info () =
45
+
(* Test mailbox_info type construction *)
46
+
let info : Imap.Client.mailbox_info =
47
+
{
48
+
name = "INBOX";
49
+
exists = 42;
50
+
recent = 3;
51
+
uidvalidity = 1234567890l;
52
+
uidnext = 43l;
53
+
flags = [ Imap.Flag.System Imap.Flag.Seen; Imap.Flag.System Imap.Flag.Answered; Imap.Flag.System Imap.Flag.Flagged ];
54
+
permanent_flags = [ Imap.Flag.System Imap.Flag.Seen; Imap.Flag.System Imap.Flag.Answered ];
55
+
readonly = false;
56
+
}
57
+
in
58
+
Alcotest.(check int) "exists" 42 info.exists;
59
+
Alcotest.(check int) "recent" 3 info.recent;
60
+
Alcotest.(check bool) "not readonly" false info.readonly
61
+
62
+
let test_message_info () =
63
+
(* Test message_info type construction *)
64
+
let info : Imap.Client.message_info =
65
+
{
66
+
seq = 1;
67
+
uid = Some 12345l;
68
+
flags = Some [ Imap.Flag.System Imap.Flag.Seen ];
69
+
envelope =
70
+
Some
71
+
{
72
+
date = Some "Mon, 1 Jan 2024 12:00:00 +0000";
73
+
subject = Some "Test Subject";
74
+
from = [ { name = Some "Alice"; adl = None; mailbox = Some "alice"; host = Some "example.com" } ];
75
+
sender = [];
76
+
reply_to = [];
77
+
to_ = [];
78
+
cc = [];
79
+
bcc = [];
80
+
in_reply_to = None;
81
+
message_id = Some "<test@example.com>";
82
+
};
83
+
body_structure = None;
84
+
internaldate = Some "01-Jan-2024 12:00:00 +0000";
85
+
size = Some 1024L;
86
+
body_section = None;
87
+
}
88
+
in
89
+
Alcotest.(check int) "seq" 1 info.seq;
90
+
Alcotest.(check (option int32)) "uid" (Some 12345l) info.uid
91
+
92
+
let test_list_entry () =
93
+
let entry : Imap.Client.list_entry =
94
+
{ flags = [ Imap.List_attr.Hasnochildren ]; delimiter = Some '/'; name = "INBOX" }
95
+
in
96
+
Alcotest.(check string) "name" "INBOX" entry.name;
97
+
Alcotest.(check (option char)) "delimiter" (Some '/') entry.delimiter
98
+
99
+
let test_status_info () =
100
+
let info : Imap.Client.status_info =
101
+
{
102
+
mailbox = "INBOX";
103
+
messages = Some 42L;
104
+
uidnext = Some 43L;
105
+
uidvalidity = Some 1234567890L;
106
+
unseen = Some 5L;
107
+
}
108
+
in
109
+
Alcotest.(check string) "mailbox" "INBOX" info.mailbox;
110
+
Alcotest.(check (option int64)) "messages" (Some 42L) info.messages
111
+
112
+
let test_idle_event () =
113
+
let events : Imap.Client.idle_event list =
114
+
[
115
+
Idle_exists 43;
116
+
Idle_expunge 10;
117
+
Idle_fetch { seq = 5; flags = [ Imap.Flag.System Imap.Flag.Seen ] };
118
+
]
119
+
in
120
+
Alcotest.(check int) "event count" 3 (List.length events)
121
+
122
+
let test_connection_state () =
123
+
let states : Imap.Client.connection_state list =
124
+
[
125
+
Not_authenticated;
126
+
Authenticated { username = "user" };
127
+
Selected { username = "user"; mailbox = "INBOX"; readonly = false };
128
+
Logout;
129
+
]
130
+
in
131
+
Alcotest.(check int) "state count" 4 (List.length states)
132
+
133
+
let test_pool_config () =
134
+
let config = Imap.Pool.default_config in
135
+
Alcotest.(check int) "min connections" 1 config.min_connections;
136
+
Alcotest.(check int) "max connections" 10 config.max_connections
137
+
138
+
let test_pool_stats () =
139
+
let stats : Imap.Pool.stats =
140
+
{ total = 5; active = 2; idle = 3; created = 10; reused = 50; failed = 1 }
141
+
in
142
+
Alcotest.(check int) "total" 5 stats.total;
143
+
Alcotest.(check int) "active" 2 stats.active;
144
+
Alcotest.(check int) "idle" 3 stats.idle
145
+
146
+
let () =
147
+
let open Alcotest in
148
+
run "imap_client"
149
+
[
150
+
( "errors",
151
+
[
152
+
test_case "error types" `Quick test_error_types;
153
+
test_case "error extraction" `Quick test_error_extraction;
154
+
] );
155
+
( "types",
156
+
[
157
+
test_case "mailbox_info" `Quick test_mailbox_info;
158
+
test_case "message_info" `Quick test_message_info;
159
+
test_case "list_entry" `Quick test_list_entry;
160
+
test_case "status_info" `Quick test_status_info;
161
+
test_case "idle_event" `Quick test_idle_event;
162
+
test_case "connection_state" `Quick test_connection_state;
163
+
] );
164
+
( "pool",
165
+
[
166
+
test_case "config" `Quick test_pool_config;
167
+
test_case "stats" `Quick test_pool_stats;
168
+
] );
169
+
]
+2
-2
test/test_parser.ml
+2
-2
test/test_parser.ml
···
5
5
6
6
(** Tests for imap_parser module *)
7
7
8
-
open Imap_parser
8
+
open Imapd.Parser
9
9
10
10
let test_parse_capability () =
11
11
match parse_command "A001 CAPABILITY\r\n" with
···
85
85
| Ok { tag; command = Store { sequence = _; silent; action; flags } } ->
86
86
Alcotest.(check string) "tag" "A010" tag;
87
87
Alcotest.(check bool) "silent" false silent;
88
-
Alcotest.(check bool) "action is add" true (action = Imap_types.Store_add);
88
+
Alcotest.(check bool) "action is add" true (action = Imapd.Protocol.Store_add);
89
89
Alcotest.(check int) "flags length" 1 (List.length flags)
90
90
| Ok _ -> Alcotest.fail "Wrong command parsed"
91
91
| Error msg -> Alcotest.fail msg
+342
test/test_read.ml
+342
test/test_read.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Imap.Read module *)
7
+
8
+
(* Helper to create a reader from a string *)
9
+
let reader_of_string s =
10
+
let flow = Eio.Flow.string_source s in
11
+
Eio.Buf_read.of_flow ~max_size:(1024 * 1024) flow
12
+
13
+
let with_reader s f = Eio_main.run @@ fun _ -> f (reader_of_string s)
14
+
15
+
let test_atom () =
16
+
let result = with_reader "INBOX " (fun r -> Imap.Read.atom r) in
17
+
Alcotest.(check string) "atom" "INBOX" result
18
+
19
+
let test_number () =
20
+
let result = with_reader "12345 " (fun r -> Imap.Read.number r) in
21
+
Alcotest.(check int) "number" 12345 result
22
+
23
+
let test_quoted_string () =
24
+
let result = with_reader "\"hello world\" " (fun r -> Imap.Read.quoted_string r) in
25
+
Alcotest.(check string) "quoted" "hello world" result
26
+
27
+
let test_quoted_string_escape () =
28
+
let result = with_reader "\"say \\\"hi\\\"\" " (fun r -> Imap.Read.quoted_string r) in
29
+
Alcotest.(check string) "escape" "say \"hi\"" result
30
+
31
+
let test_literal () =
32
+
let result = with_reader "{5}\r\nhello " (fun r -> Imap.Read.literal r) in
33
+
Alcotest.(check string) "literal" "hello" result
34
+
35
+
let test_nstring_string () =
36
+
let result = with_reader "\"text\" " (fun r -> Imap.Read.nstring r) in
37
+
Alcotest.(check (option string)) "nstring string" (Some "text") result
38
+
39
+
let test_nstring_nil () =
40
+
let result = with_reader "NIL " (fun r -> Imap.Read.nstring r) in
41
+
Alcotest.(check (option string)) "nstring nil" None result
42
+
43
+
let flag_testable =
44
+
Alcotest.testable
45
+
(fun ppf f -> Fmt.pf ppf "%a" Imap.Flag.pp f)
46
+
( = )
47
+
48
+
let test_flag_seen () =
49
+
let result = with_reader "\\Seen " (fun r -> Imap.Read.flag r) in
50
+
Alcotest.(check flag_testable) "seen" (Imap.Flag.System Imap.Flag.Seen) result
51
+
52
+
let test_flag_answered () =
53
+
let result = with_reader "\\Answered " (fun r -> Imap.Read.flag r) in
54
+
Alcotest.(check flag_testable) "answered" (Imap.Flag.System Imap.Flag.Answered) result
55
+
56
+
let test_flag_keyword () =
57
+
let result = with_reader "$Forwarded " (fun r -> Imap.Read.flag r) in
58
+
Alcotest.(check flag_testable) "keyword" (Imap.Flag.Keyword "$Forwarded") result
59
+
60
+
let test_flag_list () =
61
+
let result = with_reader "(\\Seen \\Answered) " (fun r -> Imap.Read.flag_list r) in
62
+
Alcotest.(check int) "flag count" 2 (List.length result)
63
+
64
+
let test_flag_list_empty () =
65
+
let result = with_reader "() " (fun r -> Imap.Read.flag_list r) in
66
+
Alcotest.(check int) "empty flag list" 0 (List.length result)
67
+
68
+
let is_ok = function Imap.Response.Ok _ -> true | _ -> false
69
+
let is_no = function Imap.Response.No _ -> true | _ -> false
70
+
let is_bad = function Imap.Response.Bad _ -> true | _ -> false
71
+
let is_capability = function Imap.Response.Capability _ -> true | _ -> false
72
+
let is_exists = function Imap.Response.Exists _ -> true | _ -> false
73
+
let is_expunge = function Imap.Response.Expunge _ -> true | _ -> false
74
+
let is_flags = function Imap.Response.Flags _ -> true | _ -> false
75
+
let is_list = function Imap.Response.List _ -> true | _ -> false
76
+
let is_continuation = function Imap.Response.Continuation _ -> true | _ -> false
77
+
let is_preauth = function Imap.Response.Preauth _ -> true | _ -> false
78
+
let is_bye = function Imap.Response.Bye _ -> true | _ -> false
79
+
let is_status = function Imap.Response.Status _ -> true | _ -> false
80
+
let is_namespace = function Imap.Response.Namespace _ -> true | _ -> false
81
+
let is_enabled = function Imap.Response.Enabled _ -> true | _ -> false
82
+
let is_id = function Imap.Response.Id _ -> true | _ -> false
83
+
let is_fetch = function Imap.Response.Fetch _ -> true | _ -> false
84
+
85
+
let test_response_ok_tagged () =
86
+
let result = with_reader "A001 OK Success\r\n" (fun r -> Imap.Read.response r) in
87
+
Alcotest.(check bool) "is OK" true (is_ok result);
88
+
match result with
89
+
| Imap.Response.Ok { tag; text; _ } ->
90
+
Alcotest.(check (option string)) "tag" (Some "A001") tag;
91
+
Alcotest.(check string) "text" "Success" text
92
+
| _ -> Alcotest.fail "expected OK"
93
+
94
+
let test_response_ok_with_code () =
95
+
let result =
96
+
with_reader "A001 OK [CAPABILITY IMAP4rev2] Ready\r\n" (fun r -> Imap.Read.response r)
97
+
in
98
+
Alcotest.(check bool) "is OK" true (is_ok result);
99
+
match result with
100
+
| Imap.Response.Ok { code = Some (Imap.Code.Capability caps); _ } ->
101
+
Alcotest.(check int) "cap count" 1 (List.length caps)
102
+
| _ -> Alcotest.fail "expected OK with CAPABILITY"
103
+
104
+
let test_response_no () =
105
+
let result = with_reader "A002 NO Access denied\r\n" (fun r -> Imap.Read.response r) in
106
+
Alcotest.(check bool) "is NO" true (is_no result)
107
+
108
+
let test_response_bad () =
109
+
let result = with_reader "A003 BAD Syntax error\r\n" (fun r -> Imap.Read.response r) in
110
+
Alcotest.(check bool) "is BAD" true (is_bad result)
111
+
112
+
let test_response_capability () =
113
+
let result =
114
+
with_reader "* CAPABILITY IMAP4rev2 IDLE\r\n" (fun r -> Imap.Read.response r)
115
+
in
116
+
Alcotest.(check bool) "is CAPABILITY" true (is_capability result);
117
+
match result with
118
+
| Imap.Response.Capability caps ->
119
+
Alcotest.(check int) "cap count" 2 (List.length caps)
120
+
| _ -> Alcotest.fail "expected CAPABILITY"
121
+
122
+
let test_response_exists () =
123
+
let result = with_reader "* 42 EXISTS\r\n" (fun r -> Imap.Read.response r) in
124
+
Alcotest.(check bool) "is EXISTS" true (is_exists result);
125
+
match result with
126
+
| Imap.Response.Exists n -> Alcotest.(check int) "count" 42 n
127
+
| _ -> Alcotest.fail "expected EXISTS"
128
+
129
+
let test_response_expunge () =
130
+
let result = with_reader "* 10 EXPUNGE\r\n" (fun r -> Imap.Read.response r) in
131
+
Alcotest.(check bool) "is EXPUNGE" true (is_expunge result);
132
+
match result with
133
+
| Imap.Response.Expunge n -> Alcotest.(check int) "seq" 10 n
134
+
| _ -> Alcotest.fail "expected EXPUNGE"
135
+
136
+
let test_response_flags () =
137
+
let result =
138
+
with_reader "* FLAGS (\\Seen \\Answered \\Flagged)\r\n" (fun r -> Imap.Read.response r)
139
+
in
140
+
Alcotest.(check bool) "is FLAGS" true (is_flags result);
141
+
match result with
142
+
| Imap.Response.Flags flags -> Alcotest.(check int) "flag count" 3 (List.length flags)
143
+
| _ -> Alcotest.fail "expected FLAGS"
144
+
145
+
let test_response_list () =
146
+
let result =
147
+
with_reader "* LIST (\\HasNoChildren) \"/\" \"INBOX\"\r\n" (fun r -> Imap.Read.response r)
148
+
in
149
+
Alcotest.(check bool) "is LIST" true (is_list result);
150
+
match result with
151
+
| Imap.Response.List { name; delimiter; _ } ->
152
+
Alcotest.(check string) "name" "INBOX" name;
153
+
Alcotest.(check (option char)) "delimiter" (Some '/') delimiter
154
+
| _ -> Alcotest.fail "expected LIST"
155
+
156
+
let test_response_list_no_delimiter () =
157
+
let result =
158
+
with_reader "* LIST (\\Noselect) NIL \"\"\r\n" (fun r -> Imap.Read.response r)
159
+
in
160
+
Alcotest.(check bool) "is LIST" true (is_list result);
161
+
match result with
162
+
| Imap.Response.List { delimiter; _ } ->
163
+
Alcotest.(check (option char)) "no delimiter" None delimiter
164
+
| _ -> Alcotest.fail "expected LIST"
165
+
166
+
let test_response_continuation () =
167
+
let result = with_reader "+ \r\n" (fun r -> Imap.Read.response r) in
168
+
Alcotest.(check bool) "is continuation" true (is_continuation result)
169
+
170
+
let test_response_continuation_text () =
171
+
let result = with_reader "+ Ready for data\r\n" (fun r -> Imap.Read.response r) in
172
+
Alcotest.(check bool) "is continuation" true (is_continuation result);
173
+
match result with
174
+
| Imap.Response.Continuation (Some text) -> Alcotest.(check string) "text" "Ready for data" text
175
+
| _ -> Alcotest.fail "expected continuation with text"
176
+
177
+
let test_response_untagged_ok () =
178
+
let result = with_reader "* OK Server ready\r\n" (fun r -> Imap.Read.response r) in
179
+
Alcotest.(check bool) "is OK" true (is_ok result);
180
+
match result with
181
+
| Imap.Response.Ok { tag = None; _ } -> ()
182
+
| _ -> Alcotest.fail "expected untagged OK"
183
+
184
+
let test_response_preauth () =
185
+
let result = with_reader "* PREAUTH Already authenticated\r\n" (fun r -> Imap.Read.response r) in
186
+
Alcotest.(check bool) "is PREAUTH" true (is_preauth result)
187
+
188
+
let test_response_bye () =
189
+
let result = with_reader "* BYE Server shutting down\r\n" (fun r -> Imap.Read.response r) in
190
+
Alcotest.(check bool) "is BYE" true (is_bye result)
191
+
192
+
let test_response_uidvalidity () =
193
+
let result =
194
+
with_reader "* OK [UIDVALIDITY 1234567890] UIDs valid\r\n" (fun r -> Imap.Read.response r)
195
+
in
196
+
match result with
197
+
| Imap.Response.Ok { code = Some (Imap.Code.Uidvalidity v); _ } ->
198
+
Alcotest.(check int32) "uidvalidity" 1234567890l v
199
+
| _ -> Alcotest.fail "expected UIDVALIDITY"
200
+
201
+
let test_response_uidnext () =
202
+
let result =
203
+
with_reader "* OK [UIDNEXT 42] Next UID\r\n" (fun r -> Imap.Read.response r)
204
+
in
205
+
match result with
206
+
| Imap.Response.Ok { code = Some (Imap.Code.Uidnext n); _ } -> Alcotest.(check int32) "uidnext" 42l n
207
+
| _ -> Alcotest.fail "expected UIDNEXT"
208
+
209
+
let test_response_fetch_flags () =
210
+
let result =
211
+
with_reader "* 1 FETCH (FLAGS (\\Seen))\r\n" (fun r -> Imap.Read.response r)
212
+
in
213
+
Alcotest.(check bool) "is FETCH" true (is_fetch result);
214
+
match result with
215
+
| Imap.Response.Fetch { seq; items } ->
216
+
Alcotest.(check int) "seq" 1 seq;
217
+
Alcotest.(check int) "items" 1 (List.length items)
218
+
| _ -> Alcotest.fail "expected FETCH"
219
+
220
+
let test_response_fetch_uid () =
221
+
let result =
222
+
with_reader "* 1 FETCH (UID 12345)\r\n" (fun r -> Imap.Read.response r)
223
+
in
224
+
match result with
225
+
| Imap.Response.Fetch { items; _ } ->
226
+
let uid =
227
+
List.find_map
228
+
(function Imap.Fetch.Item_uid u -> Some u | _ -> None)
229
+
items
230
+
in
231
+
Alcotest.(check (option int32)) "uid" (Some 12345l) uid
232
+
| _ -> Alcotest.fail "expected FETCH"
233
+
234
+
let test_response_fetch_multiple () =
235
+
let result =
236
+
with_reader "* 1 FETCH (FLAGS (\\Seen) UID 12345)\r\n" (fun r -> Imap.Read.response r)
237
+
in
238
+
match result with
239
+
| Imap.Response.Fetch { items; _ } -> Alcotest.(check int) "items" 2 (List.length items)
240
+
| _ -> Alcotest.fail "expected FETCH"
241
+
242
+
let test_response_status () =
243
+
let result =
244
+
with_reader "* STATUS INBOX (MESSAGES 42 UNSEEN 5)\r\n" (fun r -> Imap.Read.response r)
245
+
in
246
+
Alcotest.(check bool) "is STATUS" true (is_status result);
247
+
match result with
248
+
| Imap.Response.Status { mailbox; items } ->
249
+
Alcotest.(check string) "mailbox" "INBOX" mailbox;
250
+
Alcotest.(check int) "items" 2 (List.length items)
251
+
| _ -> Alcotest.fail "expected STATUS"
252
+
253
+
let test_response_namespace () =
254
+
let result =
255
+
with_reader "* NAMESPACE ((\"\" \"/\")) NIL NIL\r\n" (fun r -> Imap.Read.response r)
256
+
in
257
+
Alcotest.(check bool) "is NAMESPACE" true (is_namespace result)
258
+
259
+
let test_response_enabled () =
260
+
let result =
261
+
with_reader "* ENABLED CONDSTORE QRESYNC\r\n" (fun r -> Imap.Read.response r)
262
+
in
263
+
Alcotest.(check bool) "is ENABLED" true (is_enabled result);
264
+
match result with
265
+
| Imap.Response.Enabled exts -> Alcotest.(check int) "extensions" 2 (List.length exts)
266
+
| _ -> Alcotest.fail "expected ENABLED"
267
+
268
+
let test_response_id () =
269
+
let result =
270
+
with_reader "* ID (\"name\" \"test\" \"version\" \"1.0\")\r\n" (fun r -> Imap.Read.response r)
271
+
in
272
+
Alcotest.(check bool) "is ID" true (is_id result);
273
+
match result with
274
+
| Imap.Response.Id (Some pairs) -> Alcotest.(check int) "pairs" 2 (List.length pairs)
275
+
| _ -> Alcotest.fail "expected ID with params"
276
+
277
+
let test_response_id_nil () =
278
+
let result = with_reader "* ID NIL\r\n" (fun r -> Imap.Read.response r) in
279
+
match result with
280
+
| Imap.Response.Id None -> ()
281
+
| _ -> Alcotest.fail "expected ID NIL"
282
+
283
+
let test_responses_until_tagged () =
284
+
let input = "* 42 EXISTS\r\n* FLAGS (\\Seen)\r\nA001 OK Done\r\n" in
285
+
let untagged, final =
286
+
with_reader input (fun r -> Imap.Read.responses_until_tagged r "A001")
287
+
in
288
+
Alcotest.(check int) "untagged count" 2 (List.length untagged);
289
+
Alcotest.(check bool) "final is OK" true (is_ok final)
290
+
291
+
let () =
292
+
let open Alcotest in
293
+
run "imap_read"
294
+
[
295
+
( "primitives",
296
+
[
297
+
test_case "atom" `Quick test_atom;
298
+
test_case "number" `Quick test_number;
299
+
test_case "quoted string" `Quick test_quoted_string;
300
+
test_case "quoted string escape" `Quick test_quoted_string_escape;
301
+
test_case "literal" `Quick test_literal;
302
+
test_case "nstring string" `Quick test_nstring_string;
303
+
test_case "nstring nil" `Quick test_nstring_nil;
304
+
] );
305
+
( "flags",
306
+
[
307
+
test_case "seen" `Quick test_flag_seen;
308
+
test_case "answered" `Quick test_flag_answered;
309
+
test_case "keyword" `Quick test_flag_keyword;
310
+
test_case "flag list" `Quick test_flag_list;
311
+
test_case "flag list empty" `Quick test_flag_list_empty;
312
+
] );
313
+
( "responses",
314
+
[
315
+
test_case "OK tagged" `Quick test_response_ok_tagged;
316
+
test_case "OK with code" `Quick test_response_ok_with_code;
317
+
test_case "NO" `Quick test_response_no;
318
+
test_case "BAD" `Quick test_response_bad;
319
+
test_case "CAPABILITY" `Quick test_response_capability;
320
+
test_case "EXISTS" `Quick test_response_exists;
321
+
test_case "EXPUNGE" `Quick test_response_expunge;
322
+
test_case "FLAGS" `Quick test_response_flags;
323
+
test_case "LIST" `Quick test_response_list;
324
+
test_case "LIST no delimiter" `Quick test_response_list_no_delimiter;
325
+
test_case "continuation" `Quick test_response_continuation;
326
+
test_case "continuation text" `Quick test_response_continuation_text;
327
+
test_case "untagged OK" `Quick test_response_untagged_ok;
328
+
test_case "PREAUTH" `Quick test_response_preauth;
329
+
test_case "BYE" `Quick test_response_bye;
330
+
test_case "UIDVALIDITY" `Quick test_response_uidvalidity;
331
+
test_case "UIDNEXT" `Quick test_response_uidnext;
332
+
test_case "FETCH FLAGS" `Quick test_response_fetch_flags;
333
+
test_case "FETCH UID" `Quick test_response_fetch_uid;
334
+
test_case "FETCH multiple" `Quick test_response_fetch_multiple;
335
+
test_case "STATUS" `Quick test_response_status;
336
+
test_case "NAMESPACE" `Quick test_response_namespace;
337
+
test_case "ENABLED" `Quick test_response_enabled;
338
+
test_case "ID" `Quick test_response_id;
339
+
test_case "ID NIL" `Quick test_response_id_nil;
340
+
test_case "responses until tagged" `Quick test_responses_until_tagged;
341
+
] );
342
+
]
+2
-2
test/test_server.ml
+2
-2
test/test_server.ml
···
8
8
(* Note: Full connection handling tests require EIO mock flows which are complex to set up.
9
9
These tests focus on response serialization and parser integration. *)
10
10
11
-
open Imap_types
12
-
open Imap_parser
11
+
open Imapd.Protocol
12
+
open Imapd.Parser
13
13
14
14
(* Helper: check if string contains substring *)
15
15
let contains_substring ~substring s =
+2
-2
test/test_storage.ml
+2
-2
test/test_storage.ml
+1
-1
test/test_types.ml
+1
-1
test/test_types.ml
+290
test/test_write.ml
+290
test/test_write.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Imap.Write module *)
7
+
8
+
(* Helper to capture serialized output *)
9
+
let serialize f =
10
+
let buf = Buffer.create 256 in
11
+
Eio_main.run @@ fun _ ->
12
+
Eio.Buf_write.with_flow (Eio.Flow.buffer_sink buf) f;
13
+
Buffer.contents buf
14
+
15
+
let test_atom () =
16
+
let result = serialize (fun w -> Imap.Write.atom w "INBOX") in
17
+
Alcotest.(check string) "atom" "INBOX" result
18
+
19
+
let test_quoted_string () =
20
+
let result = serialize (fun w -> Imap.Write.quoted_string w "hello world") in
21
+
Alcotest.(check string) "quoted" "\"hello world\"" result
22
+
23
+
let test_quoted_string_escape () =
24
+
let result = serialize (fun w -> Imap.Write.quoted_string w "say \"hi\"") in
25
+
Alcotest.(check string) "escape quotes" "\"say \\\"hi\\\"\"" result
26
+
27
+
let test_astring_atom () =
28
+
let result = serialize (fun w -> Imap.Write.astring w "INBOX") in
29
+
Alcotest.(check string) "astring atom" "INBOX" result
30
+
31
+
let test_astring_quoted () =
32
+
let result = serialize (fun w -> Imap.Write.astring w "Sent Items") in
33
+
Alcotest.(check string) "astring quoted" "\"Sent Items\"" result
34
+
35
+
let test_nstring_some () =
36
+
let result = serialize (fun w -> Imap.Write.nstring w (Some "text")) in
37
+
Alcotest.(check string) "nstring some" "\"text\"" result
38
+
39
+
let test_nstring_none () =
40
+
let result = serialize (fun w -> Imap.Write.nstring w None) in
41
+
Alcotest.(check string) "nstring none" "NIL" result
42
+
43
+
let test_sequence_single () =
44
+
let result =
45
+
serialize (fun w -> Imap.Write.sequence_set w [ Imap.Seq.Single 5 ])
46
+
in
47
+
Alcotest.(check string) "single" "5" result
48
+
49
+
let test_sequence_range () =
50
+
let result =
51
+
serialize (fun w -> Imap.Write.sequence_set w [ Imap.Seq.Range (1, 10) ])
52
+
in
53
+
Alcotest.(check string) "range" "1:10" result
54
+
55
+
let test_sequence_from () =
56
+
let result =
57
+
serialize (fun w -> Imap.Write.sequence_set w [ Imap.Seq.From 5 ])
58
+
in
59
+
Alcotest.(check string) "from" "5:*" result
60
+
61
+
let test_sequence_all () =
62
+
let result =
63
+
serialize (fun w -> Imap.Write.sequence_set w [ Imap.Seq.All ])
64
+
in
65
+
Alcotest.(check string) "all" "*" result
66
+
67
+
let test_sequence_complex () =
68
+
let result =
69
+
serialize (fun w ->
70
+
Imap.Write.sequence_set w [ Imap.Seq.Single 1; Imap.Seq.Range (3, 5); Imap.Seq.From 10 ])
71
+
in
72
+
Alcotest.(check string) "complex" "1,3:5,10:*" result
73
+
74
+
let test_flag_seen () =
75
+
let result = serialize (fun w -> Imap.Write.flag w (Imap.Flag.System Imap.Flag.Seen)) in
76
+
Alcotest.(check string) "seen" "\\Seen" result
77
+
78
+
let test_flag_keyword () =
79
+
let result = serialize (fun w -> Imap.Write.flag w (Imap.Flag.Keyword "Forwarded")) in
80
+
Alcotest.(check string) "keyword" "$Forwarded" result
81
+
82
+
let test_flag_list () =
83
+
let result =
84
+
serialize (fun w ->
85
+
Imap.Write.flag_list w [ Imap.Flag.System Imap.Flag.Seen; Imap.Flag.System Imap.Flag.Flagged; Imap.Flag.Keyword "Important" ])
86
+
in
87
+
Alcotest.(check string) "flag list" "(\\Seen \\Flagged $Important)" result
88
+
89
+
let test_command_capability () =
90
+
let result = serialize (fun w -> Imap.Write.command w ~tag:"A001" Imap.Command.Capability) in
91
+
Alcotest.(check string) "capability" "A001 CAPABILITY\r\n" result
92
+
93
+
let test_command_noop () =
94
+
let result = serialize (fun w -> Imap.Write.command w ~tag:"A002" Imap.Command.Noop) in
95
+
Alcotest.(check string) "noop" "A002 NOOP\r\n" result
96
+
97
+
let test_command_logout () =
98
+
let result = serialize (fun w -> Imap.Write.command w ~tag:"A003" Imap.Command.Logout) in
99
+
Alcotest.(check string) "logout" "A003 LOGOUT\r\n" result
100
+
101
+
let test_command_login () =
102
+
let result =
103
+
serialize (fun w ->
104
+
Imap.Write.command w ~tag:"A004"
105
+
(Imap.Command.Login { username = "user"; password = "pass" }))
106
+
in
107
+
Alcotest.(check string) "login" "A004 LOGIN user pass\r\n" result
108
+
109
+
let test_command_login_quoted () =
110
+
(* Note: @ and . are valid atom characters per RFC 9051, so only the password
111
+
with a space needs quoting *)
112
+
let result =
113
+
serialize (fun w ->
114
+
Imap.Write.command w ~tag:"A005"
115
+
(Imap.Command.Login { username = "user@example.com"; password = "p@ss word" }))
116
+
in
117
+
Alcotest.(check string) "login quoted"
118
+
"A005 LOGIN user@example.com \"p@ss word\"\r\n" result
119
+
120
+
let test_command_select () =
121
+
let result =
122
+
serialize (fun w -> Imap.Write.command w ~tag:"A006" (Imap.Command.Select "INBOX"))
123
+
in
124
+
Alcotest.(check string) "select" "A006 SELECT INBOX\r\n" result
125
+
126
+
let test_command_examine () =
127
+
let result =
128
+
serialize (fun w -> Imap.Write.command w ~tag:"A007" (Imap.Command.Examine "Sent Items"))
129
+
in
130
+
Alcotest.(check string) "examine" "A007 EXAMINE \"Sent Items\"\r\n" result
131
+
132
+
let test_command_list () =
133
+
let result =
134
+
serialize (fun w ->
135
+
Imap.Write.command w ~tag:"A008" (Imap.Command.List { reference = ""; pattern = "*" }))
136
+
in
137
+
Alcotest.(check string) "list" "A008 LIST \"\" \"*\"\r\n" result
138
+
139
+
let test_command_fetch () =
140
+
let result =
141
+
serialize (fun w ->
142
+
Imap.Write.command w ~tag:"A009"
143
+
(Imap.Command.Fetch { sequence = [ Imap.Seq.Range (1, 10) ]; items = [ Imap.Fetch.Uid; Imap.Fetch.Flags ] }))
144
+
in
145
+
Alcotest.(check string) "fetch" "A009 FETCH 1:10 (UID FLAGS)\r\n" result
146
+
147
+
let test_command_fetch_single_item () =
148
+
let result =
149
+
serialize (fun w ->
150
+
Imap.Write.command w ~tag:"A010"
151
+
(Imap.Command.Fetch { sequence = [ Imap.Seq.All ]; items = [ Imap.Fetch.Envelope ] }))
152
+
in
153
+
Alcotest.(check string) "fetch single" "A010 FETCH * ENVELOPE\r\n" result
154
+
155
+
let test_command_store () =
156
+
let result =
157
+
serialize (fun w ->
158
+
Imap.Write.command w ~tag:"A011"
159
+
(Imap.Command.Store
160
+
{
161
+
sequence = [ Imap.Seq.Range (1, 5) ];
162
+
silent = false;
163
+
action = Imap.Store.Add;
164
+
flags = [ Imap.Flag.System Imap.Flag.Seen ];
165
+
}))
166
+
in
167
+
Alcotest.(check string) "store" "A011 STORE 1:5 +FLAGS (\\Seen)\r\n" result
168
+
169
+
let test_command_store_silent () =
170
+
let result =
171
+
serialize (fun w ->
172
+
Imap.Write.command w ~tag:"A012"
173
+
(Imap.Command.Store
174
+
{
175
+
sequence = [ Imap.Seq.Single 1 ];
176
+
silent = true;
177
+
action = Imap.Store.Remove;
178
+
flags = [ Imap.Flag.System Imap.Flag.Deleted ];
179
+
}))
180
+
in
181
+
Alcotest.(check string) "store silent"
182
+
"A012 STORE 1 -FLAGS.SILENT (\\Deleted)\r\n" result
183
+
184
+
let test_command_copy () =
185
+
let result =
186
+
serialize (fun w ->
187
+
Imap.Write.command w ~tag:"A013"
188
+
(Imap.Command.Copy { sequence = [ Imap.Seq.Range (1, 10) ]; mailbox = "Archive" }))
189
+
in
190
+
Alcotest.(check string) "copy" "A013 COPY 1:10 Archive\r\n" result
191
+
192
+
let test_command_search () =
193
+
let result =
194
+
serialize (fun w ->
195
+
Imap.Write.command w ~tag:"A014"
196
+
(Imap.Command.Search { charset = None; criteria = Imap.Search.Unseen }))
197
+
in
198
+
Alcotest.(check string) "search" "A014 SEARCH UNSEEN\r\n" result
199
+
200
+
let test_command_search_complex () =
201
+
(* Note: @ and . are valid atom characters per RFC 9051, so email addresses
202
+
are output as atoms, not quoted strings *)
203
+
let result =
204
+
serialize (fun w ->
205
+
Imap.Write.command w ~tag:"A015"
206
+
(Imap.Command.Search
207
+
{
208
+
charset = None;
209
+
criteria = Imap.Search.And [ Imap.Search.Unseen; Imap.Search.From "alice@example.com" ];
210
+
}))
211
+
in
212
+
Alcotest.(check string) "search complex"
213
+
"A015 SEARCH (UNSEEN FROM alice@example.com)\r\n" result
214
+
215
+
let test_command_uid_fetch () =
216
+
let result =
217
+
serialize (fun w ->
218
+
Imap.Write.command w ~tag:"A016"
219
+
(Imap.Command.Uid (Uid_fetch { sequence = [ Imap.Seq.Range (100, 200) ]; items = [ Imap.Fetch.Flags ] })))
220
+
in
221
+
Alcotest.(check string) "uid fetch" "A016 UID FETCH 100:200 FLAGS\r\n" result
222
+
223
+
let test_command_id () =
224
+
let result =
225
+
serialize (fun w ->
226
+
Imap.Write.command w ~tag:"A017"
227
+
(Imap.Command.Id (Some [ ("name", "test"); ("version", "1.0") ])))
228
+
in
229
+
Alcotest.(check string) "id"
230
+
"A017 ID (\"name\" \"test\" \"version\" \"1.0\")\r\n" result
231
+
232
+
let test_command_id_nil () =
233
+
let result = serialize (fun w -> Imap.Write.command w ~tag:"A018" (Imap.Command.Id None)) in
234
+
Alcotest.(check string) "id nil" "A018 ID NIL\r\n" result
235
+
236
+
let test_idle_done () =
237
+
let result = serialize (fun w -> Imap.Write.idle_done w) in
238
+
Alcotest.(check string) "idle done" "DONE\r\n" result
239
+
240
+
let () =
241
+
let open Alcotest in
242
+
run "imap_write"
243
+
[
244
+
( "primitives",
245
+
[
246
+
test_case "atom" `Quick test_atom;
247
+
test_case "quoted string" `Quick test_quoted_string;
248
+
test_case "quoted string escape" `Quick test_quoted_string_escape;
249
+
test_case "astring atom" `Quick test_astring_atom;
250
+
test_case "astring quoted" `Quick test_astring_quoted;
251
+
test_case "nstring some" `Quick test_nstring_some;
252
+
test_case "nstring none" `Quick test_nstring_none;
253
+
] );
254
+
( "sequences",
255
+
[
256
+
test_case "single" `Quick test_sequence_single;
257
+
test_case "range" `Quick test_sequence_range;
258
+
test_case "from" `Quick test_sequence_from;
259
+
test_case "all" `Quick test_sequence_all;
260
+
test_case "complex" `Quick test_sequence_complex;
261
+
] );
262
+
( "flags",
263
+
[
264
+
test_case "seen" `Quick test_flag_seen;
265
+
test_case "keyword" `Quick test_flag_keyword;
266
+
test_case "flag list" `Quick test_flag_list;
267
+
] );
268
+
( "commands",
269
+
[
270
+
test_case "CAPABILITY" `Quick test_command_capability;
271
+
test_case "NOOP" `Quick test_command_noop;
272
+
test_case "LOGOUT" `Quick test_command_logout;
273
+
test_case "LOGIN" `Quick test_command_login;
274
+
test_case "LOGIN quoted" `Quick test_command_login_quoted;
275
+
test_case "SELECT" `Quick test_command_select;
276
+
test_case "EXAMINE" `Quick test_command_examine;
277
+
test_case "LIST" `Quick test_command_list;
278
+
test_case "FETCH" `Quick test_command_fetch;
279
+
test_case "FETCH single item" `Quick test_command_fetch_single_item;
280
+
test_case "STORE" `Quick test_command_store;
281
+
test_case "STORE silent" `Quick test_command_store_silent;
282
+
test_case "COPY" `Quick test_command_copy;
283
+
test_case "SEARCH" `Quick test_command_search;
284
+
test_case "SEARCH complex" `Quick test_command_search_complex;
285
+
test_case "UID FETCH" `Quick test_command_uid_fetch;
286
+
test_case "ID" `Quick test_command_id;
287
+
test_case "ID NIL" `Quick test_command_id_nil;
288
+
test_case "IDLE DONE" `Quick test_idle_done;
289
+
] );
290
+
]