forked from
anil.recoil.org/ocaml-imap
IMAP in OCaml
trim out the imapd for now and will reconcile with mtelvers version at a later date once the client is stable
+1
-10291
-6
bin/dune
-6
bin/dune
+1
-24
dune-project
+1
-24
dune-project
···
1
1
(lang dune 3.20)
2
2
3
-
(name imapd)
3
+
(name imap)
4
4
5
5
(generate_opam_files true)
6
-
7
-
(using menhir 2.1)
8
6
9
7
(license ISC)
10
8
(authors "Anil Madhavapeddy")
···
34
32
(mirage-crypto-rng (>= 1.0.0))
35
33
(odoc :with-doc)
36
34
(alcotest (and :with-test (>= 1.7.0)))))
37
-
38
-
(package
39
-
(name imapd)
40
-
(synopsis "IMAP4rev2 server implemented in OCaml with Eio")
41
-
(description
42
-
"A modular IMAP4rev2 server implementation (RFC 9051) in OCaml using Eio for \
43
-
networking. Includes pluggable storage backends.")
44
-
(depends
45
-
(ocaml (>= 5.1.0))
46
-
(menhir (>= 20230608))
47
-
(eio (>= 1.0))
48
-
(eio_main (>= 1.0))
49
-
(tls-eio (>= 1.0))
50
-
(tls (>= 1.0))
51
-
(faraday (>= 0.8))
52
-
(cmdliner (>= 1.2.0))
53
-
(fmt (>= 0.9.0))
54
-
(base64 (>= 3.5.0))
55
-
(conf-pam :build)
56
-
(odoc :with-doc)
57
-
(alcotest (and :with-test (>= 1.7.0)))))
-41
imapd.opam
-41
imapd.opam
···
1
-
# This file is generated by dune, edit dune-project instead
2
-
opam-version: "2.0"
3
-
synopsis: "IMAP4rev2 server implemented in OCaml with Eio"
4
-
description:
5
-
"A modular IMAP4rev2 server implementation (RFC 9051) in OCaml using Eio for networking. Includes pluggable storage backends."
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
-
"menhir" {>= "20230608"}
15
-
"eio" {>= "1.0"}
16
-
"eio_main" {>= "1.0"}
17
-
"tls-eio" {>= "1.0"}
18
-
"tls" {>= "1.0"}
19
-
"faraday" {>= "0.8"}
20
-
"cmdliner" {>= "1.2.0"}
21
-
"fmt" {>= "0.9.0"}
22
-
"base64" {>= "3.5.0"}
23
-
"conf-pam" {build}
24
-
"odoc" {with-doc}
25
-
"alcotest" {with-test & >= "1.7.0"}
26
-
]
27
-
build: [
28
-
["dune" "subst"] {dev}
29
-
[
30
-
"dune"
31
-
"build"
32
-
"-p"
33
-
name
34
-
"-j"
35
-
jobs
36
-
"@install"
37
-
"@runtest" {with-test}
38
-
"@doc" {with-doc}
39
-
]
40
-
]
41
-
x-maintenance-intent: ["(latest)"]
-52
lib/imapd/auth.ml
-52
lib/imapd/auth.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** IMAP Authentication Module
7
-
8
-
Implements {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.2.3}RFC 9051 Section 6.2.3}
9
-
LOGIN command authentication. *)
10
-
11
-
module type AUTH = sig
12
-
type t
13
-
14
-
val create : service_name:string -> t
15
-
val authenticate : t -> username:string -> password:string -> bool
16
-
end
17
-
18
-
(* External C functions for PAM *)
19
-
external pam_authenticate_ext : string -> string -> string -> bool = "caml_pam_authenticate"
20
-
external pam_available_ext : unit -> bool = "caml_pam_available"
21
-
22
-
module Pam_auth = struct
23
-
type t = {
24
-
service_name : string;
25
-
}
26
-
27
-
let create ~service_name = { service_name }
28
-
29
-
let authenticate t ~username ~password =
30
-
pam_authenticate_ext t.service_name username password
31
-
32
-
let is_available () = pam_available_ext ()
33
-
end
34
-
35
-
module Mock_auth = struct
36
-
type t = {
37
-
mutable users : (string * string) list;
38
-
service_name : string; [@warning "-69"]
39
-
(** Kept for API compatibility with [Pam_auth] *)
40
-
}
41
-
42
-
let create ~service_name = { users = []; service_name }
43
-
44
-
let add_user t ~username ~password =
45
-
t.users <- (username, password) :: List.filter (fun (u, _) -> u <> username) t.users
46
-
47
-
let remove_user t ~username =
48
-
t.users <- List.filter (fun (u, _) -> u <> username) t.users
49
-
50
-
let authenticate t ~username ~password =
51
-
List.exists (fun (u, p) -> u = username && p = password) t.users
52
-
end
-52
lib/imapd/auth.mli
-52
lib/imapd/auth.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** IMAP Authentication Module
7
-
8
-
This module provides authentication backends for the IMAP server.
9
-
10
-
Implements {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.2.3}RFC 9051 Section 6.2.3}
11
-
LOGIN command authentication.
12
-
13
-
{2 References}
14
-
{ul
15
-
{- {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} - IMAP4rev2}
16
-
{- {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.2.2}RFC 9051 Section 6.2.2} - AUTHENTICATE command}} *)
17
-
18
-
(** Authentication backend signature *)
19
-
module type AUTH = sig
20
-
type t
21
-
22
-
val create : service_name:string -> t
23
-
(** [create ~service_name] creates an authenticator using the given service name.
24
-
For PAM, this corresponds to the PAM service configuration (e.g., "imapd"). *)
25
-
26
-
val authenticate : t -> username:string -> password:string -> bool
27
-
(** [authenticate t ~username ~password] returns [true] if authentication succeeds. *)
28
-
end
29
-
30
-
(** PAM-based authentication using system accounts.
31
-
32
-
Uses Linux-PAM to authenticate against system users.
33
-
Requires a PAM service configuration file (e.g., /etc/pam.d/imapd). *)
34
-
module Pam_auth : sig
35
-
include AUTH
36
-
37
-
val is_available : unit -> bool
38
-
(** [is_available ()] returns [true] if PAM support is compiled in. *)
39
-
end
40
-
41
-
(** Mock authenticator for testing.
42
-
43
-
Stores credentials in memory. Useful for unit tests. *)
44
-
module Mock_auth : sig
45
-
include AUTH
46
-
47
-
val add_user : t -> username:string -> password:string -> unit
48
-
(** [add_user t ~username ~password] adds a user with the given credentials. *)
49
-
50
-
val remove_user : t -> username:string -> unit
51
-
(** [remove_user t ~username] removes a user. *)
52
-
end
-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 (List_basic { 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))
-544
lib/imapd/grammar.mly
-544
lib/imapd/grammar.mly
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** IMAP Grammar - RFC 9051 Section 9 ABNF
7
-
8
-
Menhir grammar for IMAP4rev2 protocol parsing.
9
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-9}RFC 9051 Section 9}. *)
10
-
11
-
%{
12
-
open Protocol
13
-
%}
14
-
15
-
(* Tokens *)
16
-
%token EOF
17
-
%token SP CRLF
18
-
%token LPAREN RPAREN LBRACKET RBRACKET LBRACE RBRACE
19
-
%token STAR PLUS MINUS COLON COMMA DOT LANGLE RANGLE
20
-
21
-
(* Literals and strings *)
22
-
%token <int64> NUMBER
23
-
%token <string> ATOM
24
-
%token <string> QUOTED_STRING
25
-
%token <int64> LITERAL_START
26
-
%token <int64> LITERAL_START_PLUS
27
-
%token NIL
28
-
29
-
(* System flags *)
30
-
%token FLAG_SEEN FLAG_ANSWERED FLAG_FLAGGED FLAG_DELETED FLAG_DRAFT FLAG_RECENT
31
-
%token <string> FLAG_EXTENSION
32
-
%token FLAG_PERM_ALL
33
-
34
-
(* Commands - Any state *)
35
-
%token CAPABILITY NOOP LOGOUT ID
36
-
37
-
(* Commands - Not authenticated *)
38
-
%token STARTTLS LOGIN AUTHENTICATE
39
-
40
-
(* Commands - Authenticated *)
41
-
%token ENABLE SELECT EXAMINE CREATE DELETE RENAME
42
-
%token SUBSCRIBE UNSUBSCRIBE LIST NAMESPACE STATUS APPEND IDLE
43
-
44
-
(* Commands - Selected *)
45
-
%token CLOSE UNSELECT EXPUNGE SEARCH FETCH STORE COPY MOVE UID
46
-
47
-
(* Fetch attributes *)
48
-
%token ENVELOPE FLAGS INTERNALDATE RFC822 BODY BODYSTRUCTURE BINARY
49
-
%token ALL FAST FULL
50
-
51
-
(* Status attributes *)
52
-
%token MESSAGES UIDNEXT UIDVALIDITY UNSEEN DELETED_STATUS SIZE
53
-
54
-
(* Search keys *)
55
-
%token ANSWERED BCC BEFORE CC DRAFT FLAGGED FROM
56
-
%token HEADER KEYWORD LARGER NEW NOT OLD ON OR
57
-
%token SEEN SENTBEFORE SENTON SENTSINCE SINCE SMALLER
58
-
%token SUBJECT TEXT TO UNANSWERED UNDELETED UNDRAFT UNFLAGGED UNKEYWORD
59
-
60
-
(* Other keywords *)
61
-
%token CHARSET MIME PEEK HEADER_FIELDS HEADER_FIELDS_NOT SILENT
62
-
%token RETURN SUBSCRIBED CHILDREN REMOTE RECURSIVEMATCH DONE
63
-
64
-
(* LIST-EXTENDED - RFC 5258, RFC 6154 *)
65
-
%token SPECIAL_USE
66
-
67
-
(* QUOTA extension - RFC 9208 *)
68
-
%token GETQUOTA GETQUOTAROOT SETQUOTA STORAGE MAILBOX ANNOTATION_STORAGE
69
-
70
-
(* Entry point *)
71
-
%start <Protocol.tagged_command> command
72
-
%start <Protocol.response> response_parser
73
-
74
-
%%
75
-
76
-
(* === Basic types === *)
77
-
78
-
(* astring = 1*ASTRING-CHAR / string *)
79
-
astring:
80
-
| s = ATOM { s }
81
-
| s = QUOTED_STRING { s }
82
-
;
83
-
84
-
(* string = quoted / literal - literal handled specially *)
85
-
imap_string:
86
-
| s = QUOTED_STRING { s }
87
-
;
88
-
89
-
(* nstring = string / nil *)
90
-
nstring:
91
-
| NIL { None }
92
-
| s = imap_string { Some s }
93
-
| s = ATOM { Some s }
94
-
;
95
-
96
-
(* number = 1*DIGIT *)
97
-
number:
98
-
| n = NUMBER { n }
99
-
;
100
-
101
-
(* nz-number = digit-nz *DIGIT *)
102
-
nz_number:
103
-
| n = NUMBER { if n = 0L then failwith "Expected non-zero number" else n }
104
-
;
105
-
106
-
(* tag = 1*<any ASTRING-CHAR except "+"> *)
107
-
tag:
108
-
| t = ATOM { t }
109
-
| n = NUMBER { Int64.to_string n }
110
-
;
111
-
112
-
(* mailbox = "INBOX" / astring *)
113
-
mailbox:
114
-
| s = astring { s }
115
-
;
116
-
117
-
(* userid / password = astring *)
118
-
userid:
119
-
| s = astring { s }
120
-
;
121
-
122
-
password:
123
-
| s = astring { s }
124
-
;
125
-
126
-
(* === Sequence sets - RFC 9051 Section 9 === *)
127
-
128
-
(* Simplified sequence parsing to avoid LR conflicts *)
129
-
(* seq-number can be a number or * *)
130
-
seq_num_value:
131
-
| n = nz_number { Some (Int64.to_int n) }
132
-
| STAR { None }
133
-
;
134
-
135
-
(* A sequence element is either a single value or a range *)
136
-
(* We inline the range check to avoid reduce/reduce conflicts *)
137
-
seq_element:
138
-
| a = seq_num_value COLON b = seq_num_value
139
-
{
140
-
match a, b with
141
-
| Some a, Some b -> Range (a, b)
142
-
| Some a, None -> From a
143
-
| None, Some b -> Range (1, b)
144
-
| None, None -> All
145
-
}
146
-
| n = seq_num_value
147
-
{
148
-
match n with
149
-
| Some n -> Single n
150
-
| None -> All
151
-
}
152
-
;
153
-
154
-
sequence_set:
155
-
| e = seq_element { [e] }
156
-
| e = seq_element COMMA rest = sequence_set { e :: rest }
157
-
;
158
-
159
-
(* === Flags === *)
160
-
161
-
(* flag = "\Answered" / "\Flagged" / "\Deleted" / "\Seen" / "\Draft" / flag-keyword / flag-extension *)
162
-
flag:
163
-
| FLAG_SEEN { System Seen }
164
-
| FLAG_ANSWERED { System Answered }
165
-
| FLAG_FLAGGED { System Flagged }
166
-
| FLAG_DELETED { System Deleted }
167
-
| FLAG_DRAFT { System Draft }
168
-
| FLAG_RECENT { System Seen } (* \Recent is obsolete, map to Seen *)
169
-
| s = FLAG_EXTENSION { Keyword ("\\" ^ s) }
170
-
| s = ATOM { Keyword s }
171
-
;
172
-
173
-
(* flag-list = "(" [flag *(SP flag)] ")" *)
174
-
flag_list:
175
-
| LPAREN RPAREN { [] }
176
-
| LPAREN f = flag fs = flag_list_rest RPAREN { f :: fs }
177
-
;
178
-
179
-
flag_list_rest:
180
-
| { [] }
181
-
| SP f = flag fs = flag_list_rest { f :: fs }
182
-
;
183
-
184
-
185
-
(* === Fetch items === *)
186
-
187
-
(* section-spec for BODY[...] *)
188
-
section_spec:
189
-
| HEADER { "HEADER" }
190
-
| HEADER_FIELDS SP LPAREN hs = header_list RPAREN { "HEADER.FIELDS (" ^ String.concat " " hs ^ ")" }
191
-
| HEADER_FIELDS_NOT SP LPAREN hs = header_list RPAREN { "HEADER.FIELDS.NOT (" ^ String.concat " " hs ^ ")" }
192
-
| TEXT { "TEXT" }
193
-
| MIME { "MIME" }
194
-
| n = section_part { n }
195
-
;
196
-
197
-
section_part:
198
-
| n = nz_number { Int64.to_string n }
199
-
| n = nz_number DOT rest = section_part { Int64.to_string n ^ "." ^ rest }
200
-
;
201
-
202
-
header_list:
203
-
| h = astring { [h] }
204
-
| h = astring SP hs = header_list { h :: hs }
205
-
;
206
-
207
-
(* partial = "<" number "." nz-number ">" *)
208
-
partial:
209
-
| LANGLE start = number DOT count = nz_number RANGLE { Some (Int64.to_int start, Int64.to_int count) }
210
-
;
211
-
212
-
partial_opt:
213
-
| { None }
214
-
| p = partial { p }
215
-
;
216
-
217
-
(* fetch-att = "ENVELOPE" / "FLAGS" / "INTERNALDATE" / ... *)
218
-
fetch_att:
219
-
| ENVELOPE { Fetch_envelope }
220
-
| FLAGS { Fetch_flags }
221
-
| INTERNALDATE { Fetch_internaldate }
222
-
| RFC822 { Fetch_rfc822 }
223
-
| RFC822 DOT SIZE { Fetch_rfc822_size }
224
-
| RFC822 DOT HEADER { Fetch_rfc822_header }
225
-
| RFC822 DOT TEXT { Fetch_rfc822_text }
226
-
| BODY { Fetch_body }
227
-
| BODYSTRUCTURE { Fetch_bodystructure }
228
-
| BODY LBRACKET RBRACKET p = partial_opt { Fetch_body_section ("", p) }
229
-
| BODY LBRACKET s = section_spec RBRACKET p = partial_opt { Fetch_body_section (s, p) }
230
-
| BODY DOT PEEK LBRACKET RBRACKET p = partial_opt { Fetch_body_peek ("", p) }
231
-
| BODY DOT PEEK LBRACKET s = section_spec RBRACKET p = partial_opt { Fetch_body_peek (s, p) }
232
-
| BINARY LBRACKET s = section_part RBRACKET p = partial_opt { Fetch_binary (s, p) }
233
-
| BINARY DOT PEEK LBRACKET s = section_part RBRACKET p = partial_opt { Fetch_binary_peek (s, p) }
234
-
| BINARY DOT SIZE LBRACKET s = section_part RBRACKET { Fetch_binary_size s }
235
-
| UID { Fetch_uid }
236
-
;
237
-
238
-
(* fetch-macro = "ALL" / "FAST" / "FULL" *)
239
-
fetch_macro:
240
-
| ALL { [Fetch_flags; Fetch_internaldate; Fetch_rfc822_size; Fetch_envelope] }
241
-
| FAST { [Fetch_flags; Fetch_internaldate; Fetch_rfc822_size] }
242
-
| FULL { [Fetch_flags; Fetch_internaldate; Fetch_rfc822_size; Fetch_envelope; Fetch_body] }
243
-
;
244
-
245
-
fetch_att_list:
246
-
| f = fetch_att { [f] }
247
-
| f = fetch_att SP fs = fetch_att_list { f :: fs }
248
-
;
249
-
250
-
fetch_items:
251
-
| m = fetch_macro { m }
252
-
| f = fetch_att { [f] }
253
-
| LPAREN fs = fetch_att_list RPAREN { fs }
254
-
;
255
-
256
-
(* === Store action === *)
257
-
258
-
(* store-att-flags = (["+" / "-"] "FLAGS" [".SILENT"]) SP (flag-list / (flag *(SP flag))) *)
259
-
store_action:
260
-
| FLAGS { (Store_set, false) }
261
-
| FLAGS DOT SILENT { (Store_set, true) }
262
-
| PLUS FLAGS { (Store_add, false) }
263
-
| PLUS FLAGS DOT SILENT { (Store_add, true) }
264
-
| MINUS FLAGS { (Store_remove, false) }
265
-
| MINUS FLAGS DOT SILENT { (Store_remove, true) }
266
-
;
267
-
268
-
store_flags:
269
-
| fl = flag_list { fl }
270
-
| f = flag fs = store_flag_rest { f :: fs }
271
-
;
272
-
273
-
store_flag_rest:
274
-
| { [] }
275
-
| SP f = flag fs = store_flag_rest { f :: fs }
276
-
;
277
-
278
-
(* === Search criteria - RFC 9051 Section 9 === *)
279
-
280
-
search_key:
281
-
| ALL { Search_all }
282
-
| ANSWERED { Search_answered }
283
-
| DELETED_STATUS { Search_deleted }
284
-
| FLAGGED { Search_flagged }
285
-
| NEW { Search_new }
286
-
| OLD { Search_old }
287
-
| SEEN { Search_seen }
288
-
| UNANSWERED { Search_unanswered }
289
-
| UNDELETED { Search_undeleted }
290
-
| UNFLAGGED { Search_unflagged }
291
-
| UNSEEN { Search_unseen }
292
-
| DRAFT { Search_draft }
293
-
| UNDRAFT { Search_undraft }
294
-
| BCC SP s = astring { Search_bcc s }
295
-
| BEFORE SP s = astring { Search_before s }
296
-
| BODY SP s = astring { Search_body s }
297
-
| CC SP s = astring { Search_cc s }
298
-
| FROM SP s = astring { Search_from s }
299
-
| HEADER SP h = astring SP v = astring { Search_header (h, v) }
300
-
| KEYWORD SP s = ATOM { Search_keyword s }
301
-
| LARGER SP n = number { Search_larger n }
302
-
| NOT SP k = search_key { Search_not k }
303
-
| ON SP s = astring { Search_on s }
304
-
| OR SP k1 = search_key SP k2 = search_key { Search_or (k1, k2) }
305
-
| SENTBEFORE SP s = astring { Search_sentbefore s }
306
-
| SENTON SP s = astring { Search_senton s }
307
-
| SENTSINCE SP s = astring { Search_sentsince s }
308
-
| SINCE SP s = astring { Search_since s }
309
-
| SMALLER SP n = number { Search_smaller n }
310
-
| SUBJECT SP s = astring { Search_subject s }
311
-
| TEXT SP s = astring { Search_text s }
312
-
| TO SP s = astring { Search_to s }
313
-
| UID SP seq = sequence_set { Search_uid seq }
314
-
| UNKEYWORD SP s = ATOM { Search_unkeyword s }
315
-
| seq = sequence_set { Search_sequence_set seq }
316
-
| LPAREN k = search_key RPAREN { k }
317
-
;
318
-
319
-
search_program:
320
-
| k = search_key { (None, k) }
321
-
| CHARSET SP c = astring SP k = search_key { (Some c, k) }
322
-
;
323
-
324
-
(* === Status attributes === *)
325
-
326
-
status_att:
327
-
| MESSAGES { Status_messages }
328
-
| UIDNEXT { Status_uidnext }
329
-
| UIDVALIDITY { Status_uidvalidity }
330
-
| UNSEEN { Status_unseen }
331
-
| DELETED_STATUS { Status_deleted }
332
-
| SIZE { Status_size }
333
-
;
334
-
335
-
status_att_list:
336
-
| s = status_att { [s] }
337
-
| s = status_att SP ss = status_att_list { s :: ss }
338
-
;
339
-
340
-
(* === Date-time === *)
341
-
342
-
date_time:
343
-
| s = QUOTED_STRING { s }
344
-
;
345
-
346
-
(* === Commands === *)
347
-
348
-
(* id-params-list = string SP nstring *(SP string SP nstring) *)
349
-
id_params:
350
-
| NIL { None }
351
-
| LPAREN RPAREN { Some [] }
352
-
| LPAREN pairs = id_pairs RPAREN { Some pairs }
353
-
;
354
-
355
-
id_pairs:
356
-
| k = imap_string SP v = nstring { [(k, match v with Some s -> s | None -> "")] }
357
-
| k = imap_string SP v = nstring SP rest = id_pairs { (k, match v with Some s -> s | None -> "") :: rest }
358
-
;
359
-
360
-
(* command-any = "CAPABILITY" / "LOGOUT" / "NOOP" / id *)
361
-
command_any:
362
-
| CAPABILITY { Capability }
363
-
| LOGOUT { Logout }
364
-
| NOOP { Noop }
365
-
| ID SP params = id_params { Id params }
366
-
;
367
-
368
-
(* command-nonauth = login / authenticate / "STARTTLS" *)
369
-
command_nonauth:
370
-
| LOGIN SP u = userid SP p = password { Login { username = u; password = p } }
371
-
| AUTHENTICATE SP m = ATOM { Authenticate { mechanism = m; initial_response = None } }
372
-
| AUTHENTICATE SP m = ATOM SP ir = astring { Authenticate { mechanism = m; initial_response = Some ir } }
373
-
| STARTTLS { Starttls }
374
-
;
375
-
376
-
(* command-auth - authenticated state commands *)
377
-
command_auth:
378
-
| ENABLE SP caps = enable_caps { Enable caps }
379
-
| SELECT SP mb = mailbox { Select mb }
380
-
| EXAMINE SP mb = mailbox { Examine mb }
381
-
| CREATE SP mb = mailbox { Create mb }
382
-
| DELETE SP mb = mailbox { Delete mb }
383
-
| RENAME SP old_mb = mailbox SP new_mb = mailbox { Rename { old_name = old_mb; new_name = new_mb } }
384
-
| SUBSCRIBE SP mb = mailbox { Subscribe mb }
385
-
| UNSUBSCRIBE SP mb = mailbox { Unsubscribe mb }
386
-
(* LIST command - RFC 9051, RFC 5258 LIST-EXTENDED *)
387
-
| LIST SP ref = astring SP pat = list_mailbox
388
-
{ List (List_basic { reference = ref; pattern = pat }) }
389
-
(* LIST-EXTENDED: LIST (selection-opts) reference patterns [RETURN (return-opts)]
390
-
Per RFC 5258 Section 3 *)
391
-
| LIST SP sel = list_select_opts SP ref = astring SP pats = list_patterns
392
-
{ List (List_extended { selection = sel; reference = ref; patterns = pats; return_opts = [] }) }
393
-
| LIST SP sel = list_select_opts SP ref = astring SP pats = list_patterns SP ret = list_return_opts
394
-
{ List (List_extended { selection = sel; reference = ref; patterns = pats; return_opts = ret }) }
395
-
| NAMESPACE { Namespace }
396
-
| STATUS SP mb = mailbox SP LPAREN atts = status_att_list RPAREN { Status { mailbox = mb; items = atts } }
397
-
| APPEND SP mb = mailbox SP fl = flag_list SP dt = date_time SP msg = append_message
398
-
{ Append { mailbox = mb; flags = fl; date = Some dt; message = msg } }
399
-
| APPEND SP mb = mailbox SP fl = flag_list SP msg = append_message
400
-
{ Append { mailbox = mb; flags = fl; date = None; message = msg } }
401
-
| APPEND SP mb = mailbox SP msg = append_message
402
-
{ Append { mailbox = mb; flags = []; date = None; message = msg } }
403
-
| IDLE { Idle }
404
-
(* QUOTA extension - RFC 9208 *)
405
-
| GETQUOTA SP root = astring { Getquota root }
406
-
| GETQUOTAROOT SP mb = mailbox { Getquotaroot mb }
407
-
| SETQUOTA SP root = astring SP LPAREN limits = quota_limits RPAREN
408
-
{ Setquota { root; limits } }
409
-
| SETQUOTA SP root = astring SP LPAREN RPAREN
410
-
{ Setquota { root; limits = [] } }
411
-
;
412
-
413
-
(* Quota resource type - RFC 9208 Section 5 *)
414
-
quota_resource:
415
-
| STORAGE { Quota_storage }
416
-
| MESSAGES { Quota_message } (* MESSAGE uses MESSAGES token *)
417
-
| MAILBOX { Quota_mailbox }
418
-
| ANNOTATION_STORAGE { Quota_annotation_storage }
419
-
;
420
-
421
-
(* Quota limit list for SETQUOTA *)
422
-
quota_limits:
423
-
| res = quota_resource SP limit = number { [(res, limit)] }
424
-
| res = quota_resource SP limit = number SP rest = quota_limits { (res, limit) :: rest }
425
-
;
426
-
427
-
enable_caps:
428
-
| c = ATOM { [c] }
429
-
| c = ATOM SP cs = enable_caps { c :: cs }
430
-
;
431
-
432
-
list_mailbox:
433
-
| s = astring { s }
434
-
;
435
-
436
-
(* === LIST-EXTENDED grammar - RFC 5258 Section 3 === *)
437
-
438
-
(* list-select-opts = "(" [list-select-opt *(SP list-select-opt)] ")"
439
-
RFC 5258 Section 3.1 *)
440
-
list_select_opts:
441
-
| LPAREN RPAREN { [] }
442
-
| LPAREN opts = list_select_opt_list RPAREN { opts }
443
-
;
444
-
445
-
list_select_opt_list:
446
-
| o = list_select_opt { [o] }
447
-
| o = list_select_opt SP rest = list_select_opt_list { o :: rest }
448
-
;
449
-
450
-
(* list-select-opt = "SUBSCRIBED" / "REMOTE" / "RECURSIVEMATCH" / "SPECIAL-USE"
451
-
RFC 5258 Section 3.1, RFC 6154 *)
452
-
list_select_opt:
453
-
| SUBSCRIBED { List_select_subscribed }
454
-
| REMOTE { List_select_remote }
455
-
| RECURSIVEMATCH { List_select_recursivematch }
456
-
| SPECIAL_USE { List_select_special_use }
457
-
;
458
-
459
-
(* Multiple patterns: "(" mbox-or-pat *(SP mbox-or-pat) ")" or single pattern
460
-
RFC 5258 Section 3 *)
461
-
list_patterns:
462
-
| pat = list_mailbox { [pat] }
463
-
| LPAREN pats = list_pattern_list RPAREN { pats }
464
-
;
465
-
466
-
list_pattern_list:
467
-
| p = list_mailbox { [p] }
468
-
| p = list_mailbox SP rest = list_pattern_list { p :: rest }
469
-
;
470
-
471
-
(* list-return-opts = "RETURN" SP "(" [list-return-opt *(SP list-return-opt)] ")"
472
-
RFC 5258 Section 3.2 *)
473
-
list_return_opts:
474
-
| RETURN SP LPAREN RPAREN { [] }
475
-
| RETURN SP LPAREN opts = list_return_opt_list RPAREN { opts }
476
-
;
477
-
478
-
list_return_opt_list:
479
-
| o = list_return_opt { [o] }
480
-
| o = list_return_opt SP rest = list_return_opt_list { o :: rest }
481
-
;
482
-
483
-
(* list-return-opt = "SUBSCRIBED" / "CHILDREN" / "SPECIAL-USE"
484
-
RFC 5258 Section 3.2, RFC 6154 *)
485
-
list_return_opt:
486
-
| SUBSCRIBED { List_return_subscribed }
487
-
| CHILDREN { List_return_children }
488
-
| SPECIAL_USE { List_return_special_use }
489
-
;
490
-
491
-
append_message:
492
-
| s = QUOTED_STRING { s }
493
-
| LITERAL_START { "" } (* Placeholder - literal data read separately *)
494
-
| LITERAL_START_PLUS { "" }
495
-
;
496
-
497
-
(* command-select - selected state commands *)
498
-
command_select:
499
-
| CLOSE { Close }
500
-
| UNSELECT { Unselect }
501
-
| EXPUNGE { Expunge }
502
-
| SEARCH SP prog = search_program { let (charset, criteria) = prog in Search { charset; criteria } }
503
-
| FETCH SP seq = sequence_set SP items = fetch_items { Fetch { sequence = seq; items } }
504
-
| STORE SP seq = sequence_set SP act = store_action SP fl = store_flags
505
-
{ let (action, silent) = act in Store { sequence = seq; silent; action; flags = fl } }
506
-
| COPY SP seq = sequence_set SP mb = mailbox { Copy { sequence = seq; mailbox = mb } }
507
-
| MOVE SP seq = sequence_set SP mb = mailbox { Move { sequence = seq; mailbox = mb } }
508
-
;
509
-
510
-
(* UID prefix commands *)
511
-
uid_command:
512
-
| FETCH SP seq = sequence_set SP items = fetch_items
513
-
{ Uid (Uid_fetch { sequence = seq; items }) }
514
-
| STORE SP seq = sequence_set SP act = store_action SP fl = store_flags
515
-
{ let (action, silent) = act in Uid (Uid_store { sequence = seq; silent; action; flags = fl }) }
516
-
| COPY SP seq = sequence_set SP mb = mailbox
517
-
{ Uid (Uid_copy { sequence = seq; mailbox = mb }) }
518
-
| MOVE SP seq = sequence_set SP mb = mailbox
519
-
{ Uid (Uid_move { sequence = seq; mailbox = mb }) }
520
-
| SEARCH SP prog = search_program
521
-
{ let (charset, criteria) = prog in Uid (Uid_search { charset; criteria }) }
522
-
| EXPUNGE SP seq = sequence_set
523
-
{ Uid (Uid_expunge seq) }
524
-
;
525
-
526
-
(* Main command: tag SP command CRLF *)
527
-
command_body:
528
-
| c = command_any { c }
529
-
| c = command_nonauth { c }
530
-
| c = command_auth { c }
531
-
| c = command_select { c }
532
-
| UID SP c = uid_command { c }
533
-
;
534
-
535
-
command:
536
-
| t = tag SP c = command_body CRLF { { tag = t; command = c } }
537
-
| t = tag SP c = command_body EOF { { tag = t; command = c } } (* Allow missing CRLF at EOF *)
538
-
;
539
-
540
-
(* === Response parsing (for completeness) === *)
541
-
542
-
response_parser:
543
-
| EOF { Bye { code = None; text = "Connection closed" } }
544
-
;
-263
lib/imapd/lexer.mll
-263
lib/imapd/lexer.mll
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** IMAP Lexer - RFC 9051 Section 9 ABNF
7
-
8
-
Implements lexical analysis for IMAP4rev2 protocol.
9
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-9}RFC 9051 Section 9}. *)
10
-
11
-
{
12
-
open Grammar
13
-
14
-
exception Lexer_error of string
15
-
16
-
(* Buffer for accumulating quoted string contents *)
17
-
let string_buffer = Buffer.create 256
18
-
19
-
(* Track position for error messages *)
20
-
let current_pos lexbuf =
21
-
let pos = lexbuf.Lexing.lex_curr_p in
22
-
Printf.sprintf "line %d, column %d"
23
-
pos.Lexing.pos_lnum
24
-
(pos.Lexing.pos_cnum - pos.Lexing.pos_bol)
25
-
26
-
(* Case-insensitive keyword matching *)
27
-
let keyword_table = Hashtbl.create 64
28
-
let () =
29
-
List.iter (fun (kw, tok) -> Hashtbl.add keyword_table (String.uppercase_ascii kw) tok)
30
-
[
31
-
(* Any state commands *)
32
-
("CAPABILITY", CAPABILITY);
33
-
("NOOP", NOOP);
34
-
("LOGOUT", LOGOUT);
35
-
("ID", ID);
36
-
(* Not authenticated commands *)
37
-
("STARTTLS", STARTTLS);
38
-
("LOGIN", LOGIN);
39
-
("AUTHENTICATE", AUTHENTICATE);
40
-
(* Authenticated commands *)
41
-
("ENABLE", ENABLE);
42
-
("SELECT", SELECT);
43
-
("EXAMINE", EXAMINE);
44
-
("CREATE", CREATE);
45
-
("DELETE", DELETE);
46
-
("RENAME", RENAME);
47
-
("SUBSCRIBE", SUBSCRIBE);
48
-
("UNSUBSCRIBE", UNSUBSCRIBE);
49
-
("LIST", LIST);
50
-
("NAMESPACE", NAMESPACE);
51
-
("STATUS", STATUS);
52
-
("APPEND", APPEND);
53
-
("IDLE", IDLE);
54
-
(* Selected state commands *)
55
-
("CLOSE", CLOSE);
56
-
("UNSELECT", UNSELECT);
57
-
("EXPUNGE", EXPUNGE);
58
-
("SEARCH", SEARCH);
59
-
("FETCH", FETCH);
60
-
("STORE", STORE);
61
-
("COPY", COPY);
62
-
("MOVE", MOVE);
63
-
("UID", UID);
64
-
(* Fetch attributes *)
65
-
("ENVELOPE", ENVELOPE);
66
-
("FLAGS", FLAGS);
67
-
("INTERNALDATE", INTERNALDATE);
68
-
("RFC822", RFC822);
69
-
("BODY", BODY);
70
-
("BODYSTRUCTURE", BODYSTRUCTURE);
71
-
("BINARY", BINARY);
72
-
("ALL", ALL);
73
-
("FAST", FAST);
74
-
("FULL", FULL);
75
-
(* Status attributes *)
76
-
("MESSAGES", MESSAGES);
77
-
("UIDNEXT", UIDNEXT);
78
-
("UIDVALIDITY", UIDVALIDITY);
79
-
("UNSEEN", UNSEEN);
80
-
("DELETED", DELETED_STATUS);
81
-
("SIZE", SIZE);
82
-
(* Search keys *)
83
-
("ANSWERED", ANSWERED);
84
-
("BCC", BCC);
85
-
("BEFORE", BEFORE);
86
-
("CC", CC);
87
-
("DRAFT", DRAFT);
88
-
("FLAGGED", FLAGGED);
89
-
("FROM", FROM);
90
-
("HEADER", HEADER);
91
-
("KEYWORD", KEYWORD);
92
-
("LARGER", LARGER);
93
-
("NEW", NEW);
94
-
("NOT", NOT);
95
-
("OLD", OLD);
96
-
("ON", ON);
97
-
("OR", OR);
98
-
("SEEN", SEEN);
99
-
("SENTBEFORE", SENTBEFORE);
100
-
("SENTON", SENTON);
101
-
("SENTSINCE", SENTSINCE);
102
-
("SINCE", SINCE);
103
-
("SMALLER", SMALLER);
104
-
("SUBJECT", SUBJECT);
105
-
("TEXT", TEXT);
106
-
("TO", TO);
107
-
("UNANSWERED", UNANSWERED);
108
-
("UNDELETED", UNDELETED);
109
-
("UNDRAFT", UNDRAFT);
110
-
("UNFLAGGED", UNFLAGGED);
111
-
("UNKEYWORD", UNKEYWORD);
112
-
(* Other *)
113
-
("NIL", NIL);
114
-
("CHARSET", CHARSET);
115
-
("MIME", MIME);
116
-
("PEEK", PEEK);
117
-
("HEADER.FIELDS", HEADER_FIELDS);
118
-
("HEADER.FIELDS.NOT", HEADER_FIELDS_NOT);
119
-
("SILENT", SILENT);
120
-
("RETURN", RETURN);
121
-
("SUBSCRIBED", SUBSCRIBED);
122
-
("CHILDREN", CHILDREN);
123
-
("REMOTE", REMOTE);
124
-
("RECURSIVEMATCH", RECURSIVEMATCH);
125
-
("DONE", DONE);
126
-
(* LIST-EXTENDED - RFC 5258, RFC 6154 *)
127
-
("SPECIAL-USE", SPECIAL_USE);
128
-
(* QUOTA extension - RFC 9208 *)
129
-
("GETQUOTA", GETQUOTA);
130
-
("GETQUOTAROOT", GETQUOTAROOT);
131
-
("SETQUOTA", SETQUOTA);
132
-
("STORAGE", STORAGE);
133
-
("MAILBOX", MAILBOX);
134
-
("ANNOTATION-STORAGE", ANNOTATION_STORAGE);
135
-
(* Note: MESSAGE already exists as MESSAGES for STATUS *)
136
-
]
137
-
138
-
let lookup_keyword s =
139
-
let upper = String.uppercase_ascii s in
140
-
try Hashtbl.find keyword_table upper
141
-
with Not_found -> ATOM s
142
-
}
143
-
144
-
(* Character classes per RFC 9051 *)
145
-
let digit = ['0'-'9']
146
-
let nz_digit = ['1'-'9']
147
-
let alpha = ['A'-'Z' 'a'-'z']
148
-
let sp = ' '
149
-
let crlf = "\r\n"
150
-
151
-
(* ATOM-CHAR: any CHAR except atom-specials and grammar-significant chars *)
152
-
(* atom-specials = "(" / ")" / "{" / SP / CTL / list-wildcards / quoted-specials / resp-specials *)
153
-
(* list-wildcards = "%" / "*" *)
154
-
(* quoted-specials = DQUOTE / "\\" *)
155
-
(* resp-specials = "]" *)
156
-
(* Also exclude : , < > which are grammar tokens for sequences and partials *)
157
-
let atom_char = [^ '(' ')' '{' '}' ' ' '\x00'-'\x1f' '\x7f' '%' '*' '"' '\\' ']' '[' ':' ',' '<' '>' '+' '-' '.']
158
-
159
-
(* ASTRING-CHAR: ATOM-CHAR / resp-specials (allows ']') *)
160
-
let astring_char = [^ '(' ')' '{' '}' ' ' '\x00'-'\x1f' '\x7f' '%' '*' '"' '\\' ':' ',' '<' '>' '+' '-' '.']
161
-
162
-
(* TAG: 1*<any ASTRING-CHAR except "+"> *)
163
-
let tag_char = [^ '(' ')' '{' '}' ' ' '\x00'-'\x1f' '\x7f' '%' '*' '"' '\\' '+' ':' ',' '<' '>' '-' '.']
164
-
165
-
rule token = parse
166
-
(* Whitespace - SP is significant in IMAP *)
167
-
| sp { SP }
168
-
| crlf { CRLF }
169
-
170
-
(* Special characters *)
171
-
| '(' { LPAREN }
172
-
| ')' { RPAREN }
173
-
| '[' { LBRACKET }
174
-
| ']' { RBRACKET }
175
-
| '{' { LBRACE }
176
-
| '}' { RBRACE }
177
-
| '*' { STAR }
178
-
| '+' { PLUS }
179
-
| '-' { MINUS }
180
-
| ':' { COLON }
181
-
| ',' { COMMA }
182
-
| '.' { DOT }
183
-
| '<' { LANGLE }
184
-
| '>' { RANGLE }
185
-
186
-
(* System flags - must come before atom *)
187
-
| '\\' (['A'-'Z' 'a'-'z']+ as flag)
188
-
{
189
-
match String.uppercase_ascii flag with
190
-
| "SEEN" -> FLAG_SEEN
191
-
| "ANSWERED" -> FLAG_ANSWERED
192
-
| "FLAGGED" -> FLAG_FLAGGED
193
-
| "DELETED" -> FLAG_DELETED
194
-
| "DRAFT" -> FLAG_DRAFT
195
-
| "RECENT" -> FLAG_RECENT
196
-
| _ -> FLAG_EXTENSION flag
197
-
}
198
-
| "\\*" { FLAG_PERM_ALL }
199
-
200
-
(* Numbers *)
201
-
| nz_digit digit* as n
202
-
{
203
-
try NUMBER (Int64.of_string n)
204
-
with Failure _ -> raise (Lexer_error ("Number too large: " ^ n))
205
-
}
206
-
| '0' { NUMBER 0L }
207
-
208
-
(* Quoted string *)
209
-
| '"'
210
-
{
211
-
Buffer.clear string_buffer;
212
-
quoted_string lexbuf;
213
-
QUOTED_STRING (Buffer.contents string_buffer)
214
-
}
215
-
216
-
(* Literal - returns the count, caller must read the data *)
217
-
| '{' (digit+ as n) '}' crlf
218
-
{
219
-
try LITERAL_START (Int64.of_string n)
220
-
with Failure _ -> raise (Lexer_error ("Literal size too large: " ^ n))
221
-
}
222
-
223
-
(* Literal with + for non-synchronizing - RFC 7888 *)
224
-
| '{' (digit+ as n) '+' '}' crlf
225
-
{
226
-
try LITERAL_START_PLUS (Int64.of_string n)
227
-
with Failure _ -> raise (Lexer_error ("Literal size too large: " ^ n))
228
-
}
229
-
230
-
(* Atoms and keywords *)
231
-
| atom_char+ as s
232
-
{ lookup_keyword s }
233
-
234
-
(* End of input *)
235
-
| eof { EOF }
236
-
237
-
(* Unknown character *)
238
-
| _ as c
239
-
{ raise (Lexer_error (Printf.sprintf "Unexpected character '%c' at %s" c (current_pos lexbuf))) }
240
-
241
-
(* Quoted string contents - handles escapes *)
242
-
and quoted_string = parse
243
-
| '"' { () }
244
-
| '\\' '"' { Buffer.add_char string_buffer '"'; quoted_string lexbuf }
245
-
| '\\' '\\' { Buffer.add_char string_buffer '\\'; quoted_string lexbuf }
246
-
| '\\' _ { raise (Lexer_error "Invalid escape sequence in quoted string") }
247
-
| [^ '"' '\\' '\r' '\n']+ as s
248
-
{ Buffer.add_string string_buffer s; quoted_string lexbuf }
249
-
| eof { raise (Lexer_error "Unterminated quoted string") }
250
-
| _ { raise (Lexer_error "Invalid character in quoted string") }
251
-
252
-
{
253
-
(** Read exactly n bytes for a literal *)
254
-
let read_literal lexbuf n =
255
-
let n = Int64.to_int n in
256
-
let buf = Bytes.create n in
257
-
for i = 0 to n - 1 do
258
-
let c = Lexing.lexeme_char lexbuf 0 in
259
-
Bytes.set buf i c;
260
-
ignore (Lexing.lexeme lexbuf)
261
-
done;
262
-
Bytes.to_string buf
263
-
}
-122
lib/imapd/pam_stubs.c
-122
lib/imapd/pam_stubs.c
···
1
-
/* PAM C stubs for OCaml
2
-
RFC 9051 IMAP server - Authentication via PAM
3
-
4
-
Implements {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.2.3}RFC 9051 Section 6.2.3} LOGIN command authentication.
5
-
*/
6
-
7
-
#include <security/pam_appl.h>
8
-
#include <stdlib.h>
9
-
#include <string.h>
10
-
11
-
#define CAML_NAME_SPACE
12
-
#include <caml/mlvalues.h>
13
-
#include <caml/memory.h>
14
-
#include <caml/alloc.h>
15
-
#include <caml/fail.h>
16
-
17
-
/* Conversation data passed to PAM callback */
18
-
struct conv_data {
19
-
const char *password;
20
-
};
21
-
22
-
/* PAM conversation function - provides password when PAM asks */
23
-
static int pam_conv_func(int num_msg, const struct pam_message **msg,
24
-
struct pam_response **resp, void *appdata_ptr)
25
-
{
26
-
struct conv_data *data = (struct conv_data *)appdata_ptr;
27
-
struct pam_response *reply;
28
-
int i;
29
-
30
-
if (num_msg <= 0 || num_msg > PAM_MAX_NUM_MSG)
31
-
return PAM_CONV_ERR;
32
-
33
-
reply = calloc(num_msg, sizeof(struct pam_response));
34
-
if (reply == NULL)
35
-
return PAM_BUF_ERR;
36
-
37
-
for (i = 0; i < num_msg; i++) {
38
-
switch (msg[i]->msg_style) {
39
-
case PAM_PROMPT_ECHO_OFF:
40
-
case PAM_PROMPT_ECHO_ON:
41
-
/* Provide the password */
42
-
reply[i].resp = strdup(data->password);
43
-
if (reply[i].resp == NULL) {
44
-
/* Free already allocated responses */
45
-
for (int j = 0; j < i; j++) {
46
-
free(reply[j].resp);
47
-
}
48
-
free(reply);
49
-
return PAM_BUF_ERR;
50
-
}
51
-
reply[i].resp_retcode = 0;
52
-
break;
53
-
case PAM_ERROR_MSG:
54
-
case PAM_TEXT_INFO:
55
-
/* Ignore informational messages */
56
-
reply[i].resp = NULL;
57
-
reply[i].resp_retcode = 0;
58
-
break;
59
-
default:
60
-
/* Free already allocated responses */
61
-
for (int j = 0; j < i; j++) {
62
-
free(reply[j].resp);
63
-
}
64
-
free(reply);
65
-
return PAM_CONV_ERR;
66
-
}
67
-
}
68
-
69
-
*resp = reply;
70
-
return PAM_SUCCESS;
71
-
}
72
-
73
-
/* OCaml binding: authenticate username password service_name -> bool */
74
-
CAMLprim value caml_pam_authenticate(value v_service, value v_username, value v_password)
75
-
{
76
-
CAMLparam3(v_service, v_username, v_password);
77
-
78
-
const char *service = String_val(v_service);
79
-
const char *username = String_val(v_username);
80
-
const char *password = String_val(v_password);
81
-
82
-
pam_handle_t *pamh = NULL;
83
-
int retval;
84
-
85
-
struct conv_data data = { .password = password };
86
-
struct pam_conv conv = {
87
-
.conv = pam_conv_func,
88
-
.appdata_ptr = &data
89
-
};
90
-
91
-
/* Start PAM session */
92
-
retval = pam_start(service, username, &conv, &pamh);
93
-
if (retval != PAM_SUCCESS) {
94
-
CAMLreturn(Val_false);
95
-
}
96
-
97
-
/* Authenticate */
98
-
retval = pam_authenticate(pamh, 0);
99
-
if (retval != PAM_SUCCESS) {
100
-
pam_end(pamh, retval);
101
-
CAMLreturn(Val_false);
102
-
}
103
-
104
-
/* Check account validity */
105
-
retval = pam_acct_mgmt(pamh, 0);
106
-
if (retval != PAM_SUCCESS) {
107
-
pam_end(pamh, retval);
108
-
CAMLreturn(Val_false);
109
-
}
110
-
111
-
/* Clean up */
112
-
pam_end(pamh, PAM_SUCCESS);
113
-
CAMLreturn(Val_true);
114
-
}
115
-
116
-
/* OCaml binding: check if PAM is available */
117
-
CAMLprim value caml_pam_available(value unit)
118
-
{
119
-
CAMLparam1(unit);
120
-
/* If we compiled with PAM support, it's available */
121
-
CAMLreturn(Val_true);
122
-
}
-492
lib/imapd/parser.ml
-492
lib/imapd/parser.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** IMAP4rev2 Parser
7
-
8
-
Implements {{:https://datatracker.ietf.org/doc/html/rfc9051#section-9}RFC 9051 Section 9} Formal Syntax.
9
-
10
-
This module uses Menhir for parsing and Faraday for response serialization. *)
11
-
12
-
open Protocol
13
-
14
-
(* Re-export types from Types for backward compatibility *)
15
-
type thread_algorithm = Protocol.thread_algorithm =
16
-
| Thread_orderedsubject
17
-
| Thread_references
18
-
| Thread_extension of string
19
-
20
-
type thread_node = Protocol.thread_node =
21
-
| Thread_message of int * thread_node list
22
-
| Thread_dummy of thread_node list
23
-
24
-
type thread_result = Protocol.thread_result
25
-
26
-
type command = Protocol.command =
27
-
| Capability
28
-
| Noop
29
-
| Logout
30
-
| Starttls
31
-
| Login of { username : string; password : string }
32
-
| Authenticate of { mechanism : string; initial_response : string option }
33
-
| Enable of string list
34
-
| Select of mailbox_name
35
-
| Examine of mailbox_name
36
-
| Create of mailbox_name
37
-
| Delete of mailbox_name
38
-
| Rename of { old_name : mailbox_name; new_name : mailbox_name }
39
-
| Subscribe of mailbox_name
40
-
| Unsubscribe of mailbox_name
41
-
| List of list_command (** LIST command - RFC 9051, RFC 5258 LIST-EXTENDED *)
42
-
| Namespace
43
-
| Status of { mailbox : mailbox_name; items : status_item list }
44
-
| Append of { mailbox : mailbox_name; flags : flag list; date : string option; message : string }
45
-
| Idle
46
-
| Close
47
-
| Unselect
48
-
| Expunge
49
-
| Search of { charset : string option; criteria : search_key }
50
-
| Fetch of { sequence : sequence_set; items : fetch_item list }
51
-
| Store of { sequence : sequence_set; silent : bool; action : store_action; flags : flag list }
52
-
| Copy of { sequence : sequence_set; mailbox : mailbox_name }
53
-
| Move of { sequence : sequence_set; mailbox : mailbox_name }
54
-
| Uid of uid_command
55
-
| Id of (string * string) list option
56
-
(* QUOTA extension - RFC 9208 *)
57
-
| Getquota of string
58
-
| Getquotaroot of mailbox_name
59
-
| Setquota of { root : string; limits : (quota_resource * int64) list }
60
-
(* THREAD extension - RFC 5256 *)
61
-
| Thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
62
-
63
-
type uid_command = Protocol.uid_command =
64
-
| Uid_fetch of { sequence : sequence_set; items : fetch_item list }
65
-
| Uid_store of { sequence : sequence_set; silent : bool; action : store_action; flags : flag list }
66
-
| Uid_copy of { sequence : sequence_set; mailbox : mailbox_name }
67
-
| Uid_move of { sequence : sequence_set; mailbox : mailbox_name }
68
-
| Uid_search of { charset : string option; criteria : search_key }
69
-
| Uid_expunge of sequence_set
70
-
| Uid_thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
71
-
72
-
type tagged_command = Protocol.tagged_command = {
73
-
tag : string;
74
-
command : command;
75
-
}
76
-
77
-
type response = Protocol.response =
78
-
| Ok of { tag : string option; code : response_code option; text : string }
79
-
| No of { tag : string option; code : response_code option; text : string }
80
-
| Bad of { tag : string option; code : response_code option; text : string }
81
-
| Preauth of { code : response_code option; text : string }
82
-
| Bye of { code : response_code option; text : string }
83
-
| Capability_response of string list
84
-
| Enabled of string list
85
-
| List_response of list_response_data (** RFC 9051, RFC 5258 LIST-EXTENDED *)
86
-
| Namespace_response of namespace_data
87
-
| Status_response of { mailbox : mailbox_name; items : (status_item * int64) list }
88
-
| Esearch of { tag : string option; uid : bool; results : esearch_result list }
89
-
| Flags_response of flag list
90
-
| Exists of int
91
-
| Expunge_response of int
92
-
| Fetch_response of { seq : int; items : fetch_response_item list }
93
-
| Continuation of string option
94
-
| Id_response of (string * string) list option
95
-
(* QUOTA extension responses - RFC 9208 *)
96
-
| Quota_response of { root : string; resources : quota_resource_info list }
97
-
| Quotaroot_response of { mailbox : mailbox_name; roots : string list }
98
-
(* THREAD extension response - RFC 5256 *)
99
-
| Thread_response of thread_result
100
-
101
-
(* ===== Menhir Parser Interface ===== *)
102
-
103
-
let parse_command input =
104
-
let lexbuf = Lexing.from_string input in
105
-
try
106
-
Result.Ok (Grammar.command Lexer.token lexbuf)
107
-
with
108
-
| Lexer.Lexer_error msg -> Result.Error ("Lexer error: " ^ msg)
109
-
| Grammar.Error ->
110
-
let pos = lexbuf.Lexing.lex_curr_p in
111
-
Result.Error (Printf.sprintf "Parse error at line %d, column %d"
112
-
pos.Lexing.pos_lnum
113
-
(pos.Lexing.pos_cnum - pos.Lexing.pos_bol))
114
-
115
-
(* ===== Faraday Response Serializer ===== *)
116
-
117
-
let crlf = "\r\n"
118
-
119
-
let write_string f s = Faraday.write_string f s
120
-
let write_char f c = Faraday.write_char f c
121
-
let write_sp f = write_char f ' '
122
-
let write_crlf f = write_string f crlf
123
-
124
-
let write_quoted_string f s =
125
-
write_char f '"';
126
-
String.iter (fun c ->
127
-
match c with
128
-
| '"' | '\\' -> write_char f '\\'; write_char f c
129
-
| _ -> write_char f c
130
-
) s;
131
-
write_char f '"'
132
-
133
-
let write_literal f s =
134
-
write_char f '{';
135
-
write_string f (string_of_int (String.length s));
136
-
write_string f "}\r\n";
137
-
write_string f s
138
-
139
-
(** Convert quota resource to IMAP string.
140
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5}RFC 9208 Section 5}. *)
141
-
let quota_resource_to_string = function
142
-
| Quota_storage -> "STORAGE"
143
-
| Quota_message -> "MESSAGE"
144
-
| Quota_mailbox -> "MAILBOX"
145
-
| Quota_annotation_storage -> "ANNOTATION-STORAGE"
146
-
147
-
let write_flag f flag =
148
-
write_string f (flag_to_string flag)
149
-
150
-
let write_flag_list f flags =
151
-
write_char f '(';
152
-
List.iteri (fun i flag ->
153
-
if i > 0 then write_sp f;
154
-
write_flag f flag
155
-
) flags;
156
-
write_char f ')'
157
-
158
-
let write_response_code f code =
159
-
write_char f '[';
160
-
(match code with
161
-
| Code_alert -> write_string f "ALERT"
162
-
| Code_alreadyexists -> write_string f "ALREADYEXISTS"
163
-
| Code_capability caps ->
164
-
write_string f "CAPABILITY";
165
-
List.iter (fun c -> write_sp f; write_string f c) caps
166
-
| Code_permanentflags flags ->
167
-
write_string f "PERMANENTFLAGS ";
168
-
write_flag_list f flags
169
-
| Code_readonly -> write_string f "READ-ONLY"
170
-
| Code_readwrite -> write_string f "READ-WRITE"
171
-
| Code_uidvalidity v ->
172
-
write_string f "UIDVALIDITY ";
173
-
write_string f (Int32.to_string v)
174
-
| Code_uidnext u ->
175
-
write_string f "UIDNEXT ";
176
-
write_string f (Int32.to_string u)
177
-
| Code_appenduid (v, u) ->
178
-
write_string f "APPENDUID ";
179
-
write_string f (Int32.to_string v);
180
-
write_sp f;
181
-
write_string f (Int32.to_string u)
182
-
| Code_trycreate -> write_string f "TRYCREATE"
183
-
| Code_nonexistent -> write_string f "NONEXISTENT"
184
-
| Code_authenticationfailed -> write_string f "AUTHENTICATIONFAILED"
185
-
| Code_authorizationfailed -> write_string f "AUTHORIZATIONFAILED"
186
-
| Code_parse -> write_string f "PARSE"
187
-
| Code_closed -> write_string f "CLOSED"
188
-
| Code_cannot -> write_string f "CANNOT"
189
-
| Code_noperm -> write_string f "NOPERM"
190
-
| Code_overquota -> write_string f "OVERQUOTA"
191
-
| Code_inuse -> write_string f "INUSE"
192
-
| Code_haschildren -> write_string f "HASCHILDREN"
193
-
| Code_serverbug -> write_string f "SERVERBUG"
194
-
| Code_clientbug -> write_string f "CLIENTBUG"
195
-
| Code_other (name, value) ->
196
-
write_string f name;
197
-
(match value with Some v -> write_sp f; write_string f v | None -> ())
198
-
| _ -> write_string f "UNKNOWN");
199
-
write_char f ']';
200
-
write_sp f
201
-
202
-
let serialize_response f resp =
203
-
match resp with
204
-
| Ok { tag; code; text } ->
205
-
(match tag with
206
-
| Some t -> write_string f t; write_sp f
207
-
| None -> write_string f "* ");
208
-
write_string f "OK ";
209
-
(match code with Some c -> write_response_code f c | None -> ());
210
-
write_string f text;
211
-
write_crlf f
212
-
213
-
| No { tag; code; text } ->
214
-
(match tag with
215
-
| Some t -> write_string f t; write_sp f
216
-
| None -> write_string f "* ");
217
-
write_string f "NO ";
218
-
(match code with Some c -> write_response_code f c | None -> ());
219
-
write_string f text;
220
-
write_crlf f
221
-
222
-
| Bad { tag; code; text } ->
223
-
(match tag with
224
-
| Some t -> write_string f t; write_sp f
225
-
| None -> write_string f "* ");
226
-
write_string f "BAD ";
227
-
(match code with Some c -> write_response_code f c | None -> ());
228
-
write_string f text;
229
-
write_crlf f
230
-
231
-
| Preauth { code; text } ->
232
-
write_string f "* PREAUTH ";
233
-
(match code with Some c -> write_response_code f c | None -> ());
234
-
write_string f text;
235
-
write_crlf f
236
-
237
-
| Bye { code; text } ->
238
-
write_string f "* BYE ";
239
-
(match code with Some c -> write_response_code f c | None -> ());
240
-
write_string f text;
241
-
write_crlf f
242
-
243
-
| Capability_response caps ->
244
-
write_string f "* CAPABILITY";
245
-
List.iter (fun c -> write_sp f; write_string f c) caps;
246
-
write_crlf f
247
-
248
-
| Enabled caps ->
249
-
write_string f "* ENABLED";
250
-
List.iter (fun c -> write_sp f; write_string f c) caps;
251
-
write_crlf f
252
-
253
-
| List_response { flags; delimiter; name; extended } ->
254
-
(* LIST response per RFC 9051 Section 7.3.1, RFC 5258 Section 3.4 *)
255
-
write_string f "* LIST (";
256
-
List.iteri (fun i flag ->
257
-
if i > 0 then write_sp f;
258
-
match flag with
259
-
| List_noinferiors -> write_string f "\\Noinferiors"
260
-
| List_noselect -> write_string f "\\Noselect"
261
-
| List_marked -> write_string f "\\Marked"
262
-
| List_unmarked -> write_string f "\\Unmarked"
263
-
| List_subscribed -> write_string f "\\Subscribed"
264
-
| List_haschildren -> write_string f "\\HasChildren"
265
-
| List_hasnochildren -> write_string f "\\HasNoChildren"
266
-
| List_nonexistent -> write_string f "\\NonExistent" (* RFC 5258 Section 3.4 *)
267
-
| List_remote -> write_string f "\\Remote" (* RFC 5258 Section 3.4 *)
268
-
| List_all -> write_string f "\\All"
269
-
| List_archive -> write_string f "\\Archive"
270
-
| List_drafts -> write_string f "\\Drafts"
271
-
| List_flagged -> write_string f "\\Flagged"
272
-
| List_junk -> write_string f "\\Junk"
273
-
| List_sent -> write_string f "\\Sent"
274
-
| List_trash -> write_string f "\\Trash"
275
-
| List_extension s -> write_string f s
276
-
) flags;
277
-
write_string f ") ";
278
-
(match delimiter with
279
-
| Some d -> write_quoted_string f (String.make 1 d)
280
-
| None -> write_string f "NIL");
281
-
write_sp f;
282
-
write_quoted_string f name;
283
-
(* Extended data per RFC 5258 Section 3.5 *)
284
-
List.iter (fun ext ->
285
-
match ext with
286
-
| Childinfo subscriptions ->
287
-
(* CHILDINFO extended data item: "CHILDINFO" SP "(" tag-list ")" *)
288
-
write_sp f;
289
-
write_string f "(\"CHILDINFO\" (";
290
-
List.iteri (fun i tag ->
291
-
if i > 0 then write_sp f;
292
-
write_quoted_string f tag
293
-
) subscriptions;
294
-
write_string f "))"
295
-
) extended;
296
-
write_crlf f
297
-
298
-
| Namespace_response { personal; other; shared } ->
299
-
let write_namespace ns =
300
-
match ns with
301
-
| None -> write_string f "NIL"
302
-
| Some entries ->
303
-
write_char f '(';
304
-
List.iteri (fun i entry ->
305
-
if i > 0 then write_sp f;
306
-
write_char f '(';
307
-
write_quoted_string f entry.prefix;
308
-
write_sp f;
309
-
(match entry.delimiter with
310
-
| Some d -> write_quoted_string f (String.make 1 d)
311
-
| None -> write_string f "NIL");
312
-
write_char f ')'
313
-
) entries;
314
-
write_char f ')'
315
-
in
316
-
write_string f "* NAMESPACE ";
317
-
write_namespace personal;
318
-
write_sp f;
319
-
write_namespace other;
320
-
write_sp f;
321
-
write_namespace shared;
322
-
write_crlf f
323
-
324
-
| Status_response { mailbox; items } ->
325
-
write_string f "* STATUS ";
326
-
write_quoted_string f mailbox;
327
-
write_string f " (";
328
-
List.iteri (fun i (item, value) ->
329
-
if i > 0 then write_sp f;
330
-
(match item with
331
-
| Status_messages -> write_string f "MESSAGES"
332
-
| Status_uidnext -> write_string f "UIDNEXT"
333
-
| Status_uidvalidity -> write_string f "UIDVALIDITY"
334
-
| Status_unseen -> write_string f "UNSEEN"
335
-
| Status_deleted -> write_string f "DELETED"
336
-
| Status_size -> write_string f "SIZE");
337
-
write_sp f;
338
-
write_string f (Int64.to_string value)
339
-
) items;
340
-
write_char f ')';
341
-
write_crlf f
342
-
343
-
| Esearch { tag = _; uid; results } ->
344
-
write_string f "* ESEARCH";
345
-
if uid then write_string f " UID";
346
-
List.iter (fun r ->
347
-
write_sp f;
348
-
match r with
349
-
| Esearch_min n -> write_string f "MIN "; write_string f (string_of_int n)
350
-
| Esearch_max n -> write_string f "MAX "; write_string f (string_of_int n)
351
-
| Esearch_count n -> write_string f "COUNT "; write_string f (string_of_int n)
352
-
| Esearch_all _ -> write_string f "ALL ..."
353
-
) results;
354
-
write_crlf f
355
-
356
-
| Flags_response flags ->
357
-
write_string f "* FLAGS ";
358
-
write_flag_list f flags;
359
-
write_crlf f
360
-
361
-
| Exists n ->
362
-
write_string f "* ";
363
-
write_string f (string_of_int n);
364
-
write_string f " EXISTS";
365
-
write_crlf f
366
-
367
-
| Expunge_response n ->
368
-
write_string f "* ";
369
-
write_string f (string_of_int n);
370
-
write_string f " EXPUNGE";
371
-
write_crlf f
372
-
373
-
| Fetch_response { seq; items } ->
374
-
write_string f "* ";
375
-
write_string f (string_of_int seq);
376
-
write_string f " FETCH (";
377
-
List.iteri (fun i item ->
378
-
if i > 0 then write_sp f;
379
-
match item with
380
-
| Fetch_item_flags flags ->
381
-
write_string f "FLAGS ";
382
-
write_flag_list f flags
383
-
| Fetch_item_uid uid ->
384
-
write_string f "UID ";
385
-
write_string f (Int32.to_string uid)
386
-
| Fetch_item_internaldate date ->
387
-
write_string f "INTERNALDATE ";
388
-
write_quoted_string f date
389
-
| Fetch_item_rfc822_size size ->
390
-
write_string f "RFC822.SIZE ";
391
-
write_string f (Int64.to_string size)
392
-
| Fetch_item_body_section { section = _; origin; data } ->
393
-
write_string f "BODY[] ";
394
-
(match origin with Some o -> write_string f ("<" ^ string_of_int o ^ "> ") | None -> ());
395
-
(match data with Some d -> write_literal f d | None -> write_string f "NIL")
396
-
| _ -> write_string f "..."
397
-
) items;
398
-
write_char f ')';
399
-
write_crlf f
400
-
401
-
| Continuation text ->
402
-
write_string f "+ ";
403
-
(match text with Some t -> write_string f t | None -> ());
404
-
write_crlf f
405
-
406
-
| Id_response params ->
407
-
write_string f "* ID ";
408
-
(match params with
409
-
| None -> write_string f "NIL"
410
-
| Some pairs ->
411
-
write_char f '(';
412
-
let first = ref true in
413
-
List.iter (fun (key, value) ->
414
-
if not !first then write_sp f;
415
-
first := false;
416
-
write_quoted_string f key;
417
-
write_sp f;
418
-
write_quoted_string f value
419
-
) pairs;
420
-
write_char f ')');
421
-
write_crlf f
422
-
423
-
(* QUOTA extension responses - RFC 9208 *)
424
-
| Quota_response { root; resources } ->
425
-
(* QUOTA response format: * QUOTA root (resource usage limit ...) *)
426
-
write_string f "* QUOTA ";
427
-
write_quoted_string f root;
428
-
write_string f " (";
429
-
List.iteri (fun i { resource; usage; limit } ->
430
-
if i > 0 then write_sp f;
431
-
write_string f (quota_resource_to_string resource);
432
-
write_sp f;
433
-
write_string f (Int64.to_string usage);
434
-
write_sp f;
435
-
write_string f (Int64.to_string limit)
436
-
) resources;
437
-
write_char f ')';
438
-
write_crlf f
439
-
440
-
| Quotaroot_response { mailbox; roots } ->
441
-
(* QUOTAROOT response format: * QUOTAROOT mailbox root ... *)
442
-
write_string f "* QUOTAROOT ";
443
-
write_quoted_string f mailbox;
444
-
List.iter (fun root ->
445
-
write_sp f;
446
-
write_quoted_string f root
447
-
) roots;
448
-
write_crlf f
449
-
450
-
(* THREAD extension response - RFC 5256 Section 4 *)
451
-
| Thread_response threads ->
452
-
(* THREAD response format: * THREAD [SP 1*thread-list]
453
-
Each thread node is either:
454
-
- (n) for a single message
455
-
- (n children...) for a message with children
456
-
- ((children...)) for a dummy parent
457
-
@see <https://datatracker.ietf.org/doc/html/rfc5256#section-4> RFC 5256 Section 4 *)
458
-
let rec write_thread_node = function
459
-
| Thread_message (n, []) ->
460
-
(* Single message with no children: (n) *)
461
-
write_char f '(';
462
-
write_string f (string_of_int n);
463
-
write_char f ')'
464
-
| Thread_message (n, children) ->
465
-
(* Message with children: (n child1 child2 ...) *)
466
-
write_char f '(';
467
-
write_string f (string_of_int n);
468
-
List.iter (fun child ->
469
-
write_sp f;
470
-
write_thread_node child
471
-
) children;
472
-
write_char f ')'
473
-
| Thread_dummy children ->
474
-
(* Dummy node (missing parent): ((child1)(child2)...) *)
475
-
write_char f '(';
476
-
List.iteri (fun i child ->
477
-
if i > 0 then write_sp f;
478
-
write_thread_node child
479
-
) children;
480
-
write_char f ')'
481
-
in
482
-
write_string f "* THREAD";
483
-
List.iter (fun thread ->
484
-
write_sp f;
485
-
write_thread_node thread
486
-
) threads;
487
-
write_crlf f
488
-
489
-
let response_to_string resp =
490
-
let f = Faraday.create 256 in
491
-
serialize_response f resp;
492
-
Faraday.serialize_to_string f
-114
lib/imapd/parser.mli
-114
lib/imapd/parser.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** IMAP4rev2 Parser
7
-
8
-
Implements {{:https://datatracker.ietf.org/doc/html/rfc9051#section-9}RFC 9051 Section 9} Formal Syntax.
9
-
10
-
This module uses Menhir for parsing and Faraday for response serialization. *)
11
-
12
-
open Protocol
13
-
14
-
(** {1 Type Re-exports}
15
-
16
-
Types are defined in {!Protocol} and re-exported here for convenience. *)
17
-
18
-
type thread_algorithm = Protocol.thread_algorithm =
19
-
| Thread_orderedsubject
20
-
| Thread_references
21
-
| Thread_extension of string
22
-
23
-
type command = Protocol.command =
24
-
| Capability
25
-
| Noop
26
-
| Logout
27
-
| Starttls
28
-
| Login of { username : string; password : string }
29
-
| Authenticate of { mechanism : string; initial_response : string option }
30
-
| Enable of string list
31
-
| Select of mailbox_name
32
-
| Examine of mailbox_name
33
-
| Create of mailbox_name
34
-
| Delete of mailbox_name
35
-
| Rename of { old_name : mailbox_name; new_name : mailbox_name }
36
-
| Subscribe of mailbox_name
37
-
| Unsubscribe of mailbox_name
38
-
| List of list_command
39
-
| Namespace
40
-
| Status of { mailbox : mailbox_name; items : status_item list }
41
-
| Append of { mailbox : mailbox_name; flags : flag list; date : string option; message : string }
42
-
| Idle
43
-
| Close
44
-
| Unselect
45
-
| Expunge
46
-
| Search of { charset : string option; criteria : search_key }
47
-
| Fetch of { sequence : sequence_set; items : fetch_item list }
48
-
| Store of { sequence : sequence_set; silent : bool; action : store_action; flags : flag list }
49
-
| Copy of { sequence : sequence_set; mailbox : mailbox_name }
50
-
| Move of { sequence : sequence_set; mailbox : mailbox_name }
51
-
| Uid of uid_command
52
-
| Id of (string * string) list option
53
-
(* QUOTA extension - RFC 9208 *)
54
-
| Getquota of string
55
-
| Getquotaroot of mailbox_name
56
-
| Setquota of { root : string; limits : (quota_resource * int64) list }
57
-
(* THREAD extension - RFC 5256 *)
58
-
| Thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
59
-
60
-
type uid_command = Protocol.uid_command =
61
-
| Uid_fetch of { sequence : sequence_set; items : fetch_item list }
62
-
| Uid_store of { sequence : sequence_set; silent : bool; action : store_action; flags : flag list }
63
-
| Uid_copy of { sequence : sequence_set; mailbox : mailbox_name }
64
-
| Uid_move of { sequence : sequence_set; mailbox : mailbox_name }
65
-
| Uid_search of { charset : string option; criteria : search_key }
66
-
| Uid_expunge of sequence_set
67
-
| Uid_thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
68
-
69
-
type tagged_command = Protocol.tagged_command = {
70
-
tag : string;
71
-
command : command;
72
-
}
73
-
74
-
type response = Protocol.response =
75
-
| Ok of { tag : string option; code : response_code option; text : string }
76
-
| No of { tag : string option; code : response_code option; text : string }
77
-
| Bad of { tag : string option; code : response_code option; text : string }
78
-
| Preauth of { code : response_code option; text : string }
79
-
| Bye of { code : response_code option; text : string }
80
-
| Capability_response of string list
81
-
| Enabled of string list
82
-
| List_response of list_response_data
83
-
| Namespace_response of namespace_data
84
-
| Status_response of { mailbox : mailbox_name; items : (status_item * int64) list }
85
-
| Esearch of { tag : string option; uid : bool; results : esearch_result list }
86
-
| Flags_response of flag list
87
-
| Exists of int
88
-
| Expunge_response of int
89
-
| Fetch_response of { seq : int; items : fetch_response_item list }
90
-
| Continuation of string option
91
-
| Id_response of (string * string) list option
92
-
(* QUOTA extension responses - RFC 9208 *)
93
-
| Quota_response of { root : string; resources : quota_resource_info list }
94
-
| Quotaroot_response of { mailbox : mailbox_name; roots : string list }
95
-
(* THREAD extension response - RFC 5256 *)
96
-
| Thread_response of thread_result
97
-
98
-
(** {1 Parsing} *)
99
-
100
-
val parse_command : string -> (tagged_command, string) result
101
-
(** Parse a complete IMAP command line. *)
102
-
103
-
(** {1 Serialization} *)
104
-
105
-
val serialize_response : Faraday.t -> response -> unit
106
-
(** Serialize a response to a Faraday buffer. *)
107
-
108
-
val response_to_string : response -> string
109
-
(** Convert response to string. *)
110
-
111
-
(** {1 Utilities} *)
112
-
113
-
val crlf : string
114
-
(** CRLF line ending. *)
-555
lib/imapd/protocol.ml
-555
lib/imapd/protocol.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** IMAP4rev2 Core Types
7
-
8
-
Implements types from {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051}. *)
9
-
10
-
(* Basic types *)
11
-
type mailbox_name = string
12
-
type uid = int32
13
-
type seq_num = int
14
-
type uidvalidity = int32
15
-
16
-
(* Message flags - RFC 9051 Section 2.3.2 *)
17
-
type system_flag =
18
-
| Seen
19
-
| Answered
20
-
| Flagged
21
-
| Deleted
22
-
| Draft
23
-
24
-
type flag =
25
-
| System of system_flag
26
-
| Keyword of string
27
-
28
-
(* Email addresses *)
29
-
type address = {
30
-
name : string option;
31
-
adl : string option;
32
-
mailbox : string option;
33
-
host : string option;
34
-
}
35
-
36
-
(* Message envelope - RFC 9051 Section 2.3.5 *)
37
-
type envelope = {
38
-
date : string option;
39
-
subject : string option;
40
-
from : address list;
41
-
sender : address list;
42
-
reply_to : address list;
43
-
to_ : address list;
44
-
cc : address list;
45
-
bcc : address list;
46
-
in_reply_to : string option;
47
-
message_id : string option;
48
-
}
49
-
50
-
(* Body structure - RFC 9051 Section 2.3.6 *)
51
-
type body_fields = {
52
-
params : (string * string) list;
53
-
content_id : string option;
54
-
description : string option;
55
-
encoding : string;
56
-
size : int64;
57
-
}
58
-
59
-
type body_type =
60
-
| Text of {
61
-
subtype : string;
62
-
fields : body_fields;
63
-
lines : int64;
64
-
}
65
-
| Message_rfc822 of {
66
-
fields : body_fields;
67
-
envelope : envelope;
68
-
body : body_structure;
69
-
lines : int64;
70
-
}
71
-
| Basic of {
72
-
media_type : string;
73
-
subtype : string;
74
-
fields : body_fields;
75
-
}
76
-
| Multipart of {
77
-
subtype : string;
78
-
parts : body_structure list;
79
-
params : (string * string) list;
80
-
}
81
-
82
-
and body_structure = {
83
-
body_type : body_type;
84
-
disposition : (string * (string * string) list) option;
85
-
language : string list option;
86
-
location : string option;
87
-
}
88
-
89
-
(* Sequence sets - RFC 9051 Section 4.1.1 *)
90
-
type sequence_range =
91
-
| Single of int
92
-
| Range of int * int
93
-
| From of int
94
-
| All
95
-
96
-
type sequence_set = sequence_range list
97
-
98
-
(* Section specification for BODY[...] - RFC 9051 Section 6.4.5 *)
99
-
type section_spec =
100
-
| Section_header
101
-
| Section_header_fields of string list
102
-
| Section_header_fields_not of string list
103
-
| Section_text
104
-
| Section_mime
105
-
| Section_part of int list * section_spec option
106
-
107
-
type body_section = {
108
-
section : section_spec option;
109
-
partial : (int * int) option;
110
-
}
111
-
112
-
(* FETCH items - RFC 9051 Section 6.4.5 *)
113
-
type fetch_item =
114
-
| Fetch_envelope
115
-
| Fetch_flags
116
-
| Fetch_internaldate
117
-
| Fetch_rfc822
118
-
| Fetch_rfc822_size
119
-
| Fetch_rfc822_header
120
-
| Fetch_rfc822_text
121
-
| Fetch_uid
122
-
| Fetch_body
123
-
| Fetch_bodystructure
124
-
| Fetch_body_section of string * (int * int) option (* section string, partial *)
125
-
| Fetch_body_peek of string * (int * int) option
126
-
| Fetch_binary of string * (int * int) option
127
-
| Fetch_binary_peek of string * (int * int) option
128
-
| Fetch_binary_size of string
129
-
130
-
(* SEARCH criteria - RFC 9051 Section 6.4.4 *)
131
-
type search_key =
132
-
| Search_all
133
-
| Search_answered
134
-
| Search_bcc of string
135
-
| Search_before of string
136
-
| Search_body of string
137
-
| Search_cc of string
138
-
| Search_deleted
139
-
| Search_flagged
140
-
| Search_from of string
141
-
| Search_keyword of string
142
-
| Search_new
143
-
| Search_not of search_key
144
-
| Search_old
145
-
| Search_on of string
146
-
| Search_or of search_key * search_key
147
-
| Search_seen
148
-
| Search_since of string
149
-
| Search_subject of string
150
-
| Search_text of string
151
-
| Search_to of string
152
-
| Search_unanswered
153
-
| Search_undeleted
154
-
| Search_unflagged
155
-
| Search_unkeyword of string
156
-
| Search_unseen
157
-
| Search_draft
158
-
| Search_undraft
159
-
| Search_header of string * string
160
-
| Search_larger of int64
161
-
| Search_smaller of int64
162
-
| Search_uid of sequence_set
163
-
| Search_sequence_set of sequence_set
164
-
| Search_and of search_key list
165
-
| Search_sentbefore of string
166
-
| Search_senton of string
167
-
| Search_sentsince of string
168
-
169
-
(* STORE actions - RFC 9051 Section 6.4.6 *)
170
-
type store_action =
171
-
| Store_set
172
-
| Store_add
173
-
| Store_remove
174
-
175
-
type store_silent = bool
176
-
177
-
(* STATUS items - RFC 9051 Section 6.3.11 *)
178
-
type status_item =
179
-
| Status_messages
180
-
| Status_uidnext
181
-
| Status_uidvalidity
182
-
| Status_unseen
183
-
| Status_deleted
184
-
| Status_size
185
-
186
-
(* LIST flags - RFC 9051 Section 7.3.1, RFC 5258 Section 3.4 *)
187
-
type list_flag =
188
-
| List_noinferiors
189
-
| List_noselect
190
-
| List_marked
191
-
| List_unmarked
192
-
| List_subscribed
193
-
| List_haschildren
194
-
| List_hasnochildren
195
-
| List_nonexistent (** RFC 5258 Section 3.4 - Mailbox name refers to non-existent mailbox *)
196
-
| List_remote (** RFC 5258 Section 3.4 - Mailbox is remote, not on this server *)
197
-
| List_all
198
-
| List_archive
199
-
| List_drafts
200
-
| List_flagged
201
-
| List_junk
202
-
| List_sent
203
-
| List_trash
204
-
| List_extension of string
205
-
206
-
(** LIST selection options per RFC 5258 Section 3.1
207
-
208
-
Selection options control which mailboxes are returned by LIST:
209
-
- SUBSCRIBED: Return subscribed mailboxes (like LSUB)
210
-
- REMOTE: Include remote mailboxes (not on this server)
211
-
- RECURSIVEMATCH: Include ancestors of matched mailboxes
212
-
- SPECIAL-USE: Return only special-use mailboxes (RFC 6154) *)
213
-
type list_select_option =
214
-
| List_select_subscribed (** RFC 5258 Section 3.1.1 *)
215
-
| List_select_remote (** RFC 5258 Section 3.1.2 *)
216
-
| List_select_recursivematch (** RFC 5258 Section 3.1.3 *)
217
-
| List_select_special_use (** RFC 6154 Section 3 *)
218
-
219
-
(** LIST return options per RFC 5258 Section 3.2
220
-
221
-
Return options control what additional data is returned:
222
-
- SUBSCRIBED: Include \Subscribed flag
223
-
- CHILDREN: Include \HasChildren/\HasNoChildren flags
224
-
- SPECIAL-USE: Include special-use flags (RFC 6154) *)
225
-
type list_return_option =
226
-
| List_return_subscribed (** RFC 5258 Section 3.2.1 *)
227
-
| List_return_children (** RFC 5258 Section 3.2.2 *)
228
-
| List_return_special_use (** RFC 6154 Section 3 *)
229
-
230
-
(** Extended data items in LIST response per RFC 5258 Section 3.5 *)
231
-
type list_extended_item =
232
-
| Childinfo of string list (** RFC 5258 Section 3.5 - CHILDINFO extended data *)
233
-
234
-
(** LIST command variants per RFC 5258 *)
235
-
type list_command =
236
-
| List_basic of {
237
-
reference : string; (** Reference name (context for pattern) *)
238
-
pattern : string; (** Mailbox pattern with wildcards *)
239
-
}
240
-
| List_extended of {
241
-
selection : list_select_option list; (** RFC 5258 Section 3.1 *)
242
-
reference : string;
243
-
patterns : string list; (** Multiple patterns allowed *)
244
-
return_opts : list_return_option list; (** RFC 5258 Section 3.2 *)
245
-
}
246
-
247
-
(** Extended LIST response per RFC 5258 Section 3.4 *)
248
-
type list_response_data = {
249
-
flags : list_flag list;
250
-
delimiter : char option;
251
-
name : mailbox_name;
252
-
extended : list_extended_item list; (** RFC 5258 Section 3.5 *)
253
-
}
254
-
255
-
(* Connection state - RFC 9051 Section 3 *)
256
-
type connection_state =
257
-
| Not_authenticated
258
-
| Authenticated of { username : string }
259
-
| Selected of { username : string; mailbox : mailbox_name; readonly : bool }
260
-
| Logout
261
-
262
-
(* Mailbox state *)
263
-
type mailbox_state = {
264
-
name : mailbox_name;
265
-
exists : int;
266
-
uidvalidity : uidvalidity;
267
-
uidnext : uid;
268
-
flags : flag list;
269
-
permanent_flags : flag list;
270
-
readonly : bool;
271
-
}
272
-
273
-
(* Message representation *)
274
-
type message = {
275
-
uid : uid;
276
-
seq : seq_num;
277
-
flags : flag list;
278
-
internal_date : string;
279
-
size : int64;
280
-
envelope : envelope option;
281
-
body_structure : body_structure option;
282
-
raw_headers : string option;
283
-
raw_body : string option;
284
-
}
285
-
286
-
(* Response codes - RFC 9051 Section 7.1 *)
287
-
type response_code =
288
-
| Code_alert
289
-
| Code_alreadyexists
290
-
| Code_appenduid of uidvalidity * uid
291
-
| Code_authenticationfailed
292
-
| Code_authorizationfailed
293
-
| Code_badcharset of string list
294
-
| Code_cannot
295
-
| Code_capability of string list
296
-
| Code_clientbug
297
-
| Code_closed
298
-
| Code_contactadmin
299
-
| Code_copyuid of uidvalidity * sequence_set * sequence_set
300
-
| Code_corruption
301
-
| Code_expired
302
-
| Code_expungeissued
303
-
| Code_haschildren
304
-
| Code_inuse
305
-
| Code_limit
306
-
| Code_nonexistent
307
-
| Code_noperm
308
-
| Code_overquota
309
-
| Code_parse
310
-
| Code_permanentflags of flag list
311
-
| Code_privacyrequired
312
-
| Code_readonly
313
-
| Code_readwrite
314
-
| Code_serverbug
315
-
| Code_trycreate
316
-
| Code_uidnotsticky
317
-
| Code_uidvalidity of uidvalidity
318
-
| Code_uidnext of uid
319
-
| Code_unavailable
320
-
| Code_unknown_cte
321
-
| Code_other of string * string option
322
-
323
-
(* Utility functions *)
324
-
325
-
(** Validate a username for path safety.
326
-
Prevents path traversal attacks by rejecting dangerous characters. *)
327
-
let is_safe_username username =
328
-
let len = String.length username in
329
-
if len = 0 || len > 256 then false
330
-
else
331
-
(* Reject null bytes, path separators, and path traversal *)
332
-
not (String.contains username '\x00') &&
333
-
not (String.contains username '/') &&
334
-
not (String.contains username '\\') &&
335
-
username <> "." &&
336
-
username <> ".." &&
337
-
(* Reject leading/trailing dots and spaces *)
338
-
username.[0] <> '.' &&
339
-
username.[len - 1] <> '.' &&
340
-
username.[0] <> ' ' &&
341
-
username.[len - 1] <> ' '
342
-
343
-
(** Validate a mailbox name for path safety.
344
-
Prevents path traversal attacks. Allows '/' as hierarchy delimiter. *)
345
-
let is_safe_mailbox_name name =
346
-
let len = String.length name in
347
-
if len = 0 || len > 1024 then false
348
-
else
349
-
(* Reject null bytes and backslashes *)
350
-
not (String.contains name '\x00') &&
351
-
not (String.contains name '\\') &&
352
-
(* Reject path components that are . or .. *)
353
-
let parts = String.split_on_char '/' name in
354
-
not (List.exists (fun p -> p = "." || p = "..") parts)
355
-
356
-
let normalize_mailbox_name name =
357
-
if String.uppercase_ascii name = "INBOX" then "INBOX"
358
-
else name
359
-
360
-
let is_inbox name =
361
-
String.uppercase_ascii name = "INBOX"
362
-
363
-
let system_flag_to_string = function
364
-
| Seen -> "\\Seen"
365
-
| Answered -> "\\Answered"
366
-
| Flagged -> "\\Flagged"
367
-
| Deleted -> "\\Deleted"
368
-
| Draft -> "\\Draft"
369
-
370
-
let flag_to_string = function
371
-
| System sf -> system_flag_to_string sf
372
-
| Keyword kw -> kw
373
-
374
-
let string_to_flag s =
375
-
let s_upper = String.uppercase_ascii s in
376
-
match s_upper with
377
-
| "\\SEEN" -> Some (System Seen)
378
-
| "\\ANSWERED" -> Some (System Answered)
379
-
| "\\FLAGGED" -> Some (System Flagged)
380
-
| "\\DELETED" -> Some (System Deleted)
381
-
| "\\DRAFT" -> Some (System Draft)
382
-
| _ ->
383
-
if String.length s > 0 && s.[0] <> '\\' then
384
-
Some (Keyword s)
385
-
else
386
-
None
387
-
388
-
(* === THREAD Types - RFC 5256 === *)
389
-
390
-
(** Threading algorithm for the THREAD command.
391
-
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-3}RFC 5256 Section 3}. *)
392
-
type thread_algorithm =
393
-
| Thread_orderedsubject
394
-
(** ORDEREDSUBJECT algorithm (RFC 5256 Section 3.1).
395
-
Groups messages by base subject, then sorts by sent date. *)
396
-
| Thread_references
397
-
(** REFERENCES algorithm (RFC 5256 Section 3.2).
398
-
Implements the JWZ threading algorithm using Message-ID,
399
-
In-Reply-To, and References headers. *)
400
-
| Thread_extension of string
401
-
(** Future algorithm extensions. *)
402
-
403
-
(** A thread node in the THREAD response.
404
-
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-4}RFC 5256 Section 4}. *)
405
-
type thread_node =
406
-
| Thread_message of int * thread_node list
407
-
(** A message with its sequence number/UID and child threads. *)
408
-
| Thread_dummy of thread_node list
409
-
(** A placeholder for a missing parent message. *)
410
-
411
-
(** Thread result: a list of root-level thread trees.
412
-
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-4}RFC 5256 Section 4}. *)
413
-
type thread_result = thread_node list
414
-
415
-
(* === Quota Types - RFC 9208 === *)
416
-
417
-
(** Quota resource types.
418
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5}RFC 9208 Section 5}. *)
419
-
type quota_resource =
420
-
| Quota_storage (** STORAGE - physical space in KB.
421
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.1}RFC 9208 Section 5.1}. *)
422
-
| Quota_message (** MESSAGE - number of messages.
423
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.2}RFC 9208 Section 5.2}. *)
424
-
| Quota_mailbox (** MAILBOX - number of mailboxes.
425
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.3}RFC 9208 Section 5.3}. *)
426
-
| Quota_annotation_storage (** ANNOTATION-STORAGE - annotation size in KB.
427
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.4}RFC 9208 Section 5.4}. *)
428
-
429
-
(** A single quota resource with usage and limit.
430
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.2.2}RFC 9208 Section 4.2.2}. *)
431
-
type quota_resource_info = {
432
-
resource : quota_resource;
433
-
usage : int64; (** Current usage *)
434
-
limit : int64; (** Maximum allowed *)
435
-
}
436
-
437
-
(* === Commands - RFC 9051 Section 6 === *)
438
-
439
-
type command =
440
-
| Capability
441
-
| Noop
442
-
| Logout
443
-
| Starttls
444
-
| Login of { username : string; password : string }
445
-
| Authenticate of { mechanism : string; initial_response : string option }
446
-
| Enable of string list
447
-
| Select of mailbox_name
448
-
| Examine of mailbox_name
449
-
| Create of mailbox_name
450
-
| Delete of mailbox_name
451
-
| Rename of { old_name : mailbox_name; new_name : mailbox_name }
452
-
| Subscribe of mailbox_name
453
-
| Unsubscribe of mailbox_name
454
-
| List of list_command (** LIST command - RFC 9051, RFC 5258 LIST-EXTENDED *)
455
-
| Namespace
456
-
| Status of { mailbox : mailbox_name; items : status_item list }
457
-
| Append of { mailbox : mailbox_name; flags : flag list; date : string option; message : string }
458
-
| Idle
459
-
| Close
460
-
| Unselect
461
-
| Expunge
462
-
| Search of { charset : string option; criteria : search_key }
463
-
| Fetch of { sequence : sequence_set; items : fetch_item list }
464
-
| Store of { sequence : sequence_set; silent : bool; action : store_action; flags : flag list }
465
-
| Copy of { sequence : sequence_set; mailbox : mailbox_name }
466
-
| Move of { sequence : sequence_set; mailbox : mailbox_name }
467
-
| Uid of uid_command
468
-
| Id of (string * string) list option (** RFC 2971 - NIL or list of field/value pairs *)
469
-
(* QUOTA extension - RFC 9208 *)
470
-
| Getquota of string (** GETQUOTA quota-root.
471
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.2}RFC 9208 Section 4.2}. *)
472
-
| Getquotaroot of mailbox_name (** GETQUOTAROOT mailbox.
473
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.3}RFC 9208 Section 4.3}. *)
474
-
| Setquota of { root : string; limits : (quota_resource * int64) list } (** SETQUOTA.
475
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.1}RFC 9208 Section 4.1}. *)
476
-
(* THREAD extension - RFC 5256 *)
477
-
| Thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
478
-
(** THREAD command.
479
-
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-3}RFC 5256 Section 3}. *)
480
-
481
-
and uid_command =
482
-
| Uid_fetch of { sequence : sequence_set; items : fetch_item list }
483
-
| Uid_store of { sequence : sequence_set; silent : bool; action : store_action; flags : flag list }
484
-
| Uid_copy of { sequence : sequence_set; mailbox : mailbox_name }
485
-
| Uid_move of { sequence : sequence_set; mailbox : mailbox_name }
486
-
| Uid_search of { charset : string option; criteria : search_key }
487
-
| Uid_expunge of sequence_set
488
-
| Uid_thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
489
-
(** UID THREAD command - RFC 5256. Returns UIDs instead of sequence numbers. *)
490
-
491
-
type tagged_command = {
492
-
tag : string;
493
-
command : command;
494
-
}
495
-
496
-
(* === Responses - RFC 9051 Section 7 === *)
497
-
498
-
type namespace_entry = {
499
-
prefix : string;
500
-
delimiter : char option;
501
-
}
502
-
503
-
type namespace_data = {
504
-
personal : namespace_entry list option;
505
-
other : namespace_entry list option;
506
-
shared : namespace_entry list option;
507
-
}
508
-
509
-
type esearch_result =
510
-
| Esearch_min of int
511
-
| Esearch_max of int
512
-
| Esearch_count of int
513
-
| Esearch_all of sequence_set
514
-
515
-
type fetch_response_item =
516
-
| Fetch_item_envelope of envelope
517
-
| Fetch_item_flags of flag list
518
-
| Fetch_item_internaldate of string
519
-
| Fetch_item_rfc822_size of int64
520
-
| Fetch_item_uid of uid
521
-
| Fetch_item_body of body_structure
522
-
| Fetch_item_bodystructure of body_structure
523
-
| Fetch_item_body_section of { section : section_spec option; origin : int option; data : string option }
524
-
| Fetch_item_binary of { section : int list; data : string option }
525
-
| Fetch_item_binary_size of { section : int list; size : int64 }
526
-
527
-
type response =
528
-
| Ok of { tag : string option; code : response_code option; text : string }
529
-
| No of { tag : string option; code : response_code option; text : string }
530
-
| Bad of { tag : string option; code : response_code option; text : string }
531
-
| Preauth of { code : response_code option; text : string }
532
-
| Bye of { code : response_code option; text : string }
533
-
| Capability_response of string list
534
-
| Enabled of string list
535
-
| List_response of list_response_data (** RFC 9051, RFC 5258 LIST-EXTENDED *)
536
-
| Namespace_response of namespace_data
537
-
| Status_response of { mailbox : mailbox_name; items : (status_item * int64) list }
538
-
| Esearch of { tag : string option; uid : bool; results : esearch_result list }
539
-
| Flags_response of flag list
540
-
| Exists of int
541
-
| Expunge_response of int
542
-
| Fetch_response of { seq : int; items : fetch_response_item list }
543
-
| Continuation of string option
544
-
| Id_response of (string * string) list option (** RFC 2971 - NIL or list of field/value pairs *)
545
-
(* QUOTA extension responses - RFC 9208 *)
546
-
| Quota_response of { root : string; resources : quota_resource_info list }
547
-
(** QUOTA response.
548
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.1}RFC 9208 Section 5.1}. *)
549
-
| Quotaroot_response of { mailbox : mailbox_name; roots : string list }
550
-
(** QUOTAROOT response.
551
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.2}RFC 9208 Section 5.2}. *)
552
-
(* THREAD extension response - RFC 5256 *)
553
-
| Thread_response of thread_result
554
-
(** THREAD response - a list of thread trees.
555
-
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-4}RFC 5256 Section 4}. *)
-577
lib/imapd/protocol.mli
-577
lib/imapd/protocol.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** IMAP4rev2 Core Types
7
-
8
-
This module defines the core types for the IMAP4rev2 protocol as specified in
9
-
{{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051}.
10
-
11
-
{2 References}
12
-
{ul
13
-
{- {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} - IMAP4rev2}
14
-
{- {{:https://datatracker.ietf.org/doc/html/rfc9051#section-2.3}RFC 9051 Section 2.3} - Message Attributes}
15
-
{- {{:https://datatracker.ietf.org/doc/html/rfc9051#section-3}RFC 9051 Section 3} - State and Flow Diagram}} *)
16
-
17
-
(** {1 Basic Types} *)
18
-
19
-
type mailbox_name = string
20
-
(** Mailbox name. INBOX is case-insensitive per {{:https://datatracker.ietf.org/doc/html/rfc9051#section-5.1}RFC 9051 Section 5.1}. *)
21
-
22
-
type uid = int32
23
-
(** Unique identifier for a message.
24
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-2.3.1.1}RFC 9051 Section 2.3.1.1}. *)
25
-
26
-
type seq_num = int
27
-
(** Message sequence number (1-based).
28
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-2.3.1.2}RFC 9051 Section 2.3.1.2}. *)
29
-
30
-
type uidvalidity = int32
31
-
(** UIDVALIDITY value for a mailbox.
32
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-2.3.1.1}RFC 9051 Section 2.3.1.1}. *)
33
-
34
-
(** {1 Message Flags}
35
-
36
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-2.3.2}RFC 9051 Section 2.3.2}. *)
37
-
38
-
type system_flag =
39
-
| Seen (** Message has been read *)
40
-
| Answered (** Message has been answered *)
41
-
| Flagged (** Message is flagged for urgent/special attention *)
42
-
| Deleted (** Message is marked for deletion *)
43
-
| Draft (** Message has not completed composition *)
44
-
45
-
type flag =
46
-
| System of system_flag
47
-
| Keyword of string (** User-defined keyword (e.g., "$Forwarded", "$Junk") *)
48
-
49
-
(** {1 Email Addresses}
50
-
51
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-7.5.2}RFC 9051 Section 7.5.2} ENVELOPE structure. *)
52
-
53
-
type address = {
54
-
name : string option; (** Display name *)
55
-
adl : string option; (** Source route (obsolete, usually NIL) *)
56
-
mailbox : string option; (** Local part of email address *)
57
-
host : string option; (** Domain part of email address *)
58
-
}
59
-
60
-
(** {1 Message Envelope}
61
-
62
-
Parsed representation of RFC 5322 header.
63
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-2.3.5}RFC 9051 Section 2.3.5}. *)
64
-
65
-
type envelope = {
66
-
date : string option;
67
-
subject : string option;
68
-
from : address list;
69
-
sender : address list;
70
-
reply_to : address list;
71
-
to_ : address list;
72
-
cc : address list;
73
-
bcc : address list;
74
-
in_reply_to : string option;
75
-
message_id : string option;
76
-
}
77
-
78
-
(** {1 Body Structure}
79
-
80
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-2.3.6}RFC 9051 Section 2.3.6}. *)
81
-
82
-
type body_fields = {
83
-
params : (string * string) list; (** Content-Type parameters *)
84
-
content_id : string option;
85
-
description : string option;
86
-
encoding : string; (** Content-Transfer-Encoding *)
87
-
size : int64; (** Size in octets *)
88
-
}
89
-
90
-
type body_type =
91
-
| Text of {
92
-
subtype : string;
93
-
fields : body_fields;
94
-
lines : int64;
95
-
}
96
-
| Message_rfc822 of {
97
-
fields : body_fields;
98
-
envelope : envelope;
99
-
body : body_structure;
100
-
lines : int64;
101
-
}
102
-
| Basic of {
103
-
media_type : string;
104
-
subtype : string;
105
-
fields : body_fields;
106
-
}
107
-
| Multipart of {
108
-
subtype : string;
109
-
parts : body_structure list;
110
-
params : (string * string) list;
111
-
}
112
-
113
-
and body_structure = {
114
-
body_type : body_type;
115
-
disposition : (string * (string * string) list) option;
116
-
language : string list option;
117
-
location : string option;
118
-
}
119
-
120
-
(** {1 Sequence Sets}
121
-
122
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-4.1.1}RFC 9051 Section 4.1.1}. *)
123
-
124
-
type sequence_range =
125
-
| Single of int (** Single message number *)
126
-
| Range of int * int (** Range n:m *)
127
-
| From of int (** n:* (from n to end) *)
128
-
| All (** * (all messages) *)
129
-
130
-
type sequence_set = sequence_range list
131
-
132
-
(** {1 Section Specification}
133
-
134
-
For BODY[...] fetch items.
135
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.4.5}RFC 9051 Section 6.4.5}. *)
136
-
137
-
type section_spec =
138
-
| Section_header
139
-
| Section_header_fields of string list
140
-
| Section_header_fields_not of string list
141
-
| Section_text
142
-
| Section_mime
143
-
| Section_part of int list * section_spec option
144
-
145
-
type body_section = {
146
-
section : section_spec option;
147
-
partial : (int * int) option; (** <offset.length> *)
148
-
}
149
-
150
-
(** {1 FETCH Items}
151
-
152
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.4.5}RFC 9051 Section 6.4.5}. *)
153
-
154
-
type fetch_item =
155
-
| Fetch_envelope
156
-
| Fetch_flags
157
-
| Fetch_internaldate
158
-
| Fetch_rfc822
159
-
| Fetch_rfc822_size
160
-
| Fetch_rfc822_header
161
-
| Fetch_rfc822_text
162
-
| Fetch_uid
163
-
| Fetch_body
164
-
| Fetch_bodystructure
165
-
| Fetch_body_section of string * (int * int) option (** section string, partial *)
166
-
| Fetch_body_peek of string * (int * int) option
167
-
| Fetch_binary of string * (int * int) option
168
-
| Fetch_binary_peek of string * (int * int) option
169
-
| Fetch_binary_size of string
170
-
171
-
(** {1 SEARCH Criteria}
172
-
173
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.4.4}RFC 9051 Section 6.4.4}. *)
174
-
175
-
type search_key =
176
-
| Search_all
177
-
| Search_answered
178
-
| Search_bcc of string
179
-
| Search_before of string (** date *)
180
-
| Search_body of string
181
-
| Search_cc of string
182
-
| Search_deleted
183
-
| Search_flagged
184
-
| Search_from of string
185
-
| Search_keyword of string
186
-
| Search_new
187
-
| Search_not of search_key
188
-
| Search_old
189
-
| Search_on of string (** date *)
190
-
| Search_or of search_key * search_key
191
-
| Search_seen
192
-
| Search_since of string (** date *)
193
-
| Search_subject of string
194
-
| Search_text of string
195
-
| Search_to of string
196
-
| Search_unanswered
197
-
| Search_undeleted
198
-
| Search_unflagged
199
-
| Search_unkeyword of string
200
-
| Search_unseen
201
-
| Search_draft
202
-
| Search_undraft
203
-
| Search_header of string * string
204
-
| Search_larger of int64
205
-
| Search_smaller of int64
206
-
| Search_uid of sequence_set
207
-
| Search_sequence_set of sequence_set
208
-
| Search_and of search_key list
209
-
| Search_sentbefore of string
210
-
| Search_senton of string
211
-
| Search_sentsince of string
212
-
213
-
(** {1 STORE Actions}
214
-
215
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.4.6}RFC 9051 Section 6.4.6}. *)
216
-
217
-
type store_action =
218
-
| Store_set (** FLAGS - replace flags *)
219
-
| Store_add (** +FLAGS - add flags *)
220
-
| Store_remove (** -FLAGS - remove flags *)
221
-
222
-
type store_silent = bool (** .SILENT modifier *)
223
-
224
-
(** {1 STATUS Items}
225
-
226
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.3.11}RFC 9051 Section 6.3.11}. *)
227
-
228
-
type status_item =
229
-
| Status_messages
230
-
| Status_uidnext
231
-
| Status_uidvalidity
232
-
| Status_unseen
233
-
| Status_deleted
234
-
| Status_size
235
-
236
-
(** {1 LIST Flags}
237
-
238
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-7.3.1}RFC 9051 Section 7.3.1}. *)
239
-
240
-
type list_flag =
241
-
| List_noinferiors (** \Noinferiors *)
242
-
| List_noselect (** \Noselect *)
243
-
| List_marked (** \Marked *)
244
-
| List_unmarked (** \Unmarked *)
245
-
| List_subscribed (** \Subscribed *)
246
-
| List_haschildren (** \HasChildren *)
247
-
| List_hasnochildren (** \HasNoChildren *)
248
-
| List_nonexistent (** \NonExistent - RFC 5258 Section 3.4 *)
249
-
| List_remote (** \Remote - RFC 5258 Section 3.4 *)
250
-
| List_all (** \All - special-use *)
251
-
| List_archive (** \Archive *)
252
-
| List_drafts (** \Drafts *)
253
-
| List_flagged (** \Flagged *)
254
-
| List_junk (** \Junk *)
255
-
| List_sent (** \Sent *)
256
-
| List_trash (** \Trash *)
257
-
| List_extension of string (** Other flags *)
258
-
259
-
(** LIST selection options per RFC 5258 Section 3.1 *)
260
-
type list_select_option =
261
-
| List_select_subscribed (** RFC 5258 Section 3.1.1 *)
262
-
| List_select_remote (** RFC 5258 Section 3.1.2 *)
263
-
| List_select_recursivematch (** RFC 5258 Section 3.1.3 *)
264
-
| List_select_special_use (** RFC 6154 Section 3 *)
265
-
266
-
(** LIST return options per RFC 5258 Section 3.2 *)
267
-
type list_return_option =
268
-
| List_return_subscribed (** RFC 5258 Section 3.2.1 *)
269
-
| List_return_children (** RFC 5258 Section 3.2.2 *)
270
-
| List_return_special_use (** RFC 6154 Section 3 *)
271
-
272
-
(** Extended data items in LIST response per RFC 5258 Section 3.5 *)
273
-
type list_extended_item =
274
-
| Childinfo of string list (** RFC 5258 Section 3.5 - CHILDINFO extended data *)
275
-
276
-
(** LIST command variants per RFC 5258 *)
277
-
type list_command =
278
-
| List_basic of {
279
-
reference : string; (** Reference name *)
280
-
pattern : string; (** Mailbox pattern *)
281
-
}
282
-
| List_extended of {
283
-
selection : list_select_option list;
284
-
reference : string;
285
-
patterns : string list;
286
-
return_opts : list_return_option list;
287
-
}
288
-
289
-
(** Extended LIST response per RFC 5258 Section 3.4 *)
290
-
type list_response_data = {
291
-
flags : list_flag list;
292
-
delimiter : char option;
293
-
name : mailbox_name;
294
-
extended : list_extended_item list;
295
-
}
296
-
297
-
(** {1 Connection State}
298
-
299
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-3}RFC 9051 Section 3}. *)
300
-
301
-
type connection_state =
302
-
| Not_authenticated
303
-
| Authenticated of { username : string }
304
-
| Selected of { username : string; mailbox : mailbox_name; readonly : bool }
305
-
| Logout
306
-
307
-
(** {1 Mailbox State}
308
-
309
-
Information about a selected mailbox. *)
310
-
311
-
type mailbox_state = {
312
-
name : mailbox_name;
313
-
exists : int; (** Number of messages *)
314
-
uidvalidity : uidvalidity;
315
-
uidnext : uid;
316
-
flags : flag list; (** Available flags *)
317
-
permanent_flags : flag list; (** Flags that can be changed permanently *)
318
-
readonly : bool;
319
-
}
320
-
321
-
(** {1 Message Representation} *)
322
-
323
-
type message = {
324
-
uid : uid;
325
-
seq : seq_num;
326
-
flags : flag list;
327
-
internal_date : string;
328
-
size : int64;
329
-
envelope : envelope option;
330
-
body_structure : body_structure option;
331
-
raw_headers : string option;
332
-
raw_body : string option;
333
-
}
334
-
335
-
(** {1 Response Codes}
336
-
337
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-7.1}RFC 9051 Section 7.1}. *)
338
-
339
-
type response_code =
340
-
| Code_alert
341
-
| Code_alreadyexists
342
-
| Code_appenduid of uidvalidity * uid
343
-
| Code_authenticationfailed
344
-
| Code_authorizationfailed
345
-
| Code_badcharset of string list
346
-
| Code_cannot
347
-
| Code_capability of string list
348
-
| Code_clientbug
349
-
| Code_closed
350
-
| Code_contactadmin
351
-
| Code_copyuid of uidvalidity * sequence_set * sequence_set
352
-
| Code_corruption
353
-
| Code_expired
354
-
| Code_expungeissued
355
-
| Code_haschildren
356
-
| Code_inuse
357
-
| Code_limit
358
-
| Code_nonexistent
359
-
| Code_noperm
360
-
| Code_overquota
361
-
| Code_parse
362
-
| Code_permanentflags of flag list
363
-
| Code_privacyrequired
364
-
| Code_readonly
365
-
| Code_readwrite
366
-
| Code_serverbug
367
-
| Code_trycreate
368
-
| Code_uidnotsticky
369
-
| Code_uidvalidity of uidvalidity
370
-
| Code_uidnext of uid
371
-
| Code_unavailable
372
-
| Code_unknown_cte
373
-
| Code_other of string * string option
374
-
375
-
(** {1 Quota Types}
376
-
377
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208}RFC 9208 - IMAP QUOTA Extension}. *)
378
-
379
-
(** Quota resource types.
380
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5}RFC 9208 Section 5}. *)
381
-
type quota_resource =
382
-
| Quota_storage (** STORAGE - physical space in KB.
383
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.1}RFC 9208 Section 5.1}. *)
384
-
| Quota_message (** MESSAGE - number of messages.
385
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.2}RFC 9208 Section 5.2}. *)
386
-
| Quota_mailbox (** MAILBOX - number of mailboxes.
387
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.3}RFC 9208 Section 5.3}. *)
388
-
| Quota_annotation_storage (** ANNOTATION-STORAGE - annotation size in KB.
389
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.4}RFC 9208 Section 5.4}. *)
390
-
391
-
(** A single quota resource with usage and limit.
392
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.2.2}RFC 9208 Section 4.2.2}. *)
393
-
type quota_resource_info = {
394
-
resource : quota_resource;
395
-
usage : int64; (** Current usage *)
396
-
limit : int64; (** Maximum allowed *)
397
-
}
398
-
399
-
(** {1 Thread Types}
400
-
401
-
See {{:https://datatracker.ietf.org/doc/html/rfc5256}RFC 5256 - IMAP SORT and THREAD Extensions}. *)
402
-
403
-
(** Threading algorithm for the THREAD command.
404
-
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-3}RFC 5256 Section 3}. *)
405
-
type thread_algorithm =
406
-
| Thread_orderedsubject
407
-
(** ORDEREDSUBJECT algorithm (RFC 5256 Section 3.1). *)
408
-
| Thread_references
409
-
(** REFERENCES algorithm (RFC 5256 Section 3.2). *)
410
-
| Thread_extension of string
411
-
(** Future algorithm extensions. *)
412
-
413
-
(** A thread node in the THREAD response.
414
-
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-4}RFC 5256 Section 4}. *)
415
-
type thread_node =
416
-
| Thread_message of int * thread_node list
417
-
(** A message with its sequence number/UID and child threads. *)
418
-
| Thread_dummy of thread_node list
419
-
(** A placeholder for a missing parent message. *)
420
-
421
-
(** Thread result: a list of root-level thread trees. *)
422
-
type thread_result = thread_node list
423
-
424
-
(** {1 Commands}
425
-
426
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6}RFC 9051 Section 6}. *)
427
-
428
-
type command =
429
-
| Capability
430
-
| Noop
431
-
| Logout
432
-
| Starttls
433
-
| Login of { username : string; password : string }
434
-
| Authenticate of { mechanism : string; initial_response : string option }
435
-
| Enable of string list
436
-
| Select of mailbox_name
437
-
| Examine of mailbox_name
438
-
| Create of mailbox_name
439
-
| Delete of mailbox_name
440
-
| Rename of { old_name : mailbox_name; new_name : mailbox_name }
441
-
| Subscribe of mailbox_name
442
-
| Unsubscribe of mailbox_name
443
-
| List of list_command (** LIST command - RFC 9051, RFC 5258 LIST-EXTENDED *)
444
-
| Namespace
445
-
| Status of { mailbox : mailbox_name; items : status_item list }
446
-
| Append of { mailbox : mailbox_name; flags : flag list; date : string option; message : string }
447
-
| Idle
448
-
| Close
449
-
| Unselect
450
-
| Expunge
451
-
| Search of { charset : string option; criteria : search_key }
452
-
| Fetch of { sequence : sequence_set; items : fetch_item list }
453
-
| Store of { sequence : sequence_set; silent : bool; action : store_action; flags : flag list }
454
-
| Copy of { sequence : sequence_set; mailbox : mailbox_name }
455
-
| Move of { sequence : sequence_set; mailbox : mailbox_name }
456
-
| Uid of uid_command
457
-
| Id of (string * string) list option (** RFC 2971 *)
458
-
(* QUOTA extension - RFC 9208 *)
459
-
| Getquota of string (** GETQUOTA quota-root.
460
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.2}RFC 9208 Section 4.2}. *)
461
-
| Getquotaroot of mailbox_name (** GETQUOTAROOT mailbox.
462
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.3}RFC 9208 Section 4.3}. *)
463
-
| Setquota of { root : string; limits : (quota_resource * int64) list } (** SETQUOTA.
464
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-4.1}RFC 9208 Section 4.1}. *)
465
-
(* THREAD extension - RFC 5256 *)
466
-
| Thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
467
-
(** THREAD command.
468
-
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-3}RFC 5256 Section 3}. *)
469
-
470
-
and uid_command =
471
-
| Uid_fetch of { sequence : sequence_set; items : fetch_item list }
472
-
| Uid_store of { sequence : sequence_set; silent : bool; action : store_action; flags : flag list }
473
-
| Uid_copy of { sequence : sequence_set; mailbox : mailbox_name }
474
-
| Uid_move of { sequence : sequence_set; mailbox : mailbox_name }
475
-
| Uid_search of { charset : string option; criteria : search_key }
476
-
| Uid_expunge of sequence_set
477
-
| Uid_thread of { algorithm : thread_algorithm; charset : string; criteria : search_key }
478
-
(** UID THREAD command - RFC 5256. Returns UIDs instead of sequence numbers. *)
479
-
480
-
type tagged_command = {
481
-
tag : string;
482
-
command : command;
483
-
}
484
-
485
-
(** {1 Responses}
486
-
487
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-7}RFC 9051 Section 7}. *)
488
-
489
-
type namespace_entry = {
490
-
prefix : string;
491
-
delimiter : char option;
492
-
}
493
-
494
-
type namespace_data = {
495
-
personal : namespace_entry list option;
496
-
other : namespace_entry list option;
497
-
shared : namespace_entry list option;
498
-
}
499
-
500
-
type esearch_result =
501
-
| Esearch_min of int
502
-
| Esearch_max of int
503
-
| Esearch_count of int
504
-
| Esearch_all of sequence_set
505
-
506
-
type fetch_response_item =
507
-
| Fetch_item_envelope of envelope
508
-
| Fetch_item_flags of flag list
509
-
| Fetch_item_internaldate of string
510
-
| Fetch_item_rfc822_size of int64
511
-
| Fetch_item_uid of uid
512
-
| Fetch_item_body of body_structure
513
-
| Fetch_item_bodystructure of body_structure
514
-
| Fetch_item_body_section of { section : section_spec option; origin : int option; data : string option }
515
-
| Fetch_item_binary of { section : int list; data : string option }
516
-
| Fetch_item_binary_size of { section : int list; size : int64 }
517
-
518
-
type response =
519
-
| Ok of { tag : string option; code : response_code option; text : string }
520
-
| No of { tag : string option; code : response_code option; text : string }
521
-
| Bad of { tag : string option; code : response_code option; text : string }
522
-
| Preauth of { code : response_code option; text : string }
523
-
| Bye of { code : response_code option; text : string }
524
-
| Capability_response of string list
525
-
| Enabled of string list
526
-
| List_response of list_response_data (** RFC 9051, RFC 5258 LIST-EXTENDED *)
527
-
| Namespace_response of namespace_data
528
-
| Status_response of { mailbox : mailbox_name; items : (status_item * int64) list }
529
-
| Esearch of { tag : string option; uid : bool; results : esearch_result list }
530
-
| Flags_response of flag list
531
-
| Exists of int
532
-
| Expunge_response of int
533
-
| Fetch_response of { seq : int; items : fetch_response_item list }
534
-
| Continuation of string option
535
-
| Id_response of (string * string) list option (** RFC 2971 *)
536
-
(* QUOTA extension responses - RFC 9208 *)
537
-
| Quota_response of { root : string; resources : quota_resource_info list }
538
-
(** QUOTA response.
539
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.1}RFC 9208 Section 5.1}. *)
540
-
| Quotaroot_response of { mailbox : mailbox_name; roots : string list }
541
-
(** QUOTAROOT response.
542
-
See {{:https://datatracker.ietf.org/doc/html/rfc9208#section-5.2}RFC 9208 Section 5.2}. *)
543
-
(* THREAD extension response - RFC 5256 *)
544
-
| Thread_response of thread_result
545
-
(** THREAD response containing thread tree.
546
-
See {{:https://datatracker.ietf.org/doc/html/rfc5256#section-4}RFC 5256 Section 4}. *)
547
-
548
-
(** {1 Utility Functions} *)
549
-
550
-
(** {2 Security Validation} *)
551
-
552
-
val is_safe_username : string -> bool
553
-
(** Validate username for path safety. Prevents path traversal attacks.
554
-
Returns false for usernames containing null bytes, path separators,
555
-
or traversal patterns like [..]. *)
556
-
557
-
val is_safe_mailbox_name : mailbox_name -> bool
558
-
(** Validate mailbox name for path safety. Prevents path traversal attacks.
559
-
Returns false for names containing null bytes, backslashes, or
560
-
path components that are [.] or [..]. Allows [/] as hierarchy delimiter. *)
561
-
562
-
(** {2 Mailbox Utilities} *)
563
-
564
-
val normalize_mailbox_name : mailbox_name -> mailbox_name
565
-
(** Normalize mailbox name. INBOX is case-insensitive. *)
566
-
567
-
val is_inbox : mailbox_name -> bool
568
-
(** Check if mailbox name is INBOX (case-insensitive). *)
569
-
570
-
val flag_to_string : flag -> string
571
-
(** Convert flag to IMAP string representation. *)
572
-
573
-
val string_to_flag : string -> flag option
574
-
(** Parse IMAP flag string. *)
575
-
576
-
val system_flag_to_string : system_flag -> string
577
-
(** Convert system flag to string. *)
-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; extended = [] }
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. *)
-1215
lib/imapd/server.ml
-1215
lib/imapd/server.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** IMAP4rev2 Server
7
-
8
-
Implements {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} state machine. *)
9
-
10
-
open Protocol
11
-
open Parser
12
-
13
-
(* Module alias to access Storage types without conflicting with functor parameter *)
14
-
module Storage_types = Storage
15
-
16
-
(** Base capabilities per RFC 9051.
17
-
@see <https://datatracker.ietf.org/doc/html/rfc9051> RFC 9051: IMAP4rev2
18
-
@see <https://datatracker.ietf.org/doc/html/rfc6855#section-3> RFC 6855 Section 3: UTF8=ACCEPT *)
19
-
let base_capabilities_pre_tls = [
20
-
"IMAP4rev2";
21
-
"IMAP4rev1"; (* For compatibility *)
22
-
"AUTH=PLAIN";
23
-
"STARTTLS";
24
-
"IDLE";
25
-
"NAMESPACE";
26
-
"UIDPLUS";
27
-
"MOVE";
28
-
"ENABLE";
29
-
"LITERAL+";
30
-
"ID";
31
-
"UNSELECT"; (* RFC 3691 *)
32
-
"SPECIAL-USE"; (* RFC 6154 *)
33
-
"LIST-EXTENDED"; (* RFC 5258 *)
34
-
"CONDSTORE"; (* RFC 7162 - modification sequences for flags *)
35
-
(* QUOTA extension - RFC 9208 *)
36
-
"QUOTA";
37
-
"QUOTA=RES-STORAGE"; (* RFC 9208 Section 5.1 *)
38
-
"QUOTA=RES-MESSAGE"; (* RFC 9208 Section 5.2 *)
39
-
(* UTF-8 support - RFC 6855 *)
40
-
"UTF8=ACCEPT"; (* RFC 6855 Section 3 *)
41
-
(* THREAD extension - RFC 5256 *)
42
-
"THREAD=ORDEREDSUBJECT"; (* RFC 5256 Section 3.1 *)
43
-
"THREAD=REFERENCES"; (* RFC 5256 Section 3.2 *)
44
-
]
45
-
46
-
let base_capabilities_post_tls = [
47
-
"IMAP4rev2";
48
-
"IMAP4rev1";
49
-
"AUTH=PLAIN";
50
-
"IDLE";
51
-
"NAMESPACE";
52
-
"UIDPLUS";
53
-
"MOVE";
54
-
"ENABLE";
55
-
"LITERAL+";
56
-
"ID";
57
-
"UNSELECT"; (* RFC 3691 *)
58
-
"SPECIAL-USE"; (* RFC 6154 *)
59
-
"LIST-EXTENDED"; (* RFC 5258 *)
60
-
"CONDSTORE"; (* RFC 7162 - modification sequences for flags *)
61
-
(* QUOTA extension - RFC 9208 *)
62
-
"QUOTA";
63
-
"QUOTA=RES-STORAGE"; (* RFC 9208 Section 5.1 *)
64
-
"QUOTA=RES-MESSAGE"; (* RFC 9208 Section 5.2 *)
65
-
(* UTF-8 support - RFC 6855 *)
66
-
"UTF8=ACCEPT"; (* RFC 6855 Section 3 *)
67
-
(* THREAD extension - RFC 5256 *)
68
-
"THREAD=ORDEREDSUBJECT"; (* RFC 5256 Section 3.1 *)
69
-
"THREAD=REFERENCES"; (* RFC 5256 Section 3.2 *)
70
-
]
71
-
72
-
(* Server configuration *)
73
-
type config = {
74
-
hostname : string;
75
-
capabilities : string list;
76
-
greeting : string option;
77
-
autologout_timeout : float;
78
-
tls_config : Tls.Config.server option;
79
-
}
80
-
81
-
let default_config = {
82
-
hostname = "localhost";
83
-
capabilities = [];
84
-
greeting = None;
85
-
autologout_timeout = 1800.0; (* 30 minutes per RFC 9051 Section 5.4 *)
86
-
tls_config = None;
87
-
}
88
-
89
-
module Make
90
-
(Storage : Storage.STORAGE)
91
-
(Auth : Auth.AUTH) = struct
92
-
93
-
(** Connection state with UTF-8 mode tracking.
94
-
@see <https://datatracker.ietf.org/doc/html/rfc6855#section-3> RFC 6855 Section 3 *)
95
-
type connection_state =
96
-
| Not_authenticated
97
-
| Authenticated of { username : string; utf8_enabled : bool }
98
-
| Selected of { username : string; mailbox : string; readonly : bool; utf8_enabled : bool }
99
-
| Logout
100
-
101
-
(* Action returned by command handlers *)
102
-
type command_action =
103
-
| Continue
104
-
| Upgrade_tls of string (* tag for response *)
105
-
106
-
type t = {
107
-
config : config;
108
-
storage : Storage.t;
109
-
auth : Auth.t;
110
-
}
111
-
112
-
let create ~config ~storage ~auth = { config; storage; auth }
113
-
114
-
let all_capabilities t ~tls_active =
115
-
let base = if tls_active then base_capabilities_post_tls else base_capabilities_pre_tls in
116
-
base @ t.config.capabilities
117
-
118
-
(* Send a response to the client *)
119
-
let send_response flow response =
120
-
let data = response_to_string response in
121
-
Eio.Flow.copy_string data flow
122
-
123
-
(* Send greeting *)
124
-
let send_greeting t flow ~tls_active =
125
-
let caps = all_capabilities t ~tls_active in
126
-
let greeting = match t.config.greeting with
127
-
| Some g -> g
128
-
| None -> "IMAP4rev2 Service Ready"
129
-
in
130
-
let response = Ok {
131
-
tag = None;
132
-
code = Some (Code_capability caps);
133
-
text = greeting;
134
-
} in
135
-
send_response flow response
136
-
137
-
(* Process CAPABILITY command - valid in any state *)
138
-
let handle_capability t flow tag ~tls_active =
139
-
let caps = all_capabilities t ~tls_active in
140
-
send_response flow (Capability_response caps);
141
-
send_response flow (Ok { tag = Some tag; code = None; text = "CAPABILITY completed" })
142
-
143
-
(* Process NOOP command - valid in any state *)
144
-
let handle_noop flow tag =
145
-
send_response flow (Ok { tag = Some tag; code = None; text = "NOOP completed" })
146
-
147
-
(* Process ID command - RFC 2971 - valid in any state *)
148
-
let handle_id flow tag _client_params =
149
-
(* Return server identification *)
150
-
let server_id = Some [
151
-
("name", "imapd");
152
-
("vendor", "OCaml IMAP");
153
-
("version", "0.1.0");
154
-
("support-url", "https://github.com/mtelvers/imapd");
155
-
] in
156
-
send_response flow (Id_response server_id);
157
-
send_response flow (Ok { tag = Some tag; code = None; text = "ID completed" })
158
-
159
-
(* Process LOGOUT command - valid in any state *)
160
-
let handle_logout flow tag =
161
-
send_response flow (Bye { code = None; text = "IMAP4rev2 Server logging out" });
162
-
send_response flow (Ok { tag = Some tag; code = None; text = "LOGOUT completed" });
163
-
Logout
164
-
165
-
(* Process LOGIN command - only valid in Not_authenticated state *)
166
-
let handle_login t flow tag ~username ~password ~tls_active state =
167
-
match state with
168
-
| Not_authenticated ->
169
-
(* Security: Validate username before authentication *)
170
-
if not (Protocol.is_safe_username username) then begin
171
-
send_response flow (No {
172
-
tag = Some tag;
173
-
code = Some Code_authenticationfailed;
174
-
text = "LOGIN failed"
175
-
});
176
-
state
177
-
end else if Auth.authenticate t.auth ~username ~password then begin
178
-
let caps = all_capabilities t ~tls_active in
179
-
send_response flow (Ok {
180
-
tag = Some tag;
181
-
code = Some (Code_capability caps);
182
-
text = "LOGIN completed"
183
-
});
184
-
Authenticated { username; utf8_enabled = false }
185
-
end else begin
186
-
send_response flow (No {
187
-
tag = Some tag;
188
-
code = Some Code_authenticationfailed;
189
-
text = "LOGIN failed"
190
-
});
191
-
state
192
-
end
193
-
| _ ->
194
-
send_response flow (Bad {
195
-
tag = Some tag;
196
-
code = None;
197
-
text = "Command not valid in this state"
198
-
});
199
-
state
200
-
201
-
(* Process SELECT/EXAMINE command - only valid in Authenticated/Selected state *)
202
-
let handle_select t flow tag mailbox ~readonly state =
203
-
let username, utf8_enabled = match state with
204
-
| Authenticated { username; utf8_enabled } -> Some username, utf8_enabled
205
-
| Selected { username; utf8_enabled; _ } -> Some username, utf8_enabled
206
-
| _ -> None, false
207
-
in
208
-
match username with
209
-
| None ->
210
-
send_response flow (Bad {
211
-
tag = Some tag;
212
-
code = None;
213
-
text = "Command not valid in this state"
214
-
});
215
-
state
216
-
| Some username ->
217
-
(* Security: Validate mailbox name *)
218
-
if not (Protocol.is_safe_mailbox_name mailbox) then begin
219
-
send_response flow (No {
220
-
tag = Some tag;
221
-
code = None;
222
-
text = "Invalid mailbox name"
223
-
});
224
-
Authenticated { username; utf8_enabled }
225
-
end else
226
-
match Storage.select_mailbox t.storage ~username mailbox ~readonly with
227
-
| Error _ ->
228
-
send_response flow (No {
229
-
tag = Some tag;
230
-
code = Some Code_nonexistent;
231
-
text = "Mailbox does not exist"
232
-
});
233
-
Authenticated { username; utf8_enabled }
234
-
| Ok mb_state ->
235
-
(* Send untagged responses *)
236
-
send_response flow (Flags_response mb_state.flags);
237
-
send_response flow (Exists mb_state.exists);
238
-
send_response flow (Ok {
239
-
tag = None;
240
-
code = Some (Code_permanentflags mb_state.permanent_flags);
241
-
text = "Flags permitted"
242
-
});
243
-
send_response flow (Ok {
244
-
tag = None;
245
-
code = Some (Code_uidvalidity mb_state.uidvalidity);
246
-
text = "UIDs valid"
247
-
});
248
-
send_response flow (Ok {
249
-
tag = None;
250
-
code = Some (Code_uidnext mb_state.uidnext);
251
-
text = "Predicted next UID"
252
-
});
253
-
(* Send tagged OK *)
254
-
let code = if readonly then Some Code_readonly else Some Code_readwrite in
255
-
send_response flow (Ok {
256
-
tag = Some tag;
257
-
code;
258
-
text = if readonly then "EXAMINE completed" else "SELECT completed"
259
-
});
260
-
Selected { username; mailbox; readonly; utf8_enabled }
261
-
262
-
(* Process LIST command - RFC 9051, RFC 5258 LIST-EXTENDED *)
263
-
let handle_list t flow tag list_cmd state =
264
-
let username = match state with
265
-
| Authenticated { username; _ } -> Some username
266
-
| Selected { username; _ } -> Some username
267
-
| _ -> None
268
-
in
269
-
match username with
270
-
| None ->
271
-
send_response flow (Bad {
272
-
tag = Some tag;
273
-
code = None;
274
-
text = "Command not valid in this state"
275
-
});
276
-
state
277
-
| Some username ->
278
-
(* Extract reference and patterns from list command *)
279
-
let reference, patterns = match list_cmd with
280
-
| List_basic { reference; pattern } -> (reference, [pattern])
281
-
| List_extended { reference; patterns; _ } -> (reference, patterns)
282
-
in
283
-
(* Process each pattern and collect mailboxes *)
284
-
let all_mailboxes = List.concat_map (fun pattern ->
285
-
Storage.list_mailboxes t.storage ~username ~reference ~pattern
286
-
) patterns in
287
-
(* Send LIST responses with extended data if needed *)
288
-
List.iter (fun (mb : Storage_types.mailbox_info) ->
289
-
send_response flow (List_response {
290
-
flags = mb.flags;
291
-
delimiter = mb.delimiter;
292
-
name = mb.name;
293
-
extended = []; (* Extended data can be populated based on return options *)
294
-
})
295
-
) all_mailboxes;
296
-
send_response flow (Ok { tag = Some tag; code = None; text = "LIST completed" });
297
-
state
298
-
299
-
(* Process STATUS command *)
300
-
let handle_status t flow tag mailbox ~items state =
301
-
(* Security: Validate mailbox name *)
302
-
if not (Protocol.is_safe_mailbox_name mailbox) then begin
303
-
send_response flow (No { tag = Some tag; code = None; text = "Invalid mailbox name" });
304
-
state
305
-
end else
306
-
let username = match state with
307
-
| Authenticated { username; _ } -> Some username
308
-
| Selected { username; _ } -> Some username
309
-
| _ -> None
310
-
in
311
-
match username with
312
-
| None ->
313
-
send_response flow (Bad {
314
-
tag = Some tag;
315
-
code = None;
316
-
text = "Command not valid in this state"
317
-
});
318
-
state
319
-
| Some username ->
320
-
match Storage.status_mailbox t.storage ~username mailbox ~items with
321
-
| Error _ ->
322
-
send_response flow (No {
323
-
tag = Some tag;
324
-
code = Some Code_nonexistent;
325
-
text = "Mailbox does not exist"
326
-
});
327
-
state
328
-
| Ok results ->
329
-
send_response flow (Status_response { mailbox; items = results });
330
-
send_response flow (Ok { tag = Some tag; code = None; text = "STATUS completed" });
331
-
state
332
-
333
-
(* Process FETCH command *)
334
-
let handle_fetch t flow tag ~sequence ~items state =
335
-
match state with
336
-
| Selected { username; mailbox; _ } ->
337
-
(match Storage.fetch_messages t.storage ~username ~mailbox ~sequence ~items with
338
-
| Error _ ->
339
-
send_response flow (No { tag = Some tag; code = None; text = "FETCH failed" })
340
-
| Ok messages ->
341
-
List.iter (fun (msg : message) ->
342
-
let fetch_items = [
343
-
Fetch_item_uid msg.uid;
344
-
Fetch_item_flags msg.flags;
345
-
Fetch_item_rfc822_size msg.size;
346
-
Fetch_item_internaldate msg.internal_date;
347
-
] in
348
-
send_response flow (Fetch_response { seq = msg.seq; items = fetch_items })
349
-
) messages;
350
-
send_response flow (Ok { tag = Some tag; code = None; text = "FETCH completed" }));
351
-
state
352
-
| _ ->
353
-
send_response flow (Bad {
354
-
tag = Some tag;
355
-
code = None;
356
-
text = "Command not valid in this state"
357
-
});
358
-
state
359
-
360
-
(* Process STORE command *)
361
-
let handle_store t flow tag ~sequence ~silent ~action ~flags state =
362
-
match state with
363
-
| Selected { username; mailbox; readonly; _ } ->
364
-
if readonly then begin
365
-
send_response flow (No { tag = Some tag; code = None; text = "Mailbox is read-only" });
366
-
state
367
-
end else begin
368
-
match Storage.store_flags t.storage ~username ~mailbox ~sequence ~action ~flags with
369
-
| Error _ ->
370
-
send_response flow (No { tag = Some tag; code = None; text = "STORE failed" });
371
-
state
372
-
| Ok messages ->
373
-
if not silent then
374
-
List.iter (fun (msg : message) ->
375
-
send_response flow (Fetch_response {
376
-
seq = msg.seq;
377
-
items = [Fetch_item_flags msg.flags]
378
-
})
379
-
) messages;
380
-
send_response flow (Ok { tag = Some tag; code = None; text = "STORE completed" });
381
-
state
382
-
end
383
-
| _ ->
384
-
send_response flow (Bad {
385
-
tag = Some tag;
386
-
code = None;
387
-
text = "Command not valid in this state"
388
-
});
389
-
state
390
-
391
-
(* Process EXPUNGE command *)
392
-
let handle_expunge t flow tag state =
393
-
match state with
394
-
| Selected { username; mailbox; readonly; _ } ->
395
-
if readonly then begin
396
-
send_response flow (No { tag = Some tag; code = None; text = "Mailbox is read-only" });
397
-
state
398
-
end else begin
399
-
match Storage.expunge t.storage ~username ~mailbox with
400
-
| Error _ ->
401
-
send_response flow (No { tag = Some tag; code = None; text = "EXPUNGE failed" });
402
-
state
403
-
| Ok _uids ->
404
-
(* Send EXPUNGE responses for each removed message *)
405
-
send_response flow (Ok { tag = Some tag; code = None; text = "EXPUNGE completed" });
406
-
state
407
-
end
408
-
| _ ->
409
-
send_response flow (Bad {
410
-
tag = Some tag;
411
-
code = None;
412
-
text = "Command not valid in this state"
413
-
});
414
-
state
415
-
416
-
(* Process CLOSE command *)
417
-
let handle_close t flow tag state =
418
-
match state with
419
-
| Selected { username; mailbox; readonly; utf8_enabled } ->
420
-
(* Silently expunge if not readonly *)
421
-
if not readonly then
422
-
ignore (Storage.expunge t.storage ~username ~mailbox);
423
-
send_response flow (Ok { tag = Some tag; code = None; text = "CLOSE completed" });
424
-
Authenticated { username; utf8_enabled }
425
-
| _ ->
426
-
send_response flow (Bad {
427
-
tag = Some tag;
428
-
code = None;
429
-
text = "Command not valid in this state"
430
-
});
431
-
state
432
-
433
-
(* Process UNSELECT command *)
434
-
let handle_unselect flow tag state =
435
-
match state with
436
-
| Selected { username; utf8_enabled; _ } ->
437
-
send_response flow (Ok { tag = Some tag; code = None; text = "UNSELECT completed" });
438
-
Authenticated { username; utf8_enabled }
439
-
| _ ->
440
-
send_response flow (Bad {
441
-
tag = Some tag;
442
-
code = None;
443
-
text = "Command not valid in this state"
444
-
});
445
-
state
446
-
447
-
(* Process CREATE command *)
448
-
let handle_create t flow tag mailbox state =
449
-
(* Security: Validate mailbox name *)
450
-
if not (Protocol.is_safe_mailbox_name mailbox) then begin
451
-
send_response flow (No { tag = Some tag; code = None; text = "Invalid mailbox name" });
452
-
state
453
-
end else
454
-
let username = match state with
455
-
| Authenticated { username; _ } -> Some username
456
-
| Selected { username; _ } -> Some username
457
-
| _ -> None
458
-
in
459
-
match username with
460
-
| None ->
461
-
send_response flow (Bad {
462
-
tag = Some tag;
463
-
code = None;
464
-
text = "Command not valid in this state"
465
-
});
466
-
state
467
-
| Some username ->
468
-
match Storage.create_mailbox t.storage ~username mailbox with
469
-
| Ok () ->
470
-
send_response flow (Ok { tag = Some tag; code = None; text = "CREATE completed" });
471
-
state
472
-
| Error Storage_types.Mailbox_already_exists ->
473
-
send_response flow (No {
474
-
tag = Some tag;
475
-
code = Some Code_alreadyexists;
476
-
text = "Mailbox already exists"
477
-
});
478
-
state
479
-
| Error _ ->
480
-
send_response flow (No { tag = Some tag; code = None; text = "CREATE failed" });
481
-
state
482
-
483
-
(* Process DELETE command *)
484
-
let handle_delete t flow tag mailbox state =
485
-
(* Security: Validate mailbox name *)
486
-
if not (Protocol.is_safe_mailbox_name mailbox) then begin
487
-
send_response flow (No { tag = Some tag; code = None; text = "Invalid mailbox name" });
488
-
state
489
-
end else
490
-
let username = match state with
491
-
| Authenticated { username; _ } -> Some username
492
-
| Selected { username; _ } -> Some username
493
-
| _ -> None
494
-
in
495
-
match username with
496
-
| None ->
497
-
send_response flow (Bad {
498
-
tag = Some tag;
499
-
code = None;
500
-
text = "Command not valid in this state"
501
-
});
502
-
state
503
-
| Some username ->
504
-
match Storage.delete_mailbox t.storage ~username mailbox with
505
-
| Ok () ->
506
-
send_response flow (Ok { tag = Some tag; code = None; text = "DELETE completed" });
507
-
state
508
-
| Error Storage_types.Permission_denied ->
509
-
send_response flow (No {
510
-
tag = Some tag;
511
-
code = Some Code_cannot;
512
-
text = "Cannot delete INBOX"
513
-
});
514
-
state
515
-
| Error _ ->
516
-
send_response flow (No { tag = Some tag; code = None; text = "DELETE failed" });
517
-
state
518
-
519
-
(* Process RENAME command *)
520
-
let handle_rename t flow tag ~old_name ~new_name state =
521
-
(* Security: Validate both mailbox names *)
522
-
if not (Protocol.is_safe_mailbox_name old_name) ||
523
-
not (Protocol.is_safe_mailbox_name new_name) then begin
524
-
send_response flow (No { tag = Some tag; code = None; text = "Invalid mailbox name" });
525
-
state
526
-
end else
527
-
let username = match state with
528
-
| Authenticated { username; _ } -> Some username
529
-
| Selected { username; _ } -> Some username
530
-
| _ -> None
531
-
in
532
-
match username with
533
-
| None ->
534
-
send_response flow (Bad {
535
-
tag = Some tag;
536
-
code = None;
537
-
text = "Command not valid in this state"
538
-
});
539
-
state
540
-
| Some username ->
541
-
match Storage.rename_mailbox t.storage ~username ~old_name ~new_name with
542
-
| Result.Ok () ->
543
-
send_response flow (Ok { tag = Some tag; code = None; text = "RENAME completed" });
544
-
state
545
-
| Result.Error Storage_types.Mailbox_not_found ->
546
-
send_response flow (No {
547
-
tag = Some tag;
548
-
code = Some Code_nonexistent;
549
-
text = "Mailbox does not exist"
550
-
});
551
-
state
552
-
| Result.Error Storage_types.Mailbox_already_exists ->
553
-
send_response flow (No {
554
-
tag = Some tag;
555
-
code = Some Code_alreadyexists;
556
-
text = "Target mailbox already exists"
557
-
});
558
-
state
559
-
| Result.Error _ ->
560
-
send_response flow (No { tag = Some tag; code = None; text = "RENAME failed" });
561
-
state
562
-
563
-
(* Process COPY command *)
564
-
let handle_copy t flow tag ~sequence ~mailbox state =
565
-
(* Security: Validate destination mailbox name *)
566
-
if not (Protocol.is_safe_mailbox_name mailbox) then begin
567
-
send_response flow (No { tag = Some tag; code = None; text = "Invalid mailbox name" });
568
-
state
569
-
end else
570
-
match state with
571
-
| Selected { username; mailbox = src_mailbox; _ } ->
572
-
(match Storage.copy t.storage ~username ~src_mailbox ~sequence ~dst_mailbox:mailbox with
573
-
| Result.Error Storage_types.Mailbox_not_found ->
574
-
send_response flow (No {
575
-
tag = Some tag;
576
-
code = Some Code_trycreate;
577
-
text = "Destination mailbox does not exist"
578
-
})
579
-
| Result.Error _ ->
580
-
send_response flow (No { tag = Some tag; code = None; text = "COPY failed" })
581
-
| Result.Ok dst_uids ->
582
-
(* UIDPLUS: include COPYUID response code *)
583
-
let uidvalidity = match Storage.select_mailbox t.storage ~username mailbox ~readonly:true with
584
-
| Result.Ok mb -> mb.uidvalidity
585
-
| Result.Error _ -> 1l
586
-
in
587
-
let dst_set = List.map (fun uid -> Single (Int32.to_int uid)) dst_uids in
588
-
send_response flow (Ok {
589
-
tag = Some tag;
590
-
code = Some (Code_copyuid (uidvalidity, sequence, dst_set));
591
-
text = "COPY completed"
592
-
}));
593
-
state
594
-
| _ ->
595
-
send_response flow (Bad {
596
-
tag = Some tag;
597
-
code = None;
598
-
text = "Command not valid in this state"
599
-
});
600
-
state
601
-
602
-
(* Process MOVE command - RFC 6851 *)
603
-
let handle_move t flow tag ~sequence ~mailbox state =
604
-
(* Security: Validate destination mailbox name *)
605
-
if not (Protocol.is_safe_mailbox_name mailbox) then begin
606
-
send_response flow (No { tag = Some tag; code = None; text = "Invalid mailbox name" });
607
-
state
608
-
end else
609
-
match state with
610
-
| Selected { username; mailbox = src_mailbox; readonly; _ } ->
611
-
if readonly then begin
612
-
send_response flow (No { tag = Some tag; code = None; text = "Mailbox is read-only" });
613
-
state
614
-
end else begin
615
-
match Storage.move t.storage ~username ~src_mailbox ~sequence ~dst_mailbox:mailbox with
616
-
| Result.Error Storage_types.Mailbox_not_found ->
617
-
send_response flow (No {
618
-
tag = Some tag;
619
-
code = Some Code_trycreate;
620
-
text = "Destination mailbox does not exist"
621
-
});
622
-
state
623
-
| Result.Error _ ->
624
-
send_response flow (No { tag = Some tag; code = None; text = "MOVE failed" });
625
-
state
626
-
| Result.Ok dst_uids ->
627
-
(* UIDPLUS: include COPYUID response code for MOVE as well *)
628
-
let uidvalidity = match Storage.select_mailbox t.storage ~username mailbox ~readonly:true with
629
-
| Result.Ok mb -> mb.uidvalidity
630
-
| Result.Error _ -> 1l
631
-
in
632
-
let dst_set = List.map (fun uid -> Single (Int32.to_int uid)) dst_uids in
633
-
send_response flow (Ok {
634
-
tag = Some tag;
635
-
code = Some (Code_copyuid (uidvalidity, sequence, dst_set));
636
-
text = "MOVE completed"
637
-
});
638
-
state
639
-
end
640
-
| _ ->
641
-
send_response flow (Bad {
642
-
tag = Some tag;
643
-
code = None;
644
-
text = "Command not valid in this state"
645
-
});
646
-
state
647
-
648
-
(** Process SEARCH command.
649
-
@see <https://datatracker.ietf.org/doc/html/rfc6855#section-3> RFC 6855 Section 3
650
-
After ENABLE UTF8=ACCEPT, SEARCH with CHARSET is rejected. *)
651
-
let handle_search t flow tag ~charset ~criteria state =
652
-
match state with
653
-
| Selected { username; mailbox; utf8_enabled; _ } ->
654
-
(* RFC 6855 Section 3: After ENABLE UTF8=ACCEPT, reject SEARCH with CHARSET *)
655
-
if utf8_enabled && Option.is_some charset then begin
656
-
send_response flow (Bad {
657
-
tag = Some tag;
658
-
code = None;
659
-
text = "CHARSET not allowed after ENABLE UTF8=ACCEPT"
660
-
});
661
-
state
662
-
end else begin
663
-
match Storage.search t.storage ~username ~mailbox ~criteria with
664
-
| Result.Error _ ->
665
-
send_response flow (No { tag = Some tag; code = None; text = "SEARCH failed" });
666
-
state
667
-
| Result.Ok uids ->
668
-
(* Send ESEARCH response per RFC 9051 *)
669
-
let results = if List.length uids > 0 then
670
-
[Esearch_count (List.length uids); Esearch_all (List.map (fun uid -> Single (Int32.to_int uid)) uids)]
671
-
else
672
-
[Esearch_count 0]
673
-
in
674
-
send_response flow (Esearch { tag = Some tag; uid = false; results });
675
-
send_response flow (Ok { tag = Some tag; code = None; text = "SEARCH completed" });
676
-
state
677
-
end
678
-
| _ ->
679
-
send_response flow (Bad {
680
-
tag = Some tag;
681
-
code = None;
682
-
text = "Command not valid in this state"
683
-
});
684
-
state
685
-
686
-
(** Process THREAD command - RFC 5256.
687
-
688
-
The THREAD command is used to retrieve message threads from a mailbox.
689
-
It takes an algorithm, charset, and search criteria, returning threads
690
-
of messages matching the criteria.
691
-
692
-
Note: This is a basic stub implementation that returns empty threads.
693
-
A full implementation would require:
694
-
- ORDEREDSUBJECT: subject.ml for base subject extraction (RFC 5256 Section 2.1)
695
-
- REFERENCES: Message-ID/In-Reply-To/References header parsing
696
-
697
-
@see <https://datatracker.ietf.org/doc/html/rfc5256#section-3> RFC 5256 Section 3 *)
698
-
let handle_thread _t flow tag ~algorithm ~charset:_ ~criteria:_ state =
699
-
match state with
700
-
| Selected { username = _; mailbox = _; _ } ->
701
-
(* TODO: Implement actual threading algorithms.
702
-
For now, return empty thread result.
703
-
Full implementation would:
704
-
1. Search for messages matching criteria
705
-
2. Apply ORDEREDSUBJECT or REFERENCES algorithm
706
-
3. Build thread tree structure *)
707
-
let _ = algorithm in (* Acknowledge the algorithm parameter *)
708
-
send_response flow (Thread_response []);
709
-
send_response flow (Ok { tag = Some tag; code = None; text = "THREAD completed" });
710
-
state
711
-
| _ ->
712
-
send_response flow (Bad {
713
-
tag = Some tag;
714
-
code = None;
715
-
text = "THREAD requires selected state"
716
-
});
717
-
state
718
-
719
-
(* Process APPEND command *)
720
-
let handle_append t flow tag ~mailbox ~flags ~date ~message state =
721
-
(* Security: Validate mailbox name *)
722
-
if not (Protocol.is_safe_mailbox_name mailbox) then begin
723
-
send_response flow (No { tag = Some tag; code = None; text = "Invalid mailbox name" });
724
-
state
725
-
end else
726
-
let username = match state with
727
-
| Authenticated { username; _ } -> Some username
728
-
| Selected { username; _ } -> Some username
729
-
| _ -> None
730
-
in
731
-
match username with
732
-
| None ->
733
-
send_response flow (Bad {
734
-
tag = Some tag;
735
-
code = None;
736
-
text = "Command not valid in this state"
737
-
});
738
-
state
739
-
| Some username ->
740
-
match Storage.append t.storage ~username ~mailbox ~flags ~date ~message with
741
-
| Result.Error Storage_types.Mailbox_not_found ->
742
-
send_response flow (No {
743
-
tag = Some tag;
744
-
code = Some Code_trycreate;
745
-
text = "Mailbox does not exist"
746
-
});
747
-
state
748
-
| Result.Error _ ->
749
-
send_response flow (No { tag = Some tag; code = None; text = "APPEND failed" });
750
-
state
751
-
| Result.Ok uid ->
752
-
(* Get UIDVALIDITY for response *)
753
-
let uidvalidity = match Storage.select_mailbox t.storage ~username mailbox ~readonly:true with
754
-
| Result.Ok mb -> mb.uidvalidity
755
-
| Result.Error _ -> 1l
756
-
in
757
-
send_response flow (Ok {
758
-
tag = Some tag;
759
-
code = Some (Code_appenduid (uidvalidity, uid));
760
-
text = "APPEND completed"
761
-
});
762
-
state
763
-
764
-
(* Process NAMESPACE command - RFC 2342 *)
765
-
let handle_namespace flow tag state =
766
-
match state with
767
-
| Authenticated _ | Selected _ ->
768
-
send_response flow (Namespace_response {
769
-
personal = Some [{ prefix = ""; delimiter = Some '/' }];
770
-
other = None;
771
-
shared = None;
772
-
});
773
-
send_response flow (Ok { tag = Some tag; code = None; text = "NAMESPACE completed" });
774
-
state
775
-
| _ ->
776
-
send_response flow (Bad {
777
-
tag = Some tag;
778
-
code = None;
779
-
text = "Command not valid in this state"
780
-
});
781
-
state
782
-
783
-
(** Process ENABLE command - RFC 5161, RFC 6855.
784
-
After ENABLE UTF8=ACCEPT, the session accepts UTF-8 in quoted-strings.
785
-
@see <https://datatracker.ietf.org/doc/html/rfc5161> RFC 5161: ENABLE Extension
786
-
@see <https://datatracker.ietf.org/doc/html/rfc6855#section-3> RFC 6855 Section 3 *)
787
-
let handle_enable flow tag ~capabilities state =
788
-
match state with
789
-
| Authenticated { username; utf8_enabled } ->
790
-
(* Filter to capabilities we actually support *)
791
-
let enabled = List.filter (fun cap ->
792
-
let cap_upper = String.uppercase_ascii cap in
793
-
cap_upper = "IMAP4REV2" || cap_upper = "UTF8=ACCEPT"
794
-
) capabilities in
795
-
(* Check if UTF8=ACCEPT was requested and enabled *)
796
-
let new_utf8_enabled = utf8_enabled || List.exists (fun cap ->
797
-
String.uppercase_ascii cap = "UTF8=ACCEPT"
798
-
) enabled in
799
-
if List.length enabled > 0 then
800
-
send_response flow (Enabled enabled);
801
-
send_response flow (Ok { tag = Some tag; code = None; text = "ENABLE completed" });
802
-
Authenticated { username; utf8_enabled = new_utf8_enabled }
803
-
| _ ->
804
-
send_response flow (Bad {
805
-
tag = Some tag;
806
-
code = None;
807
-
text = "ENABLE only valid in authenticated state before SELECT"
808
-
});
809
-
state
810
-
811
-
(* Process SUBSCRIBE/UNSUBSCRIBE - simplified, just succeed *)
812
-
let handle_subscribe flow tag _mailbox state =
813
-
match state with
814
-
| Authenticated _ | Selected _ ->
815
-
send_response flow (Ok { tag = Some tag; code = None; text = "SUBSCRIBE completed" });
816
-
state
817
-
| _ ->
818
-
send_response flow (Bad {
819
-
tag = Some tag;
820
-
code = None;
821
-
text = "Command not valid in this state"
822
-
});
823
-
state
824
-
825
-
let handle_unsubscribe flow tag _mailbox state =
826
-
match state with
827
-
| Authenticated _ | Selected _ ->
828
-
send_response flow (Ok { tag = Some tag; code = None; text = "UNSUBSCRIBE completed" });
829
-
state
830
-
| _ ->
831
-
send_response flow (Bad {
832
-
tag = Some tag;
833
-
code = None;
834
-
text = "Command not valid in this state"
835
-
});
836
-
state
837
-
838
-
(* Process IDLE command - RFC 2177 *)
839
-
let handle_idle flow tag read_line_fn state =
840
-
match state with
841
-
| Authenticated _ | Selected _ ->
842
-
send_response flow (Continuation (Some "idling"));
843
-
(* Wait for DONE from client *)
844
-
let rec wait_for_done () =
845
-
match read_line_fn () with
846
-
| None -> () (* Connection closed *)
847
-
| Some line ->
848
-
let trimmed = String.trim (String.uppercase_ascii line) in
849
-
if trimmed = "DONE" then
850
-
send_response flow (Ok { tag = Some tag; code = None; text = "IDLE terminated" })
851
-
else
852
-
wait_for_done ()
853
-
in
854
-
wait_for_done ();
855
-
state
856
-
| _ ->
857
-
send_response flow (Bad {
858
-
tag = Some tag;
859
-
code = None;
860
-
text = "Command not valid in this state"
861
-
});
862
-
state
863
-
864
-
(* Main command dispatcher *)
865
-
let rec handle_command t flow ~read_line_fn ~tls_active cmd state =
866
-
let tag = cmd.tag in
867
-
match cmd.command with
868
-
| Capability -> handle_capability t flow tag ~tls_active; (state, Continue)
869
-
| Noop -> handle_noop flow tag; (state, Continue)
870
-
| Id params -> handle_id flow tag params; (state, Continue)
871
-
| Logout -> (handle_logout flow tag, Continue)
872
-
| Login { username; password } -> (handle_login t flow tag ~username ~password ~tls_active state, Continue)
873
-
| Select mailbox -> (handle_select t flow tag mailbox ~readonly:false state, Continue)
874
-
| Examine mailbox -> (handle_select t flow tag mailbox ~readonly:true state, Continue)
875
-
| List list_cmd -> (handle_list t flow tag list_cmd state, Continue)
876
-
| Status { mailbox; items } -> (handle_status t flow tag mailbox ~items state, Continue)
877
-
| Fetch { sequence; items } -> (handle_fetch t flow tag ~sequence ~items state, Continue)
878
-
| Store { sequence; silent; action; flags } -> (handle_store t flow tag ~sequence ~silent ~action ~flags state, Continue)
879
-
| Expunge -> (handle_expunge t flow tag state, Continue)
880
-
| Close -> (handle_close t flow tag state, Continue)
881
-
| Unselect -> (handle_unselect flow tag state, Continue)
882
-
| Create mailbox -> (handle_create t flow tag mailbox state, Continue)
883
-
| Delete mailbox -> (handle_delete t flow tag mailbox state, Continue)
884
-
| Rename { old_name; new_name } -> (handle_rename t flow tag ~old_name ~new_name state, Continue)
885
-
| Copy { sequence; mailbox } -> (handle_copy t flow tag ~sequence ~mailbox state, Continue)
886
-
| Move { sequence; mailbox } -> (handle_move t flow tag ~sequence ~mailbox state, Continue)
887
-
| Search { charset; criteria } -> (handle_search t flow tag ~charset ~criteria state, Continue)
888
-
| Thread { algorithm; charset; criteria } -> (handle_thread t flow tag ~algorithm ~charset ~criteria state, Continue)
889
-
| Append { mailbox; flags; date; message } -> (handle_append t flow tag ~mailbox ~flags ~date ~message state, Continue)
890
-
| Namespace -> (handle_namespace flow tag state, Continue)
891
-
| Enable caps -> (handle_enable flow tag ~capabilities:caps state, Continue)
892
-
| Subscribe mailbox -> (handle_subscribe flow tag mailbox state, Continue)
893
-
| Unsubscribe mailbox -> (handle_unsubscribe flow tag mailbox state, Continue)
894
-
| Idle -> (handle_idle flow tag read_line_fn state, Continue)
895
-
| Uid uid_cmd -> (handle_uid_command t flow tag ~read_line_fn uid_cmd state, Continue)
896
-
| Starttls ->
897
-
(match t.config.tls_config with
898
-
| None ->
899
-
send_response flow (Bad { tag = Some tag; code = None; text = "STARTTLS not available" });
900
-
(state, Continue)
901
-
| Some _ when tls_active ->
902
-
send_response flow (Bad { tag = Some tag; code = None; text = "TLS already active" });
903
-
(state, Continue)
904
-
| Some _ when state <> Not_authenticated ->
905
-
send_response flow (Bad { tag = Some tag; code = None; text = "STARTTLS only valid before authentication" });
906
-
(state, Continue)
907
-
| Some _ ->
908
-
(* Signal to connection handler to upgrade *)
909
-
(state, Upgrade_tls tag))
910
-
| Authenticate _ ->
911
-
send_response flow (No { tag = Some tag; code = None; text = "Use LOGIN instead" });
912
-
(state, Continue)
913
-
(* QUOTA extension - RFC 9208 *)
914
-
| Getquota root ->
915
-
(* GETQUOTA returns quota information for a quota root *)
916
-
(* For now, return empty quota - storage backend would provide real data *)
917
-
send_response flow (Quota_response { root; resources = [] });
918
-
send_response flow (Ok { tag = Some tag; code = None; text = "GETQUOTA completed" });
919
-
(state, Continue)
920
-
| Getquotaroot mailbox ->
921
-
(* GETQUOTAROOT returns the quota roots for a mailbox *)
922
-
(* Typically the user's root is the quota root *)
923
-
let roots = [mailbox] in (* Simplified: use mailbox as its own quota root *)
924
-
send_response flow (Quotaroot_response { mailbox; roots });
925
-
(* Also send QUOTA responses for each root *)
926
-
List.iter (fun root ->
927
-
send_response flow (Quota_response { root; resources = [] })
928
-
) roots;
929
-
send_response flow (Ok { tag = Some tag; code = None; text = "GETQUOTAROOT completed" });
930
-
(state, Continue)
931
-
| Setquota { root; limits = _ } ->
932
-
(* SETQUOTA is admin-only in most implementations *)
933
-
send_response flow (No {
934
-
tag = Some tag;
935
-
code = Some Code_noperm;
936
-
text = Printf.sprintf "Cannot set quota for %s" root
937
-
});
938
-
(state, Continue)
939
-
940
-
(* Handle UID prefixed commands *)
941
-
and handle_uid_command t flow tag ~read_line_fn:_ uid_cmd state =
942
-
match uid_cmd with
943
-
| Uid_fetch { sequence; items } ->
944
-
(* For UID FETCH, sequence is UIDs not sequence numbers *)
945
-
handle_fetch t flow tag ~sequence ~items state
946
-
| Uid_store { sequence; silent; action; flags } ->
947
-
handle_store t flow tag ~sequence ~silent ~action ~flags state
948
-
| Uid_copy { sequence; mailbox } ->
949
-
handle_copy t flow tag ~sequence ~mailbox state
950
-
| Uid_move { sequence; mailbox } ->
951
-
handle_move t flow tag ~sequence ~mailbox state
952
-
| Uid_search { charset; criteria } ->
953
-
handle_search t flow tag ~charset ~criteria state
954
-
| Uid_expunge _sequence ->
955
-
(* UID EXPUNGE only expunges messages in the given UID set *)
956
-
handle_expunge t flow tag state
957
-
| Uid_thread { algorithm; charset; criteria } ->
958
-
(* UID THREAD returns UIDs instead of sequence numbers *)
959
-
handle_thread t flow tag ~algorithm ~charset ~criteria state
960
-
961
-
(* Maximum line length to prevent DoS attacks via memory exhaustion.
962
-
RFC 9051 Section 4 recommends supporting lines up to 8192 octets. *)
963
-
let max_line_length = 65536
964
-
965
-
(* Read a line from the client *)
966
-
let read_line flow =
967
-
let buf = Buffer.create 256 in
968
-
let cs = Cstruct.create 1 in
969
-
let rec loop () =
970
-
try
971
-
(* Security: Prevent memory exhaustion from unbounded line length *)
972
-
if Buffer.length buf > max_line_length then
973
-
None (* Reject overly long lines *)
974
-
else
975
-
let n = Eio.Flow.single_read flow cs in
976
-
if n = 0 then
977
-
None
978
-
else begin
979
-
let c = Cstruct.get_char cs 0 in
980
-
Buffer.add_char buf c;
981
-
if c = '\n' && Buffer.length buf >= 2 &&
982
-
Buffer.nth buf (Buffer.length buf - 2) = '\r' then
983
-
Some (Buffer.contents buf)
984
-
else
985
-
loop ()
986
-
end
987
-
with End_of_file ->
988
-
if Buffer.length buf > 0 then Some (Buffer.contents buf) else None
989
-
in
990
-
loop ()
991
-
992
-
(* Main command loop - returns when connection should close or upgrade TLS *)
993
-
let rec command_loop t flow state tls_active =
994
-
let read_line_fn () = read_line flow in
995
-
match state with
996
-
| Logout -> `Done
997
-
| _ ->
998
-
match read_line flow with
999
-
| None -> `Done (* Connection closed *)
1000
-
| Some line ->
1001
-
match parse_command line with
1002
-
| Error _msg ->
1003
-
send_response flow (Bad {
1004
-
tag = None;
1005
-
code = None;
1006
-
text = "Invalid command syntax"
1007
-
});
1008
-
command_loop t flow state tls_active
1009
-
| Result.Ok cmd ->
1010
-
let (new_state, action) = handle_command t flow ~read_line_fn ~tls_active cmd state in
1011
-
match action with
1012
-
| Continue -> command_loop t flow new_state tls_active
1013
-
| Upgrade_tls tag -> `Upgrade_tls (tag, new_state)
1014
-
1015
-
(* Internal connection handler with TLS state *)
1016
-
let handle_connection_internal t (flow : _ Eio.Flow.two_way) ~tls_active ~send_greeting:should_greet ~initial_state =
1017
-
(* Send greeting only for new connections *)
1018
-
if should_greet then send_greeting t flow ~tls_active;
1019
-
command_loop t flow initial_state tls_active
1020
-
1021
-
(* Connection handler for cleartext connections (may upgrade to TLS) *)
1022
-
let handle_connection t flow _addr =
1023
-
match handle_connection_internal t flow ~tls_active:false ~send_greeting:true ~initial_state:Not_authenticated with
1024
-
| `Done -> ()
1025
-
| `Upgrade_tls (tag, state) ->
1026
-
(* Upgrade to TLS *)
1027
-
match t.config.tls_config with
1028
-
| None ->
1029
-
send_response flow (Bad { tag = Some tag; code = None; text = "TLS not configured" })
1030
-
| Some tls_config ->
1031
-
(* Send OK before upgrading *)
1032
-
send_response flow (Ok { tag = Some tag; code = None; text = "Begin TLS negotiation" });
1033
-
(* Upgrade the connection to TLS *)
1034
-
let tls_flow = Tls_eio.server_of_flow tls_config flow in
1035
-
(* Continue with TLS-wrapped flow, preserving state (which is Not_authenticated after STARTTLS) *)
1036
-
(* Per RFC 3501, STARTTLS does not send a new greeting, session continues *)
1037
-
ignore (handle_connection_internal t (tls_flow :> _ Eio.Flow.two_way) ~tls_active:true ~send_greeting:false ~initial_state:state)
1038
-
1039
-
(* Connection handler for already-TLS connections (implicit TLS on port 993) *)
1040
-
let handle_connection_tls t tls_flow _addr =
1041
-
ignore (handle_connection_internal t (tls_flow :> _ Eio.Flow.two_way) ~tls_active:true ~send_greeting:true ~initial_state:Not_authenticated)
1042
-
1043
-
(* Run server on cleartext port - single process mode (no privilege separation) *)
1044
-
let run t ~sw ~net ~addr ?(after_bind = fun () -> ()) () =
1045
-
let socket = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:128 addr in
1046
-
after_bind ();
1047
-
let rec accept_loop () =
1048
-
Eio.Net.accept_fork socket ~sw
1049
-
~on_error:(fun exn -> Eio.traceln "Connection error: %a" Fmt.exn exn)
1050
-
(fun flow addr -> handle_connection t flow addr);
1051
-
accept_loop ()
1052
-
in
1053
-
accept_loop ()
1054
-
1055
-
(* Run server on TLS port - single process mode (no privilege separation) *)
1056
-
let run_tls t ~sw ~net ~addr ~tls_config ?(after_bind = fun () -> ()) () =
1057
-
let socket = Eio.Net.listen net ~sw ~reuse_addr:true ~backlog:128 addr in
1058
-
after_bind ();
1059
-
let rec accept_loop () =
1060
-
Eio.Net.accept_fork socket ~sw
1061
-
~on_error:(fun exn -> Eio.traceln "Connection error: %a" Fmt.exn exn)
1062
-
(fun flow addr ->
1063
-
let tls_flow = Tls_eio.server_of_flow tls_config flow in
1064
-
handle_connection_tls t tls_flow addr);
1065
-
accept_loop ()
1066
-
in
1067
-
accept_loop ()
1068
-
1069
-
(* Drop privileges to the authenticated user *)
1070
-
let drop_to_user username =
1071
-
try
1072
-
let pw = Unix.getpwnam username in
1073
-
(* Set supplementary groups first *)
1074
-
Unix.initgroups username pw.Unix.pw_gid;
1075
-
(* Set GID before UID (can't change GID after dropping root) *)
1076
-
Unix.setgid pw.Unix.pw_gid;
1077
-
Unix.setuid pw.Unix.pw_uid;
1078
-
true
1079
-
with
1080
-
| Not_found -> false
1081
-
| Unix.Unix_error _ -> false
1082
-
1083
-
(* Fork-based connection handler for privilege separation.
1084
-
Each connection runs in its own process as the authenticated user. *)
1085
-
let handle_connection_forked t flow _addr ~tls_active =
1086
-
send_greeting t flow ~tls_active;
1087
-
(* Authentication loop - runs as root *)
1088
-
let rec auth_loop () =
1089
-
match read_line flow with
1090
-
| None -> () (* Connection closed *)
1091
-
| Some line ->
1092
-
match parse_command line with
1093
-
| Error _ ->
1094
-
send_response flow (Bad { tag = None; code = None; text = "Invalid command syntax" });
1095
-
auth_loop ()
1096
-
| Result.Ok cmd ->
1097
-
match cmd.command with
1098
-
| Login { username; password } ->
1099
-
if not (Protocol.is_safe_username username) then begin
1100
-
send_response flow (No {
1101
-
tag = Some cmd.tag;
1102
-
code = Some Code_authenticationfailed;
1103
-
text = "LOGIN failed"
1104
-
});
1105
-
auth_loop ()
1106
-
end else if Auth.authenticate t.auth ~username ~password then begin
1107
-
(* Authentication succeeded - drop privileges to this user *)
1108
-
if drop_to_user username then begin
1109
-
let caps = all_capabilities t ~tls_active in
1110
-
send_response flow (Ok {
1111
-
tag = Some cmd.tag;
1112
-
code = Some (Code_capability caps);
1113
-
text = "LOGIN completed"
1114
-
});
1115
-
(* Continue session as authenticated user *)
1116
-
let state = Authenticated { username; utf8_enabled = false } in
1117
-
ignore (command_loop t flow state tls_active)
1118
-
end else begin
1119
-
(* Failed to drop privileges *)
1120
-
send_response flow (No {
1121
-
tag = Some cmd.tag;
1122
-
code = Some Code_authenticationfailed;
1123
-
text = "LOGIN failed"
1124
-
});
1125
-
auth_loop ()
1126
-
end
1127
-
end else begin
1128
-
send_response flow (No {
1129
-
tag = Some cmd.tag;
1130
-
code = Some Code_authenticationfailed;
1131
-
text = "LOGIN failed"
1132
-
});
1133
-
auth_loop ()
1134
-
end
1135
-
| Capability ->
1136
-
handle_capability t flow cmd.tag ~tls_active;
1137
-
auth_loop ()
1138
-
| Noop ->
1139
-
handle_noop flow cmd.tag;
1140
-
auth_loop ()
1141
-
| Id params ->
1142
-
handle_id flow cmd.tag params;
1143
-
auth_loop ()
1144
-
| Logout ->
1145
-
ignore (handle_logout flow cmd.tag);
1146
-
() (* Exit *)
1147
-
| Starttls ->
1148
-
(* STARTTLS not supported in forked mode - would need to pass TLS state *)
1149
-
send_response flow (Bad { tag = Some cmd.tag; code = None; text = "STARTTLS not supported in this mode" });
1150
-
auth_loop ()
1151
-
| _ ->
1152
-
send_response flow (Bad {
1153
-
tag = Some cmd.tag;
1154
-
code = None;
1155
-
text = "Please authenticate first"
1156
-
});
1157
-
auth_loop ()
1158
-
in
1159
-
auth_loop ()
1160
-
1161
-
(* Run server with fork-per-connection privilege separation.
1162
-
Requires running as root. Each connection forks and drops to the authenticated user. *)
1163
-
let run_forked t ~sw:_ ~net:_ ~addr ~tls_config =
1164
-
(* Extract port and address for raw socket operations *)
1165
-
let port, bind_addr = match addr with
1166
-
| `Tcp (ip, port) ->
1167
-
let addr_str =
1168
-
if ip = Eio.Net.Ipaddr.V4.loopback then "127.0.0.1"
1169
-
else if ip = Eio.Net.Ipaddr.V4.any then "0.0.0.0"
1170
-
else
1171
-
(* Format IP address to string *)
1172
-
Format.asprintf "%a" Eio.Net.Ipaddr.pp ip
1173
-
in
1174
-
(port, Unix.inet_addr_of_string addr_str)
1175
-
| _ -> failwith "Only TCP addresses supported"
1176
-
in
1177
-
(* Create listening socket *)
1178
-
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
1179
-
Unix.setsockopt sock Unix.SO_REUSEADDR true;
1180
-
Unix.bind sock (Unix.ADDR_INET (bind_addr, port));
1181
-
Unix.listen sock 128;
1182
-
1183
-
(* Reap zombie children *)
1184
-
Sys.set_signal Sys.sigchld (Sys.Signal_handle (fun _ ->
1185
-
try while fst (Unix.waitpid [Unix.WNOHANG] (-1)) > 0 do () done
1186
-
with Unix.Unix_error (Unix.ECHILD, _, _) -> ()
1187
-
));
1188
-
1189
-
(* Accept loop - handle EINTR from signal handlers *)
1190
-
let rec accept_with_retry () =
1191
-
try Unix.accept sock
1192
-
with Unix.Unix_error (Unix.EINTR, _, _) -> accept_with_retry ()
1193
-
in
1194
-
while true do
1195
-
let client_sock, _client_addr = accept_with_retry () in
1196
-
match Unix.fork () with
1197
-
| 0 ->
1198
-
(* Child process *)
1199
-
Unix.close sock; (* Close listening socket in child *)
1200
-
(* Run EIO for this connection *)
1201
-
Eio_main.run @@ fun _env ->
1202
-
Eio.Switch.run @@ fun sw ->
1203
-
let flow = Eio_unix.Net.import_socket_stream ~sw ~close_unix:true client_sock in
1204
-
(match tls_config with
1205
-
| None ->
1206
-
handle_connection_forked t flow () ~tls_active:false
1207
-
| Some tls_cfg ->
1208
-
let tls_flow = Tls_eio.server_of_flow tls_cfg flow in
1209
-
handle_connection_forked t (tls_flow :> _ Eio.Flow.two_way) () ~tls_active:true);
1210
-
exit 0
1211
-
| _pid ->
1212
-
(* Parent process *)
1213
-
Unix.close client_sock (* Close client socket in parent *)
1214
-
done
1215
-
end
-120
lib/imapd/server.mli
-120
lib/imapd/server.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** IMAP4rev2 Server
7
-
8
-
This module implements the IMAP server connection handler and state machine
9
-
as specified in {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051}.
10
-
11
-
{2 References}
12
-
{ul
13
-
{- {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} - IMAP4rev2}
14
-
{- {{:https://datatracker.ietf.org/doc/html/rfc9051#section-3}RFC 9051 Section 3} - State and Flow Diagram}
15
-
{- {{:https://datatracker.ietf.org/doc/html/rfc8314}RFC 8314} - Use of TLS for Email}} *)
16
-
17
-
(** {1 Server Configuration} *)
18
-
19
-
type config = {
20
-
hostname : string;
21
-
(** Server hostname for greeting. *)
22
-
23
-
capabilities : string list;
24
-
(** Additional capabilities to advertise. *)
25
-
26
-
greeting : string option;
27
-
(** Custom greeting message. *)
28
-
29
-
autologout_timeout : float;
30
-
(** Inactivity timeout in seconds. Default 1800 (30 minutes) per RFC 9051. *)
31
-
32
-
tls_config : Tls.Config.server option;
33
-
(** TLS configuration for STARTTLS support. If provided, STARTTLS capability
34
-
is advertised and clients can upgrade to TLS mid-connection. *)
35
-
}
36
-
37
-
val default_config : config
38
-
(** Default server configuration. *)
39
-
40
-
(** {1 Server Functor}
41
-
42
-
Create a server instance with a specific storage backend. *)
43
-
44
-
module Make
45
-
(Storage : Storage.STORAGE)
46
-
(Auth : Auth.AUTH) : sig
47
-
48
-
type t
49
-
(** Server instance. *)
50
-
51
-
val create : config:config -> storage:Storage.t -> auth:Auth.t -> t
52
-
(** Create a new server instance. *)
53
-
54
-
(** {2 Connection Handling} *)
55
-
56
-
val handle_connection :
57
-
t ->
58
-
[> `Close | `Flow | `R | `Shutdown | `W ] Eio.Resource.t ->
59
-
_ ->
60
-
unit
61
-
(** Handle a single client connection.
62
-
63
-
This implements the IMAP state machine:
64
-
- Sends greeting
65
-
- Processes commands
66
-
- Manages state transitions
67
-
- Handles logout/disconnect *)
68
-
69
-
(** {2 Running the Server} *)
70
-
71
-
val run :
72
-
t ->
73
-
sw:Eio.Switch.t ->
74
-
net:'a Eio.Net.t ->
75
-
addr:Eio.Net.Sockaddr.stream ->
76
-
?after_bind:(unit -> unit) ->
77
-
unit ->
78
-
unit
79
-
(** Run the server on a cleartext port (143).
80
-
81
-
@param after_bind Optional callback invoked after binding but before
82
-
accepting connections. Use for privilege dropping.
83
-
84
-
Implements {{:https://datatracker.ietf.org/doc/html/rfc9051#section-2.1}RFC 9051 Section 2.1}. *)
85
-
86
-
val run_tls :
87
-
t ->
88
-
sw:Eio.Switch.t ->
89
-
net:'a Eio.Net.t ->
90
-
addr:Eio.Net.Sockaddr.stream ->
91
-
tls_config:Tls.Config.server ->
92
-
?after_bind:(unit -> unit) ->
93
-
unit ->
94
-
unit
95
-
(** Run the server on an implicit TLS port (993).
96
-
97
-
@param after_bind Optional callback invoked after binding but before
98
-
accepting connections. Use for privilege dropping.
99
-
100
-
Implements {{:https://datatracker.ietf.org/doc/html/rfc8314#section-3.2}RFC 8314 Section 3.2}. *)
101
-
102
-
val run_forked :
103
-
t ->
104
-
sw:Eio.Switch.t ->
105
-
net:'a Eio.Net.t ->
106
-
addr:Eio.Net.Sockaddr.stream ->
107
-
tls_config:Tls.Config.server option ->
108
-
unit
109
-
(** Run the server with fork-per-connection privilege separation.
110
-
111
-
Each incoming connection forks a child process. After successful
112
-
authentication, the child drops privileges to the authenticated user
113
-
via setuid/setgid. This provides strong isolation between users.
114
-
115
-
Requires running as root. STARTTLS is not supported in this mode
116
-
(use implicit TLS instead).
117
-
118
-
This is the recommended mode for production deployments. *)
119
-
end
120
-
-1154
lib/imapd/storage.ml
-1154
lib/imapd/storage.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** IMAP Storage Backends
7
-
8
-
Implements storage for {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051}. *)
9
-
10
-
open Protocol
11
-
12
-
(* Storage errors *)
13
-
type error =
14
-
| Mailbox_not_found
15
-
| Mailbox_already_exists
16
-
| Message_not_found
17
-
| Permission_denied
18
-
| Storage_error of string
19
-
| Quota_exceeded
20
-
21
-
let error_to_string = function
22
-
| Mailbox_not_found -> "Mailbox not found"
23
-
| Mailbox_already_exists -> "Mailbox already exists"
24
-
| Message_not_found -> "Message not found"
25
-
| Permission_denied -> "Permission denied"
26
-
| Storage_error msg -> "Storage error: " ^ msg
27
-
| Quota_exceeded -> "Quota exceeded"
28
-
29
-
(** Format month name for IMAP internal date format *)
30
-
let month_name = function
31
-
| 0 -> "Jan" | 1 -> "Feb" | 2 -> "Mar" | 3 -> "Apr"
32
-
| 4 -> "May" | 5 -> "Jun" | 6 -> "Jul" | 7 -> "Aug"
33
-
| 8 -> "Sep" | 9 -> "Oct" | 10 -> "Nov" | _ -> "Dec"
34
-
35
-
(** Format Unix time as IMAP internal date string *)
36
-
let format_internal_date tm =
37
-
Printf.sprintf "%02d-%s-%04d %02d:%02d:%02d +0000"
38
-
tm.Unix.tm_mday
39
-
(month_name tm.Unix.tm_mon)
40
-
(1900 + tm.Unix.tm_year)
41
-
tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
42
-
43
-
(** Check if UID matches a sequence range *)
44
-
let uid_in_range uid range =
45
-
let uid_int = Int32.to_int uid in
46
-
match range with
47
-
| Single n -> uid_int = n
48
-
| Range (a, b) -> uid_int >= a && uid_int <= b
49
-
| From n -> uid_int >= n
50
-
| All -> true
51
-
52
-
(** Check if UID matches any range in sequence set *)
53
-
let uid_matches_set uid seqs =
54
-
List.exists (uid_in_range uid) seqs
55
-
56
-
(* Mailbox information *)
57
-
type mailbox_info = {
58
-
name : mailbox_name;
59
-
delimiter : char option;
60
-
flags : list_flag list;
61
-
}
62
-
63
-
(** Get SPECIAL-USE flags for a mailbox based on its name (RFC 6154) *)
64
-
let get_special_use_for_mailbox name =
65
-
match String.lowercase_ascii name with
66
-
| "drafts" -> [List_drafts]
67
-
| "sent" | "sent messages" | "sent items" -> [List_sent]
68
-
| "trash" | "deleted messages" | "deleted items" -> [List_trash]
69
-
| "junk" | "spam" -> [List_junk]
70
-
| "archive" -> [List_archive]
71
-
| _ -> []
72
-
73
-
(* Storage backend signature *)
74
-
module type STORAGE = sig
75
-
type t
76
-
77
-
val create : unit -> t
78
-
79
-
val list_mailboxes :
80
-
t -> username:string -> reference:string -> pattern:string -> mailbox_info list
81
-
82
-
val create_mailbox : t -> username:string -> mailbox_name -> (unit, error) result
83
-
val delete_mailbox : t -> username:string -> mailbox_name -> (unit, error) result
84
-
val rename_mailbox : t -> username:string -> old_name:mailbox_name -> new_name:mailbox_name -> (unit, error) result
85
-
val select_mailbox : t -> username:string -> mailbox_name -> readonly:bool -> (mailbox_state, error) result
86
-
val status_mailbox : t -> username:string -> mailbox_name -> items:status_item list -> ((status_item * int64) list, error) result
87
-
88
-
val fetch_messages : t -> username:string -> mailbox:mailbox_name -> sequence:sequence_set -> items:fetch_item list -> (message list, error) result
89
-
val fetch_by_uid : t -> username:string -> mailbox:mailbox_name -> uids:sequence_set -> items:fetch_item list -> (message list, error) result
90
-
val store_flags : t -> username:string -> mailbox:mailbox_name -> sequence:sequence_set -> action:store_action -> flags:flag list -> (message list, error) result
91
-
val expunge : t -> username:string -> mailbox:mailbox_name -> (uid list, error) result
92
-
val append : t -> username:string -> mailbox:mailbox_name -> flags:flag list -> date:string option -> message:string -> (uid, error) result
93
-
val copy : t -> username:string -> src_mailbox:mailbox_name -> sequence:sequence_set -> dst_mailbox:mailbox_name -> (uid list, error) result
94
-
val move : t -> username:string -> src_mailbox:mailbox_name -> sequence:sequence_set -> dst_mailbox:mailbox_name -> (uid list, error) result
95
-
val search : t -> username:string -> mailbox:mailbox_name -> criteria:search_key -> (uid list, error) result
96
-
end
97
-
98
-
(* ===== In-Memory Storage ===== *)
99
-
100
-
module Memory_storage = struct
101
-
(* Internal mailbox representation *)
102
-
type mailbox = {
103
-
mutable messages : message list;
104
-
uidvalidity : uidvalidity;
105
-
mutable uidnext : uid;
106
-
flags : flag list;
107
-
}
108
-
109
-
(* User data *)
110
-
type user_data = {
111
-
mailboxes : (mailbox_name, mailbox) Hashtbl.t;
112
-
subscriptions : mailbox_name list; [@warning "-69"]
113
-
(** Placeholder for LSUB/SUBSCRIBE support per RFC 9051 Section 6.3.6 *)
114
-
}
115
-
116
-
type t = {
117
-
users : (string, user_data) Hashtbl.t;
118
-
lock : unit; [@warning "-69"]
119
-
(** Placeholder for future Eio mutex for concurrent access *)
120
-
}
121
-
122
-
let create () = {
123
-
users = Hashtbl.create 16;
124
-
lock = ();
125
-
}
126
-
127
-
let get_user t ~username =
128
-
match Hashtbl.find_opt t.users username with
129
-
| Some u -> u
130
-
| None ->
131
-
let u = {
132
-
mailboxes = Hashtbl.create 8;
133
-
subscriptions = [];
134
-
} in
135
-
Hashtbl.add t.users username u;
136
-
u
137
-
138
-
let ensure_inbox user =
139
-
if not (Hashtbl.mem user.mailboxes "INBOX") then begin
140
-
let inbox = {
141
-
messages = [];
142
-
uidvalidity = Int32.of_float (Unix.time ());
143
-
uidnext = 1l;
144
-
flags = [System Seen; System Answered; System Flagged; System Deleted; System Draft];
145
-
} in
146
-
Hashtbl.add user.mailboxes "INBOX" inbox
147
-
end
148
-
149
-
let add_test_user t ~username =
150
-
let user = get_user t ~username in
151
-
ensure_inbox user
152
-
153
-
let add_test_message t ~username ~mailbox ~message =
154
-
let user = get_user t ~username in
155
-
match Hashtbl.find_opt user.mailboxes mailbox with
156
-
| Some mb ->
157
-
mb.messages <- mb.messages @ [message];
158
-
if message.uid >= mb.uidnext then
159
-
mb.uidnext <- Int32.succ message.uid
160
-
| None -> ()
161
-
162
-
(* Pattern matching for LIST command *)
163
-
let matches_pattern ~pattern name =
164
-
if pattern = "*" then true
165
-
else if pattern = "%" then not (String.contains name '/')
166
-
else
167
-
(* Simple prefix matching - full glob support would be more complex *)
168
-
let pattern_len = String.length pattern in
169
-
if pattern_len > 0 && pattern.[pattern_len - 1] = '*' then
170
-
let prefix = String.sub pattern 0 (pattern_len - 1) in
171
-
String.length name >= String.length prefix &&
172
-
String.sub name 0 (String.length prefix) = prefix
173
-
else
174
-
name = pattern
175
-
176
-
let list_mailboxes t ~username ~reference:_ ~pattern =
177
-
let user = get_user t ~username in
178
-
ensure_inbox user;
179
-
Hashtbl.fold (fun name _mb acc ->
180
-
if matches_pattern ~pattern name then
181
-
let flags = get_special_use_for_mailbox name in
182
-
{ name; delimiter = Some '/'; flags } :: acc
183
-
else acc
184
-
) user.mailboxes []
185
-
186
-
let create_mailbox t ~username name =
187
-
let name = normalize_mailbox_name name in
188
-
let user = get_user t ~username in
189
-
if Hashtbl.mem user.mailboxes name then
190
-
Result.Error Mailbox_already_exists
191
-
else begin
192
-
let mb = {
193
-
messages = [];
194
-
uidvalidity = Int32.of_float (Unix.time ());
195
-
uidnext = 1l;
196
-
flags = [System Seen; System Answered; System Flagged; System Deleted; System Draft];
197
-
} in
198
-
Hashtbl.add user.mailboxes name mb;
199
-
Result.Ok ()
200
-
end
201
-
202
-
let delete_mailbox t ~username name =
203
-
let name = normalize_mailbox_name name in
204
-
if is_inbox name then
205
-
Result.Error Permission_denied (* Cannot delete INBOX *)
206
-
else
207
-
let user = get_user t ~username in
208
-
if Hashtbl.mem user.mailboxes name then begin
209
-
Hashtbl.remove user.mailboxes name;
210
-
Result.Ok ()
211
-
end else
212
-
Result.Error Mailbox_not_found
213
-
214
-
let rename_mailbox t ~username ~old_name ~new_name =
215
-
let old_name = normalize_mailbox_name old_name in
216
-
let new_name = normalize_mailbox_name new_name in
217
-
if is_inbox old_name then
218
-
Result.Error Permission_denied (* Cannot rename INBOX directly *)
219
-
else
220
-
let user = get_user t ~username in
221
-
match Hashtbl.find_opt user.mailboxes old_name with
222
-
| None -> Result.Error Mailbox_not_found
223
-
| Some mb ->
224
-
if Hashtbl.mem user.mailboxes new_name then
225
-
Result.Error Mailbox_already_exists
226
-
else begin
227
-
Hashtbl.remove user.mailboxes old_name;
228
-
Hashtbl.add user.mailboxes new_name mb;
229
-
Result.Ok ()
230
-
end
231
-
232
-
let select_mailbox t ~username name ~readonly =
233
-
let name = normalize_mailbox_name name in
234
-
let user = get_user t ~username in
235
-
ensure_inbox user;
236
-
match Hashtbl.find_opt user.mailboxes name with
237
-
| None -> Result.Error Mailbox_not_found
238
-
| Some mb ->
239
-
Result.Ok {
240
-
name;
241
-
exists = List.length mb.messages;
242
-
uidvalidity = mb.uidvalidity;
243
-
uidnext = mb.uidnext;
244
-
flags = mb.flags;
245
-
permanent_flags = mb.flags;
246
-
readonly;
247
-
}
248
-
249
-
let status_mailbox t ~username name ~items =
250
-
let name = normalize_mailbox_name name in
251
-
let user = get_user t ~username in
252
-
match Hashtbl.find_opt user.mailboxes name with
253
-
| None -> Result.Error Mailbox_not_found
254
-
| Some mb ->
255
-
let results = List.map (fun item ->
256
-
let value = match item with
257
-
| Status_messages -> Int64.of_int (List.length mb.messages)
258
-
| Status_uidnext -> Int64.of_int32 mb.uidnext
259
-
| Status_uidvalidity -> Int64.of_int32 mb.uidvalidity
260
-
| Status_unseen ->
261
-
Int64.of_int (List.length (List.filter (fun (m : message) ->
262
-
not (List.mem (System Seen) m.flags)
263
-
) mb.messages))
264
-
| Status_deleted ->
265
-
Int64.of_int (List.length (List.filter (fun (m : message) ->
266
-
List.mem (System Deleted) m.flags
267
-
) mb.messages))
268
-
| Status_size ->
269
-
List.fold_left (fun acc (m : message) -> Int64.add acc m.size) 0L mb.messages
270
-
in
271
-
(item, value)
272
-
) items in
273
-
Result.Ok results
274
-
275
-
(* Check if sequence number matches a range *)
276
-
let seq_in_range seq range max_seq =
277
-
match range with
278
-
| Single n -> seq = n
279
-
| Range (a, b) -> seq >= a && seq <= b
280
-
| From n -> seq >= n && seq <= max_seq
281
-
| All -> seq <= max_seq
282
-
283
-
let seq_matches sequence seq max_seq =
284
-
List.exists (fun range -> seq_in_range seq range max_seq) sequence
285
-
286
-
let fetch_messages t ~username ~mailbox ~sequence ~items:_ =
287
-
let mailbox = normalize_mailbox_name mailbox in
288
-
let user = get_user t ~username in
289
-
match Hashtbl.find_opt user.mailboxes mailbox with
290
-
| None -> Result.Error Mailbox_not_found
291
-
| Some mb ->
292
-
let max_seq = List.length mb.messages in
293
-
let results = List.filteri (fun i _ ->
294
-
seq_matches sequence (i + 1) max_seq
295
-
) mb.messages in
296
-
Result.Ok results
297
-
298
-
let fetch_by_uid t ~username ~mailbox ~uids ~items:_ =
299
-
let mailbox = normalize_mailbox_name mailbox in
300
-
let user = get_user t ~username in
301
-
match Hashtbl.find_opt user.mailboxes mailbox with
302
-
| None -> Result.Error Mailbox_not_found
303
-
| Some mb ->
304
-
let results = List.filter (fun m -> uid_matches_set m.uid uids) mb.messages in
305
-
Result.Ok results
306
-
307
-
let apply_flags_action action existing new_flags =
308
-
match action with
309
-
| Store_set -> new_flags
310
-
| Store_add ->
311
-
List.fold_left (fun acc f ->
312
-
if List.mem f acc then acc else f :: acc
313
-
) existing new_flags
314
-
| Store_remove ->
315
-
List.filter (fun f -> not (List.mem f new_flags)) existing
316
-
317
-
let store_flags t ~username ~mailbox ~sequence ~action ~flags =
318
-
let mailbox = normalize_mailbox_name mailbox in
319
-
let user = get_user t ~username in
320
-
match Hashtbl.find_opt user.mailboxes mailbox with
321
-
| None -> Result.Error Mailbox_not_found
322
-
| Some mb ->
323
-
let max_seq = List.length mb.messages in
324
-
let updated = List.mapi (fun i (m : message) ->
325
-
if seq_matches sequence (i + 1) max_seq then
326
-
{ m with flags = apply_flags_action action m.flags flags }
327
-
else m
328
-
) mb.messages in
329
-
mb.messages <- updated;
330
-
let results = List.filteri (fun i _ ->
331
-
seq_matches sequence (i + 1) max_seq
332
-
) updated in
333
-
Result.Ok results
334
-
335
-
let expunge t ~username ~mailbox =
336
-
let mailbox = normalize_mailbox_name mailbox in
337
-
let user = get_user t ~username in
338
-
match Hashtbl.find_opt user.mailboxes mailbox with
339
-
| None -> Result.Error Mailbox_not_found
340
-
| Some mb ->
341
-
let deleted, remaining = List.partition (fun (m : message) ->
342
-
List.mem (System Deleted) m.flags
343
-
) mb.messages in
344
-
mb.messages <- remaining;
345
-
(* Renumber remaining messages *)
346
-
mb.messages <- List.mapi (fun i (m : message) -> { m with seq = i + 1 }) mb.messages;
347
-
Result.Ok (List.map (fun (m : message) -> m.uid) deleted)
348
-
349
-
let current_date () =
350
-
format_internal_date (Unix.gmtime (Unix.time ()))
351
-
352
-
let append t ~username ~mailbox ~flags ~date ~message =
353
-
let mailbox = normalize_mailbox_name mailbox in
354
-
let user = get_user t ~username in
355
-
ensure_inbox user;
356
-
match Hashtbl.find_opt user.mailboxes mailbox with
357
-
| None -> Result.Error Mailbox_not_found
358
-
| Some mb ->
359
-
let uid = mb.uidnext in
360
-
mb.uidnext <- Int32.succ mb.uidnext;
361
-
let msg = {
362
-
uid;
363
-
seq = List.length mb.messages + 1;
364
-
flags;
365
-
internal_date = (match date with Some d -> d | None -> current_date ());
366
-
size = Int64.of_int (String.length message);
367
-
envelope = None;
368
-
body_structure = None;
369
-
raw_headers = None;
370
-
raw_body = Some message;
371
-
} in
372
-
mb.messages <- mb.messages @ [msg];
373
-
Result.Ok uid
374
-
375
-
let copy t ~username ~src_mailbox ~sequence ~dst_mailbox =
376
-
let src_mailbox = normalize_mailbox_name src_mailbox in
377
-
let dst_mailbox = normalize_mailbox_name dst_mailbox in
378
-
let user = get_user t ~username in
379
-
match Hashtbl.find_opt user.mailboxes src_mailbox,
380
-
Hashtbl.find_opt user.mailboxes dst_mailbox with
381
-
| None, _ -> Result.Error Mailbox_not_found
382
-
| _, None -> Result.Error Mailbox_not_found
383
-
| Some src_mb, Some dst_mb ->
384
-
let max_seq = List.length src_mb.messages in
385
-
let to_copy = List.filteri (fun i _ ->
386
-
seq_matches sequence (i + 1) max_seq
387
-
) src_mb.messages in
388
-
let new_uids = List.map (fun m ->
389
-
let uid = dst_mb.uidnext in
390
-
dst_mb.uidnext <- Int32.succ dst_mb.uidnext;
391
-
let new_msg = {
392
-
m with
393
-
uid;
394
-
seq = List.length dst_mb.messages + 1;
395
-
} in
396
-
dst_mb.messages <- dst_mb.messages @ [new_msg];
397
-
uid
398
-
) to_copy in
399
-
Result.Ok new_uids
400
-
401
-
let move t ~username ~src_mailbox ~sequence ~dst_mailbox =
402
-
match copy t ~username ~src_mailbox ~sequence ~dst_mailbox with
403
-
| Result.Error e -> Result.Error e
404
-
| Result.Ok uids ->
405
-
(* Mark source messages as deleted and expunge *)
406
-
let src_mailbox = normalize_mailbox_name src_mailbox in
407
-
let user = get_user t ~username in
408
-
(match Hashtbl.find_opt user.mailboxes src_mailbox with
409
-
| None -> ()
410
-
| Some src_mb ->
411
-
let max_seq = List.length src_mb.messages in
412
-
src_mb.messages <- List.filteri (fun i _ ->
413
-
not (seq_matches sequence (i + 1) max_seq)
414
-
) src_mb.messages;
415
-
src_mb.messages <- List.mapi (fun i (m : message) -> { m with seq = i + 1 }) src_mb.messages);
416
-
Result.Ok uids
417
-
418
-
let search t ~username ~mailbox ~criteria =
419
-
let mailbox = normalize_mailbox_name mailbox in
420
-
let user = get_user t ~username in
421
-
match Hashtbl.find_opt user.mailboxes mailbox with
422
-
| None -> Result.Error Mailbox_not_found
423
-
| Some mb ->
424
-
let rec matches (m : message) = function
425
-
| Search_all -> true
426
-
| Search_seen -> List.mem (System Seen) m.flags
427
-
| Search_unseen -> not (List.mem (System Seen) m.flags)
428
-
| Search_answered -> List.mem (System Answered) m.flags
429
-
| Search_unanswered -> not (List.mem (System Answered) m.flags)
430
-
| Search_deleted -> List.mem (System Deleted) m.flags
431
-
| Search_undeleted -> not (List.mem (System Deleted) m.flags)
432
-
| Search_flagged -> List.mem (System Flagged) m.flags
433
-
| Search_unflagged -> not (List.mem (System Flagged) m.flags)
434
-
| Search_draft -> List.mem (System Draft) m.flags
435
-
| Search_new -> not (List.mem (System Seen) m.flags) (* Simplified *)
436
-
| Search_old -> List.mem (System Seen) m.flags (* Simplified *)
437
-
| Search_not k -> not (matches m k)
438
-
| Search_or (k1, k2) -> matches m k1 || matches m k2
439
-
| Search_and ks -> List.for_all (matches m) ks
440
-
| Search_larger n -> m.size > n
441
-
| Search_smaller n -> m.size < n
442
-
| Search_uid seqs -> uid_matches_set m.uid seqs
443
-
| _ -> true (* TODO: Implement remaining search keys *)
444
-
in
445
-
let results = List.filter_map (fun (m : message) ->
446
-
if matches m criteria then Some m.uid else None
447
-
) mb.messages in
448
-
Result.Ok results
449
-
end
450
-
451
-
(* ===== Maildir Storage ===== *)
452
-
453
-
(** Maildir storage backend.
454
-
455
-
Implements the Maildir format as specified by D.J. Bernstein.
456
-
See {{:https://cr.yp.to/proto/maildir.html}Maildir specification}.
457
-
458
-
Directory structure:
459
-
- {i base_path}/{i username}/ - User's INBOX
460
-
- {i base_path}/{i username}/.{i folder}/ - Subfolders
461
-
462
-
Each mailbox contains:
463
-
- cur/ - Messages that have been seen by MUA
464
-
- new/ - Newly delivered messages
465
-
- tmp/ - Temporary files during delivery
466
-
467
-
Filename format: {i unique}:2,{i flags}
468
-
- unique: {i timestamp}.{i pid}.{i hostname}
469
-
- flags: D=Draft, F=Flagged, R=Replied, S=Seen, T=Trashed *)
470
-
471
-
module Maildir_storage = struct
472
-
type path_mode =
473
-
| Shared_base of string (* Shared base path: /var/mail/<username> *)
474
-
| Home_directory (* User home: ~<username>/Maildir *)
475
-
476
-
type t = {
477
-
path_mode : path_mode;
478
-
hostname : string;
479
-
mutable delivery_counter : int;
480
-
}
481
-
482
-
(* Helper: check if string ends with suffix *)
483
-
let ends_with ~suffix s =
484
-
let len = String.length suffix in
485
-
String.length s >= len && String.sub s (String.length s - len) len = suffix
486
-
487
-
(* UID mapping file stores: filename -> uid *)
488
-
type uid_map = {
489
-
mutable next_uid : int32;
490
-
uidvalidity : int32;
491
-
entries : (string, int32) Hashtbl.t; (* filename -> uid *)
492
-
}
493
-
494
-
let create () = {
495
-
path_mode = Home_directory;
496
-
hostname = Unix.gethostname ();
497
-
delivery_counter = 0;
498
-
}
499
-
500
-
let create_with_path ~base_path = {
501
-
path_mode = Shared_base base_path;
502
-
hostname = Unix.gethostname ();
503
-
delivery_counter = 0;
504
-
}
505
-
506
-
let create_home_directory () = {
507
-
path_mode = Home_directory;
508
-
hostname = Unix.gethostname ();
509
-
delivery_counter = 0;
510
-
}
511
-
512
-
let user_path t ~username =
513
-
match t.path_mode with
514
-
| Shared_base base_path -> Filename.concat base_path username
515
-
| Home_directory ->
516
-
try
517
-
let pw = Unix.getpwnam username in
518
-
Filename.concat pw.Unix.pw_dir "Maildir"
519
-
with Not_found ->
520
-
(* Fallback if user lookup fails *)
521
-
Filename.concat "/var/mail" username
522
-
523
-
(* Recursive mkdir -p - declared early for ensure_user *)
524
-
let rec mkdir_p path =
525
-
if not (Sys.file_exists path) then begin
526
-
mkdir_p (Filename.dirname path);
527
-
try Sys.mkdir path 0o700 with Sys_error _ -> ()
528
-
end
529
-
530
-
let ensure_maildir_structure path =
531
-
mkdir_p path;
532
-
mkdir_p (Filename.concat path "cur");
533
-
mkdir_p (Filename.concat path "new");
534
-
mkdir_p (Filename.concat path "tmp")
535
-
536
-
(* Ensure user's INBOX exists *)
537
-
let ensure_user t ~username =
538
-
let inbox_path = user_path t ~username in
539
-
ensure_maildir_structure inbox_path
540
-
541
-
let mailbox_path t ~username ~mailbox =
542
-
let base = user_path t ~username in
543
-
if is_inbox mailbox then base
544
-
else Filename.concat base ("." ^ String.map (fun c -> if c = '/' then '.' else c) mailbox)
545
-
546
-
(* UID map file - use a name that won't be confused with a mailbox *)
547
-
let uid_map_path path = Filename.concat path ".imapd-uidmap"
548
-
549
-
(* Parse Maildir flags from filename info part *)
550
-
let parse_maildir_flags info =
551
-
let flags = ref [] in
552
-
String.iter (fun c ->
553
-
match c with
554
-
| 'S' -> flags := System Seen :: !flags
555
-
| 'R' -> flags := System Answered :: !flags
556
-
| 'F' -> flags := System Flagged :: !flags
557
-
| 'T' -> flags := System Deleted :: !flags
558
-
| 'D' -> flags := System Draft :: !flags
559
-
| _ -> ()
560
-
) info;
561
-
!flags
562
-
563
-
(* Convert IMAP flags to Maildir flag string *)
564
-
let flags_to_maildir_string flags =
565
-
let buf = Buffer.create 8 in
566
-
(* Maildir flags must be in ASCII order: DFPRST *)
567
-
if List.mem (System Draft) flags then Buffer.add_char buf 'D';
568
-
if List.mem (System Flagged) flags then Buffer.add_char buf 'F';
569
-
(* P = Passed (forwarded), not in IMAP *)
570
-
if List.mem (System Answered) flags then Buffer.add_char buf 'R';
571
-
if List.mem (System Seen) flags then Buffer.add_char buf 'S';
572
-
if List.mem (System Deleted) flags then Buffer.add_char buf 'T';
573
-
Buffer.contents buf
574
-
575
-
(* Parse filename to extract base name and flags *)
576
-
let parse_filename filename =
577
-
match String.index_opt filename ':' with
578
-
| None -> (filename, [])
579
-
| Some colon_pos ->
580
-
let base = String.sub filename 0 colon_pos in
581
-
let rest = String.sub filename (colon_pos + 1) (String.length filename - colon_pos - 1) in
582
-
if String.length rest >= 2 && rest.[0] = '2' && rest.[1] = ',' then
583
-
let info = String.sub rest 2 (String.length rest - 2) in
584
-
(base, parse_maildir_flags info)
585
-
else
586
-
(base, [])
587
-
588
-
(* Build filename with flags *)
589
-
let build_filename base flags =
590
-
let flag_str = flags_to_maildir_string flags in
591
-
if flag_str = "" then base ^ ":2,"
592
-
else base ^ ":2," ^ flag_str
593
-
594
-
(* Generate unique filename for new message *)
595
-
let generate_unique_name t =
596
-
let timestamp = Unix.gettimeofday () in
597
-
let sec = int_of_float timestamp in
598
-
let usec = int_of_float ((timestamp -. float_of_int sec) *. 1000000.0) in
599
-
t.delivery_counter <- t.delivery_counter + 1;
600
-
Printf.sprintf "%d.M%dP%dQ%d.%s" sec usec (Unix.getpid ()) t.delivery_counter t.hostname
601
-
602
-
(* Load or create UID map for a mailbox *)
603
-
let load_uid_map path =
604
-
let map_file = uid_map_path path in
605
-
if Sys.file_exists map_file then begin
606
-
let ic = open_in_bin map_file in
607
-
try
608
-
let next_uid = Int32.of_string (input_line ic) in
609
-
let uidvalidity = Int32.of_string (input_line ic) in
610
-
let entries = Hashtbl.create 256 in
611
-
(try
612
-
while true do
613
-
let line = input_line ic in
614
-
match String.index_opt line '\t' with
615
-
| Some tab ->
616
-
let filename = String.sub line 0 tab in
617
-
let uid = Int32.of_string (String.sub line (tab + 1) (String.length line - tab - 1)) in
618
-
Hashtbl.add entries filename uid
619
-
| None -> ()
620
-
done
621
-
with End_of_file -> ());
622
-
close_in ic;
623
-
{ next_uid; uidvalidity; entries }
624
-
with _ ->
625
-
close_in ic;
626
-
{ next_uid = 1l; uidvalidity = Int32.of_float (Unix.time ()); entries = Hashtbl.create 256 }
627
-
end else
628
-
{ next_uid = 1l; uidvalidity = Int32.of_float (Unix.time ()); entries = Hashtbl.create 256 }
629
-
630
-
let save_uid_map path map =
631
-
let map_file = uid_map_path path in
632
-
let oc = open_out_bin map_file in
633
-
Printf.fprintf oc "%ld\n%ld\n" map.next_uid map.uidvalidity;
634
-
Hashtbl.iter (fun filename uid ->
635
-
Printf.fprintf oc "%s\t%ld\n" filename uid
636
-
) map.entries;
637
-
close_out oc
638
-
639
-
(* Get or assign UID for a filename *)
640
-
let get_or_assign_uid map filename =
641
-
let base, _ = parse_filename filename in
642
-
match Hashtbl.find_opt map.entries base with
643
-
| Some uid -> uid
644
-
| None ->
645
-
let uid = map.next_uid in
646
-
map.next_uid <- Int32.succ map.next_uid;
647
-
Hashtbl.add map.entries base uid;
648
-
uid
649
-
650
-
(* List all messages in a maildir *)
651
-
let list_messages path =
652
-
let messages = ref [] in
653
-
let add_from_dir subdir in_new =
654
-
let dir = Filename.concat path subdir in
655
-
if Sys.file_exists dir then begin
656
-
let entries = Sys.readdir dir in
657
-
Array.iter (fun filename ->
658
-
if filename.[0] <> '.' then
659
-
messages := (Filename.concat dir filename, filename, in_new) :: !messages
660
-
) entries
661
-
end
662
-
in
663
-
add_from_dir "new" true;
664
-
add_from_dir "cur" false;
665
-
!messages
666
-
667
-
(* Read message from file *)
668
-
let read_message_file filepath =
669
-
try
670
-
let ic = open_in_bin filepath in
671
-
let size = in_channel_length ic in
672
-
let content = really_input_string ic size in
673
-
close_in ic;
674
-
Some content
675
-
with _ -> None
676
-
677
-
(* Parse internal date from message or use file mtime *)
678
-
let get_internal_date filepath =
679
-
try
680
-
let stats = Unix.stat filepath in
681
-
format_internal_date (Unix.gmtime stats.Unix.st_mtime)
682
-
with _ -> Memory_storage.current_date ()
683
-
684
-
(* Check if a file is a metadata file that should not be listed as a mailbox *)
685
-
let is_metadata_file name =
686
-
ends_with ~suffix:"-uidmap" name ||
687
-
ends_with ~suffix:".uidmap" name ||
688
-
name = ".imapd-uidmap" ||
689
-
name = ".subscriptions"
690
-
691
-
let list_mailboxes t ~username ~reference:_ ~pattern =
692
-
let base = user_path t ~username in
693
-
if not (Sys.file_exists base) then
694
-
(* Create user directory with INBOX *)
695
-
(ensure_maildir_structure base;
696
-
if Memory_storage.matches_pattern ~pattern "INBOX" then
697
-
[{ name = "INBOX"; delimiter = Some '/'; flags = [] }]
698
-
else [])
699
-
else begin
700
-
let entries = Sys.readdir base in
701
-
let mailboxes = Array.fold_left (fun acc entry ->
702
-
if String.length entry > 0 && entry.[0] = '.' && entry <> ".." then
703
-
(* Skip hidden files that aren't mailboxes *)
704
-
if String.length entry > 1 && entry.[1] <> '.' then
705
-
(* Skip metadata files *)
706
-
if is_metadata_file entry then acc
707
-
else
708
-
(* Only include directories (mailboxes), not regular files *)
709
-
let entry_path = Filename.concat base entry in
710
-
if Sys.is_directory entry_path then
711
-
let name = String.sub entry 1 (String.length entry - 1) in
712
-
let name = String.map (fun c -> if c = '.' then '/' else c) name in
713
-
if Memory_storage.matches_pattern ~pattern name then
714
-
let flags = get_special_use_for_mailbox name in
715
-
{ name; delimiter = Some '/'; flags } :: acc
716
-
else acc
717
-
else acc
718
-
else acc
719
-
else acc
720
-
) [] entries in
721
-
(* Always include INBOX if it matches *)
722
-
if Memory_storage.matches_pattern ~pattern "INBOX" then
723
-
{ name = "INBOX"; delimiter = Some '/'; flags = [] } :: mailboxes
724
-
else mailboxes
725
-
end
726
-
727
-
let create_mailbox t ~username name =
728
-
let name = normalize_mailbox_name name in
729
-
let path = mailbox_path t ~username ~mailbox:name in
730
-
if Sys.file_exists path then
731
-
Result.Error Mailbox_already_exists
732
-
else begin
733
-
try
734
-
ensure_maildir_structure path;
735
-
Result.Ok ()
736
-
with Sys_error msg -> Result.Error (Storage_error msg)
737
-
end
738
-
739
-
let delete_mailbox t ~username name =
740
-
let name = normalize_mailbox_name name in
741
-
if is_inbox name then
742
-
Result.Error Permission_denied
743
-
else
744
-
let path = mailbox_path t ~username ~mailbox:name in
745
-
if not (Sys.file_exists path) then
746
-
Result.Error Mailbox_not_found
747
-
else begin
748
-
try
749
-
(* Remove all files in subdirectories first *)
750
-
List.iter (fun subdir ->
751
-
let dir = Filename.concat path subdir in
752
-
if Sys.file_exists dir then begin
753
-
Array.iter (fun f ->
754
-
Sys.remove (Filename.concat dir f)
755
-
) (Sys.readdir dir);
756
-
Sys.rmdir dir
757
-
end
758
-
) ["cur"; "new"; "tmp"];
759
-
(* Remove UID map if exists *)
760
-
let uid_file = uid_map_path path in
761
-
if Sys.file_exists uid_file then Sys.remove uid_file;
762
-
(* Remove mailbox directory *)
763
-
Sys.rmdir path;
764
-
Result.Ok ()
765
-
with Sys_error msg -> Result.Error (Storage_error msg)
766
-
end
767
-
768
-
let rename_mailbox t ~username ~old_name ~new_name =
769
-
let old_name = normalize_mailbox_name old_name in
770
-
let new_name = normalize_mailbox_name new_name in
771
-
if is_inbox old_name then
772
-
Result.Error Permission_denied
773
-
else
774
-
let old_path = mailbox_path t ~username ~mailbox:old_name in
775
-
let new_path = mailbox_path t ~username ~mailbox:new_name in
776
-
if not (Sys.file_exists old_path) then
777
-
Result.Error Mailbox_not_found
778
-
else if Sys.file_exists new_path then
779
-
Result.Error Mailbox_already_exists
780
-
else begin
781
-
try
782
-
Sys.rename old_path new_path;
783
-
Result.Ok ()
784
-
with Sys_error msg -> Result.Error (Storage_error msg)
785
-
end
786
-
787
-
let select_mailbox t ~username name ~readonly =
788
-
let name = normalize_mailbox_name name in
789
-
let path = mailbox_path t ~username ~mailbox:name in
790
-
if not (Sys.file_exists path) then begin
791
-
(* Auto-create INBOX *)
792
-
if is_inbox name then begin
793
-
ensure_maildir_structure path;
794
-
let map = load_uid_map path in
795
-
save_uid_map path map;
796
-
Result.Ok {
797
-
name;
798
-
exists = 0;
799
-
uidvalidity = map.uidvalidity;
800
-
uidnext = map.next_uid;
801
-
flags = [System Seen; System Answered; System Flagged; System Deleted; System Draft];
802
-
permanent_flags = [System Seen; System Answered; System Flagged; System Deleted; System Draft];
803
-
readonly;
804
-
}
805
-
end else
806
-
Result.Error Mailbox_not_found
807
-
end else begin
808
-
let messages = list_messages path in
809
-
let map = load_uid_map path in
810
-
(* Assign UIDs to any new messages *)
811
-
List.iter (fun (_, filename, _) ->
812
-
ignore (get_or_assign_uid map filename)
813
-
) messages;
814
-
save_uid_map path map;
815
-
Result.Ok {
816
-
name;
817
-
exists = List.length messages;
818
-
uidvalidity = map.uidvalidity;
819
-
uidnext = map.next_uid;
820
-
flags = [System Seen; System Answered; System Flagged; System Deleted; System Draft];
821
-
permanent_flags = [System Seen; System Answered; System Flagged; System Deleted; System Draft];
822
-
readonly;
823
-
}
824
-
end
825
-
826
-
let status_mailbox t ~username name ~items =
827
-
let name = normalize_mailbox_name name in
828
-
let path = mailbox_path t ~username ~mailbox:name in
829
-
if not (Sys.file_exists path) then
830
-
Result.Error Mailbox_not_found
831
-
else begin
832
-
let messages = list_messages path in
833
-
let map = load_uid_map path in
834
-
let total_size = ref 0L in
835
-
let unseen_count = ref 0 in
836
-
List.iter (fun (filepath, filename, in_new) ->
837
-
let _, flags = parse_filename filename in
838
-
if in_new || not (List.mem (System Seen) flags) then
839
-
incr unseen_count;
840
-
try
841
-
let stats = Unix.stat filepath in
842
-
total_size := Int64.add !total_size (Int64.of_int stats.Unix.st_size)
843
-
with _ -> ()
844
-
) messages;
845
-
let results = List.map (fun item ->
846
-
let value = match item with
847
-
| Status_messages -> Int64.of_int (List.length messages)
848
-
| Status_uidnext -> Int64.of_int32 map.next_uid
849
-
| Status_uidvalidity -> Int64.of_int32 map.uidvalidity
850
-
| Status_unseen -> Int64.of_int !unseen_count
851
-
| Status_deleted -> 0L (* Would need to scan for T flag *)
852
-
| Status_size -> !total_size
853
-
in
854
-
(item, value)
855
-
) items in
856
-
Result.Ok results
857
-
end
858
-
859
-
let fetch_messages t ~username ~mailbox ~sequence ~items:_ =
860
-
let mailbox = normalize_mailbox_name mailbox in
861
-
let path = mailbox_path t ~username ~mailbox in
862
-
if not (Sys.file_exists path) then
863
-
Result.Error Mailbox_not_found
864
-
else begin
865
-
let messages = list_messages path in
866
-
let map = load_uid_map path in
867
-
let max_seq = List.length messages in
868
-
let results = List.mapi (fun i (filepath, filename, _in_new) ->
869
-
let seq = i + 1 in
870
-
if Memory_storage.seq_matches sequence seq max_seq then begin
871
-
let _base, flags = parse_filename filename in
872
-
let uid = get_or_assign_uid map filename in
873
-
let size = try
874
-
let stats = Unix.stat filepath in
875
-
Int64.of_int stats.Unix.st_size
876
-
with _ -> 0L in
877
-
Some {
878
-
uid;
879
-
seq;
880
-
flags;
881
-
internal_date = get_internal_date filepath;
882
-
size;
883
-
envelope = None;
884
-
body_structure = None;
885
-
raw_headers = None;
886
-
raw_body = (match read_message_file filepath with Some s -> Some s | None -> None);
887
-
}
888
-
end else None
889
-
) messages in
890
-
save_uid_map path map;
891
-
Result.Ok (List.filter_map Fun.id results)
892
-
end
893
-
894
-
let fetch_by_uid t ~username ~mailbox ~uids ~items:_ =
895
-
let mailbox = normalize_mailbox_name mailbox in
896
-
let path = mailbox_path t ~username ~mailbox in
897
-
if not (Sys.file_exists path) then
898
-
Result.Error Mailbox_not_found
899
-
else begin
900
-
let messages = list_messages path in
901
-
let map = load_uid_map path in
902
-
let results = List.mapi (fun i (filepath, filename, _in_new) ->
903
-
let uid = get_or_assign_uid map filename in
904
-
if uid_matches_set uid uids then begin
905
-
let _, flags = parse_filename filename in
906
-
let size = try
907
-
let stats = Unix.stat filepath in
908
-
Int64.of_int stats.Unix.st_size
909
-
with _ -> 0L in
910
-
Some {
911
-
uid;
912
-
seq = i + 1;
913
-
flags;
914
-
internal_date = get_internal_date filepath;
915
-
size;
916
-
envelope = None;
917
-
body_structure = None;
918
-
raw_headers = None;
919
-
raw_body = read_message_file filepath;
920
-
}
921
-
end else None
922
-
) messages in
923
-
save_uid_map path map;
924
-
Result.Ok (List.filter_map Fun.id results)
925
-
end
926
-
927
-
let store_flags t ~username ~mailbox ~sequence ~action ~flags =
928
-
let mailbox = normalize_mailbox_name mailbox in
929
-
let path = mailbox_path t ~username ~mailbox in
930
-
if not (Sys.file_exists path) then
931
-
Result.Error Mailbox_not_found
932
-
else begin
933
-
let messages = list_messages path in
934
-
let map = load_uid_map path in
935
-
let max_seq = List.length messages in
936
-
let results = List.mapi (fun i (filepath, filename, _in_new) ->
937
-
let seq = i + 1 in
938
-
if Memory_storage.seq_matches sequence seq max_seq then begin
939
-
let base, old_flags = parse_filename filename in
940
-
let new_flags = Memory_storage.apply_flags_action action old_flags flags in
941
-
let uid = get_or_assign_uid map filename in
942
-
(* Rename file with new flags *)
943
-
let new_filename = build_filename base new_flags in
944
-
let dir = Filename.dirname filepath in
945
-
(* Move to cur/ if in new/ *)
946
-
let new_dir = if ends_with ~suffix:"/new" dir then
947
-
String.sub dir 0 (String.length dir - 4) ^ "/cur"
948
-
else dir in
949
-
let new_filepath = Filename.concat new_dir new_filename in
950
-
(try
951
-
if filepath <> new_filepath then
952
-
Sys.rename filepath new_filepath
953
-
with _ -> ());
954
-
let size = try
955
-
let stats = Unix.stat new_filepath in
956
-
Int64.of_int stats.Unix.st_size
957
-
with _ -> 0L in
958
-
Some {
959
-
uid;
960
-
seq;
961
-
flags = new_flags;
962
-
internal_date = get_internal_date new_filepath;
963
-
size;
964
-
envelope = None;
965
-
body_structure = None;
966
-
raw_headers = None;
967
-
raw_body = None;
968
-
}
969
-
end else None
970
-
) messages in
971
-
save_uid_map path map;
972
-
Result.Ok (List.filter_map Fun.id results)
973
-
end
974
-
975
-
let expunge t ~username ~mailbox =
976
-
let mailbox = normalize_mailbox_name mailbox in
977
-
let path = mailbox_path t ~username ~mailbox in
978
-
if not (Sys.file_exists path) then
979
-
Result.Error Mailbox_not_found
980
-
else begin
981
-
let messages = list_messages path in
982
-
let map = load_uid_map path in
983
-
let deleted_uids = ref [] in
984
-
List.iter (fun (filepath, filename, _) ->
985
-
let base, flags = parse_filename filename in
986
-
if List.mem (System Deleted) flags then begin
987
-
let uid = get_or_assign_uid map filename in
988
-
deleted_uids := uid :: !deleted_uids;
989
-
(* Remove from UID map *)
990
-
Hashtbl.remove map.entries base;
991
-
(* Delete file *)
992
-
(try Sys.remove filepath with _ -> ())
993
-
end
994
-
) messages;
995
-
save_uid_map path map;
996
-
Result.Ok (List.rev !deleted_uids)
997
-
end
998
-
999
-
let append t ~username ~mailbox ~flags ~date:_ ~message =
1000
-
let mailbox = normalize_mailbox_name mailbox in
1001
-
let path = mailbox_path t ~username ~mailbox in
1002
-
(* Create INBOX if it doesn't exist, error for other mailboxes *)
1003
-
if not (Sys.file_exists path) then begin
1004
-
if is_inbox mailbox then
1005
-
ensure_maildir_structure path
1006
-
else
1007
-
(* Return error for non-existent non-INBOX mailboxes *)
1008
-
()
1009
-
end;
1010
-
if not (Sys.file_exists path) then
1011
-
Result.Error Mailbox_not_found
1012
-
else
1013
-
try
1014
-
let map = load_uid_map path in
1015
-
let unique_name = generate_unique_name t in
1016
-
let filename = build_filename unique_name flags in
1017
-
(* Write to tmp first, then move to new or cur *)
1018
-
let tmp_path = Filename.concat (Filename.concat path "tmp") filename in
1019
-
let oc = open_out_bin tmp_path in
1020
-
output_string oc message;
1021
-
close_out oc;
1022
-
(* Move to cur if Seen flag set, otherwise new *)
1023
-
let dest_dir = if List.mem (System Seen) flags then "cur" else "new" in
1024
-
let dest_path = Filename.concat (Filename.concat path dest_dir) filename in
1025
-
Sys.rename tmp_path dest_path;
1026
-
(* Assign UID *)
1027
-
let uid = map.next_uid in
1028
-
map.next_uid <- Int32.succ map.next_uid;
1029
-
Hashtbl.add map.entries unique_name uid;
1030
-
save_uid_map path map;
1031
-
Result.Ok uid
1032
-
with Sys_error msg -> Result.Error (Storage_error msg)
1033
-
1034
-
let copy t ~username ~src_mailbox ~sequence ~dst_mailbox =
1035
-
let src_mailbox = normalize_mailbox_name src_mailbox in
1036
-
let dst_mailbox = normalize_mailbox_name dst_mailbox in
1037
-
let src_path = mailbox_path t ~username ~mailbox:src_mailbox in
1038
-
let dst_path = mailbox_path t ~username ~mailbox:dst_mailbox in
1039
-
if not (Sys.file_exists src_path) then
1040
-
Result.Error Mailbox_not_found
1041
-
else if not (Sys.file_exists dst_path) then
1042
-
Result.Error Mailbox_not_found
1043
-
else begin
1044
-
let messages = list_messages src_path in
1045
-
let src_map = load_uid_map src_path in
1046
-
let dst_map = load_uid_map dst_path in
1047
-
let max_seq = List.length messages in
1048
-
let new_uids = ref [] in
1049
-
List.iteri (fun i (filepath, filename, _) ->
1050
-
let seq = i + 1 in
1051
-
if Memory_storage.seq_matches sequence seq max_seq then begin
1052
-
match read_message_file filepath with
1053
-
| Some content ->
1054
-
let _, flags = parse_filename filename in
1055
-
let unique_name = generate_unique_name t in
1056
-
let new_filename = build_filename unique_name flags in
1057
-
let dest_dir = if List.mem (System Seen) flags then "cur" else "new" in
1058
-
let dest_path = Filename.concat (Filename.concat dst_path dest_dir) new_filename in
1059
-
let oc = open_out_bin dest_path in
1060
-
output_string oc content;
1061
-
close_out oc;
1062
-
let uid = dst_map.next_uid in
1063
-
dst_map.next_uid <- Int32.succ dst_map.next_uid;
1064
-
Hashtbl.add dst_map.entries unique_name uid;
1065
-
new_uids := uid :: !new_uids
1066
-
| None -> ()
1067
-
end
1068
-
) messages;
1069
-
save_uid_map src_path src_map;
1070
-
save_uid_map dst_path dst_map;
1071
-
Result.Ok (List.rev !new_uids)
1072
-
end
1073
-
1074
-
let move t ~username ~src_mailbox ~sequence ~dst_mailbox =
1075
-
match copy t ~username ~src_mailbox ~sequence ~dst_mailbox with
1076
-
| Result.Error e -> Result.Error e
1077
-
| Result.Ok new_uids ->
1078
-
(* Mark source messages as deleted and expunge *)
1079
-
let src_mailbox = normalize_mailbox_name src_mailbox in
1080
-
let src_path = mailbox_path t ~username ~mailbox:src_mailbox in
1081
-
let messages = list_messages src_path in
1082
-
let max_seq = List.length messages in
1083
-
List.iteri (fun i (filepath, _filename, _) ->
1084
-
let seq = i + 1 in
1085
-
if Memory_storage.seq_matches sequence seq max_seq then
1086
-
(try Sys.remove filepath with _ -> ())
1087
-
) messages;
1088
-
Result.Ok new_uids
1089
-
1090
-
let search t ~username ~mailbox ~criteria =
1091
-
let mailbox = normalize_mailbox_name mailbox in
1092
-
let path = mailbox_path t ~username ~mailbox in
1093
-
if not (Sys.file_exists path) then
1094
-
Result.Error Mailbox_not_found
1095
-
else begin
1096
-
let messages = list_messages path in
1097
-
let map = load_uid_map path in
1098
-
let rec matches (filepath, filename, in_new) = function
1099
-
| Search_all -> true
1100
-
| Search_seen ->
1101
-
let _, flags = parse_filename filename in
1102
-
not in_new && List.mem (System Seen) flags
1103
-
| Search_unseen ->
1104
-
let _, flags = parse_filename filename in
1105
-
in_new || not (List.mem (System Seen) flags)
1106
-
| Search_flagged ->
1107
-
let _, flags = parse_filename filename in
1108
-
List.mem (System Flagged) flags
1109
-
| Search_unflagged ->
1110
-
let _, flags = parse_filename filename in
1111
-
not (List.mem (System Flagged) flags)
1112
-
| Search_deleted ->
1113
-
let _, flags = parse_filename filename in
1114
-
List.mem (System Deleted) flags
1115
-
| Search_undeleted ->
1116
-
let _, flags = parse_filename filename in
1117
-
not (List.mem (System Deleted) flags)
1118
-
| Search_answered ->
1119
-
let _, flags = parse_filename filename in
1120
-
List.mem (System Answered) flags
1121
-
| Search_unanswered ->
1122
-
let _, flags = parse_filename filename in
1123
-
not (List.mem (System Answered) flags)
1124
-
| Search_draft ->
1125
-
let _, flags = parse_filename filename in
1126
-
List.mem (System Draft) flags
1127
-
| Search_not k -> not (matches (filepath, filename, in_new) k)
1128
-
| Search_or (k1, k2) ->
1129
-
matches (filepath, filename, in_new) k1 || matches (filepath, filename, in_new) k2
1130
-
| Search_and ks -> List.for_all (matches (filepath, filename, in_new)) ks
1131
-
| Search_larger n ->
1132
-
(try
1133
-
let stats = Unix.stat filepath in
1134
-
Int64.of_int stats.Unix.st_size > n
1135
-
with _ -> false)
1136
-
| Search_smaller n ->
1137
-
(try
1138
-
let stats = Unix.stat filepath in
1139
-
Int64.of_int stats.Unix.st_size < n
1140
-
with _ -> false)
1141
-
| Search_uid seqs ->
1142
-
let uid = get_or_assign_uid map filename in
1143
-
uid_matches_set uid seqs
1144
-
| _ -> true (* Simplified: other criteria match all *)
1145
-
in
1146
-
let results = List.filter_map (fun (filepath, filename, in_new) ->
1147
-
if matches (filepath, filename, in_new) criteria then
1148
-
Some (get_or_assign_uid map filename)
1149
-
else None
1150
-
) messages in
1151
-
save_uid_map path map;
1152
-
Result.Ok results
1153
-
end
1154
-
end
-215
lib/imapd/storage.mli
-215
lib/imapd/storage.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** IMAP Storage Backends
7
-
8
-
This module provides pluggable storage backends for the IMAP server.
9
-
10
-
{2 References}
11
-
{ul
12
-
{- {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} - IMAP4rev2}
13
-
{- {{:https://datatracker.ietf.org/doc/html/rfc9051#section-2.3}RFC 9051 Section 2.3} - Message Attributes}} *)
14
-
15
-
open Protocol
16
-
17
-
(** {1 Storage Errors} *)
18
-
19
-
type error =
20
-
| Mailbox_not_found
21
-
| Mailbox_already_exists
22
-
| Message_not_found
23
-
| Permission_denied
24
-
| Storage_error of string
25
-
| Quota_exceeded
26
-
27
-
val error_to_string : error -> string
28
-
29
-
(** {1 Mailbox Information} *)
30
-
31
-
type mailbox_info = {
32
-
name : mailbox_name;
33
-
delimiter : char option;
34
-
flags : list_flag list;
35
-
}
36
-
37
-
(** {1 Storage Backend Signature} *)
38
-
39
-
module type STORAGE = sig
40
-
type t
41
-
42
-
(** {2 Lifecycle} *)
43
-
44
-
val create : unit -> t
45
-
(** Create a new storage instance. *)
46
-
47
-
(** {2 Mailbox Operations} *)
48
-
49
-
val list_mailboxes :
50
-
t ->
51
-
username:string ->
52
-
reference:string ->
53
-
pattern:string ->
54
-
mailbox_info list
55
-
(** List mailboxes matching the pattern.
56
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.3.9}RFC 9051 Section 6.3.9}. *)
57
-
58
-
val create_mailbox :
59
-
t ->
60
-
username:string ->
61
-
mailbox_name ->
62
-
(unit, error) result
63
-
(** Create a new mailbox.
64
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.3.4}RFC 9051 Section 6.3.4}. *)
65
-
66
-
val delete_mailbox :
67
-
t ->
68
-
username:string ->
69
-
mailbox_name ->
70
-
(unit, error) result
71
-
(** Delete a mailbox.
72
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.3.5}RFC 9051 Section 6.3.5}. *)
73
-
74
-
val rename_mailbox :
75
-
t ->
76
-
username:string ->
77
-
old_name:mailbox_name ->
78
-
new_name:mailbox_name ->
79
-
(unit, error) result
80
-
(** Rename a mailbox.
81
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.3.6}RFC 9051 Section 6.3.6}. *)
82
-
83
-
val select_mailbox :
84
-
t ->
85
-
username:string ->
86
-
mailbox_name ->
87
-
readonly:bool ->
88
-
(mailbox_state, error) result
89
-
(** Select a mailbox for access.
90
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.3.2}RFC 9051 Section 6.3.2}. *)
91
-
92
-
val status_mailbox :
93
-
t ->
94
-
username:string ->
95
-
mailbox_name ->
96
-
items:status_item list ->
97
-
((status_item * int64) list, error) result
98
-
(** Get mailbox status.
99
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.3.11}RFC 9051 Section 6.3.11}. *)
100
-
101
-
(** {2 Message Operations} *)
102
-
103
-
val fetch_messages :
104
-
t ->
105
-
username:string ->
106
-
mailbox:mailbox_name ->
107
-
sequence:sequence_set ->
108
-
items:fetch_item list ->
109
-
(message list, error) result
110
-
(** Fetch messages.
111
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.4.5}RFC 9051 Section 6.4.5}. *)
112
-
113
-
val fetch_by_uid :
114
-
t ->
115
-
username:string ->
116
-
mailbox:mailbox_name ->
117
-
uids:sequence_set ->
118
-
items:fetch_item list ->
119
-
(message list, error) result
120
-
(** Fetch messages by UID. *)
121
-
122
-
val store_flags :
123
-
t ->
124
-
username:string ->
125
-
mailbox:mailbox_name ->
126
-
sequence:sequence_set ->
127
-
action:store_action ->
128
-
flags:flag list ->
129
-
(message list, error) result
130
-
(** Store flags on messages.
131
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.4.6}RFC 9051 Section 6.4.6}. *)
132
-
133
-
val expunge :
134
-
t ->
135
-
username:string ->
136
-
mailbox:mailbox_name ->
137
-
(uid list, error) result
138
-
(** Expunge deleted messages.
139
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.4.3}RFC 9051 Section 6.4.3}. *)
140
-
141
-
val append :
142
-
t ->
143
-
username:string ->
144
-
mailbox:mailbox_name ->
145
-
flags:flag list ->
146
-
date:string option ->
147
-
message:string ->
148
-
(uid, error) result
149
-
(** Append a message.
150
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.3.12}RFC 9051 Section 6.3.12}. *)
151
-
152
-
val copy :
153
-
t ->
154
-
username:string ->
155
-
src_mailbox:mailbox_name ->
156
-
sequence:sequence_set ->
157
-
dst_mailbox:mailbox_name ->
158
-
(uid list, error) result
159
-
(** Copy messages.
160
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.4.7}RFC 9051 Section 6.4.7}. *)
161
-
162
-
val move :
163
-
t ->
164
-
username:string ->
165
-
src_mailbox:mailbox_name ->
166
-
sequence:sequence_set ->
167
-
dst_mailbox:mailbox_name ->
168
-
(uid list, error) result
169
-
(** Move messages.
170
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.4.8}RFC 9051 Section 6.4.8}. *)
171
-
172
-
val search :
173
-
t ->
174
-
username:string ->
175
-
mailbox:mailbox_name ->
176
-
criteria:search_key ->
177
-
(uid list, error) result
178
-
(** Search messages.
179
-
See {{:https://datatracker.ietf.org/doc/html/rfc9051#section-6.4.4}RFC 9051 Section 6.4.4}. *)
180
-
end
181
-
182
-
(** {1 In-Memory Storage}
183
-
184
-
Simple in-memory storage for development and testing. *)
185
-
186
-
module Memory_storage : sig
187
-
include STORAGE
188
-
189
-
val add_test_user : t -> username:string -> unit
190
-
(** Add a test user with default INBOX. *)
191
-
192
-
val add_test_message : t -> username:string -> mailbox:mailbox_name -> message:message -> unit
193
-
(** Add a test message directly. *)
194
-
end
195
-
196
-
(** {1 Maildir Storage}
197
-
198
-
Maildir-based storage for production use.
199
-
See {{:https://cr.yp.to/proto/maildir.html}Maildir specification}. *)
200
-
201
-
module Maildir_storage : sig
202
-
include STORAGE
203
-
204
-
val create_with_path : base_path:string -> t
205
-
(** Create storage with a specific base path for Maildir directories.
206
-
Mail is stored at {i base_path}/{i username}/. *)
207
-
208
-
val create_home_directory : unit -> t
209
-
(** Create storage using users' home directories.
210
-
Mail is stored at ~{i username}/Maildir/ (the traditional Unix location).
211
-
This is the recommended mode for fork-per-connection with setuid. *)
212
-
213
-
val ensure_user : t -> username:string -> unit
214
-
(** Ensure user's INBOX exists (creates Maildir structure). *)
215
-
end
-181
lib/imapd/utf8.ml
-181
lib/imapd/utf8.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** UTF-8 validation per RFC 3629 for RFC 6855 IMAP UTF-8 support.
7
-
@see <https://datatracker.ietf.org/doc/html/rfc6855> RFC 6855: IMAP Support for UTF-8
8
-
@see <https://datatracker.ietf.org/doc/html/rfc3629> RFC 3629: UTF-8 encoding *)
9
-
10
-
(** Check if a string contains any non-ASCII characters (bytes >= 128). *)
11
-
let has_non_ascii s =
12
-
let len = String.length s in
13
-
let rec loop i =
14
-
if i >= len then false
15
-
else if Char.code s.[i] >= 128 then true
16
-
else loop (i + 1)
17
-
in
18
-
loop 0
19
-
20
-
(** Validate UTF-8 encoding per RFC 3629 Section 4.
21
-
22
-
UTF-8 encoding (RFC 3629):
23
-
- 1-byte: 0xxxxxxx (U+0000..U+007F)
24
-
- 2-byte: 110xxxxx 10xxxxxx (U+0080..U+07FF)
25
-
- 3-byte: 1110xxxx 10xxxxxx 10xxxxxx (U+0800..U+FFFF)
26
-
- 4-byte: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx (U+10000..U+10FFFF)
27
-
28
-
Continuation bytes always have form 10xxxxxx.
29
-
30
-
@see <https://datatracker.ietf.org/doc/html/rfc3629#section-4> RFC 3629 Section 4 *)
31
-
let is_valid_utf8 s =
32
-
let len = String.length s in
33
-
let rec loop i =
34
-
if i >= len then true
35
-
else
36
-
let b0 = Char.code s.[i] in
37
-
if b0 <= 0x7F then
38
-
(* 1-byte sequence: ASCII *)
39
-
loop (i + 1)
40
-
else if b0 land 0xE0 = 0xC0 then begin
41
-
(* 2-byte sequence: 110xxxxx 10xxxxxx *)
42
-
if i + 1 >= len then false
43
-
else
44
-
let b1 = Char.code s.[i + 1] in
45
-
(* Check continuation byte *)
46
-
if b1 land 0xC0 <> 0x80 then false
47
-
else
48
-
(* Check for overlong encoding: must encode U+0080 or higher *)
49
-
let codepoint = ((b0 land 0x1F) lsl 6) lor (b1 land 0x3F) in
50
-
if codepoint < 0x80 then false
51
-
else loop (i + 2)
52
-
end
53
-
else if b0 land 0xF0 = 0xE0 then begin
54
-
(* 3-byte sequence: 1110xxxx 10xxxxxx 10xxxxxx *)
55
-
if i + 2 >= len then false
56
-
else
57
-
let b1 = Char.code s.[i + 1] in
58
-
let b2 = Char.code s.[i + 2] in
59
-
(* Check continuation bytes *)
60
-
if b1 land 0xC0 <> 0x80 || b2 land 0xC0 <> 0x80 then false
61
-
else
62
-
let codepoint =
63
-
((b0 land 0x0F) lsl 12) lor
64
-
((b1 land 0x3F) lsl 6) lor
65
-
(b2 land 0x3F)
66
-
in
67
-
(* Check for overlong encoding: must encode U+0800 or higher *)
68
-
if codepoint < 0x800 then false
69
-
(* Check for surrogate pairs (U+D800..U+DFFF are invalid) *)
70
-
else if codepoint >= 0xD800 && codepoint <= 0xDFFF then false
71
-
else loop (i + 3)
72
-
end
73
-
else if b0 land 0xF8 = 0xF0 then begin
74
-
(* 4-byte sequence: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx *)
75
-
if i + 3 >= len then false
76
-
else
77
-
let b1 = Char.code s.[i + 1] in
78
-
let b2 = Char.code s.[i + 2] in
79
-
let b3 = Char.code s.[i + 3] in
80
-
(* Check continuation bytes *)
81
-
if b1 land 0xC0 <> 0x80 ||
82
-
b2 land 0xC0 <> 0x80 ||
83
-
b3 land 0xC0 <> 0x80 then false
84
-
else
85
-
let codepoint =
86
-
((b0 land 0x07) lsl 18) lor
87
-
((b1 land 0x3F) lsl 12) lor
88
-
((b2 land 0x3F) lsl 6) lor
89
-
(b3 land 0x3F)
90
-
in
91
-
(* Check for overlong encoding: must encode U+10000 or higher *)
92
-
if codepoint < 0x10000 then false
93
-
(* Check valid Unicode range: max is U+10FFFF *)
94
-
else if codepoint > 0x10FFFF then false
95
-
else loop (i + 4)
96
-
end
97
-
else
98
-
(* Invalid start byte *)
99
-
false
100
-
in
101
-
loop 0
102
-
103
-
(** Decode a single UTF-8 codepoint at position [i] in string [s].
104
-
Returns the codepoint and the number of bytes consumed, or None if invalid.
105
-
Assumes is_valid_utf8 has already passed. *)
106
-
let decode_codepoint s i =
107
-
let len = String.length s in
108
-
if i >= len then None
109
-
else
110
-
let b0 = Char.code s.[i] in
111
-
if b0 <= 0x7F then
112
-
Some (b0, 1)
113
-
else if b0 land 0xE0 = 0xC0 && i + 1 < len then
114
-
let b1 = Char.code s.[i + 1] in
115
-
let cp = ((b0 land 0x1F) lsl 6) lor (b1 land 0x3F) in
116
-
Some (cp, 2)
117
-
else if b0 land 0xF0 = 0xE0 && i + 2 < len then
118
-
let b1 = Char.code s.[i + 1] in
119
-
let b2 = Char.code s.[i + 2] in
120
-
let cp =
121
-
((b0 land 0x0F) lsl 12) lor
122
-
((b1 land 0x3F) lsl 6) lor
123
-
(b2 land 0x3F)
124
-
in
125
-
Some (cp, 3)
126
-
else if b0 land 0xF8 = 0xF0 && i + 3 < len then
127
-
let b1 = Char.code s.[i + 1] in
128
-
let b2 = Char.code s.[i + 2] in
129
-
let b3 = Char.code s.[i + 3] in
130
-
let cp =
131
-
((b0 land 0x07) lsl 18) lor
132
-
((b1 land 0x3F) lsl 12) lor
133
-
((b2 land 0x3F) lsl 6) lor
134
-
(b3 land 0x3F)
135
-
in
136
-
Some (cp, 4)
137
-
else
138
-
None
139
-
140
-
(** Check if a codepoint is disallowed in mailbox names per RFC 6855 Section 3.
141
-
142
-
Disallowed characters:
143
-
- U+0000..U+001F: C0 control characters
144
-
- U+007F: DELETE
145
-
- U+0080..U+009F: C1 control characters
146
-
- U+2028: LINE SEPARATOR
147
-
- U+2029: PARAGRAPH SEPARATOR
148
-
149
-
@see <https://datatracker.ietf.org/doc/html/rfc6855#section-3> RFC 6855 Section 3
150
-
@see <https://datatracker.ietf.org/doc/html/rfc5198#section-2> RFC 5198 Section 2 *)
151
-
let is_disallowed_mailbox_codepoint cp =
152
-
(* C0 control characters U+0000..U+001F *)
153
-
(cp >= 0x0000 && cp <= 0x001F) ||
154
-
(* DELETE U+007F *)
155
-
cp = 0x007F ||
156
-
(* C1 control characters U+0080..U+009F *)
157
-
(cp >= 0x0080 && cp <= 0x009F) ||
158
-
(* LINE SEPARATOR U+2028 *)
159
-
cp = 0x2028 ||
160
-
(* PARAGRAPH SEPARATOR U+2029 *)
161
-
cp = 0x2029
162
-
163
-
(** Validate a mailbox name for UTF-8 compliance per RFC 6855 Section 3.
164
-
165
-
@see <https://datatracker.ietf.org/doc/html/rfc6855#section-3> RFC 6855 Section 3 *)
166
-
let is_valid_utf8_mailbox_name s =
167
-
(* First check basic UTF-8 validity *)
168
-
if not (is_valid_utf8 s) then false
169
-
else
170
-
(* Then check for disallowed codepoints *)
171
-
let len = String.length s in
172
-
let rec loop i =
173
-
if i >= len then true
174
-
else
175
-
match decode_codepoint s i with
176
-
| None -> false
177
-
| Some (cp, bytes) ->
178
-
if is_disallowed_mailbox_codepoint cp then false
179
-
else loop (i + bytes)
180
-
in
181
-
loop 0
-33
lib/imapd/utf8.mli
-33
lib/imapd/utf8.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** UTF-8 validation per RFC 3629 for RFC 6855 IMAP UTF-8 support.
7
-
@see <https://datatracker.ietf.org/doc/html/rfc6855> RFC 6855: IMAP Support for UTF-8
8
-
@see <https://datatracker.ietf.org/doc/html/rfc3629> RFC 3629: UTF-8 encoding *)
9
-
10
-
(** {1 UTF-8 Validation} *)
11
-
12
-
val is_valid_utf8 : string -> bool
13
-
(** [is_valid_utf8 s] returns [true] if [s] contains only valid UTF-8 sequences
14
-
per RFC 3629. Returns [true] for empty strings and pure ASCII strings.
15
-
@see <https://datatracker.ietf.org/doc/html/rfc3629#section-4> RFC 3629 Section 4 *)
16
-
17
-
val has_non_ascii : string -> bool
18
-
(** [has_non_ascii s] returns [true] if [s] contains any bytes with value >= 128.
19
-
This is useful for detecting when UTF-8 validation is needed. *)
20
-
21
-
(** {1 Mailbox Name Validation} *)
22
-
23
-
val is_valid_utf8_mailbox_name : string -> bool
24
-
(** [is_valid_utf8_mailbox_name s] validates a mailbox name for UTF-8 compliance
25
-
per RFC 6855 Section 3. Mailbox names must:
26
-
- Contain only valid UTF-8 sequences
27
-
- Comply with Net-Unicode (RFC 5198 Section 2)
28
-
- Not contain control characters U+0000-U+001F, U+0080-U+009F
29
-
- Not contain delete U+007F
30
-
- Not contain line separator U+2028 or paragraph separator U+2029
31
-
32
-
@see <https://datatracker.ietf.org/doc/html/rfc6855#section-3> RFC 6855 Section 3
33
-
@see <https://datatracker.ietf.org/doc/html/rfc5198#section-2> RFC 5198 Section 2 *)
-554
lib/imapd/write.ml
-554
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 list_cmd ->
354
-
W.string w "LIST ";
355
-
(match list_cmd with
356
-
| List_basic { reference; pattern } ->
357
-
astring w reference;
358
-
sp w;
359
-
astring w pattern
360
-
| List_extended { selection; reference; patterns; return_opts } ->
361
-
(* Selection options - RFC 5258 Section 3.1 *)
362
-
W.char w '(';
363
-
List.iteri (fun i opt ->
364
-
if i > 0 then sp w;
365
-
match opt with
366
-
| List_select_subscribed -> W.string w "SUBSCRIBED"
367
-
| List_select_remote -> W.string w "REMOTE"
368
-
| List_select_recursivematch -> W.string w "RECURSIVEMATCH"
369
-
| List_select_special_use -> W.string w "SPECIAL-USE"
370
-
) selection;
371
-
W.char w ')';
372
-
sp w;
373
-
astring w reference;
374
-
sp w;
375
-
(* Patterns - multiple patterns in parentheses *)
376
-
(match patterns with
377
-
| [p] -> astring w p
378
-
| ps ->
379
-
W.char w '(';
380
-
List.iteri (fun i p ->
381
-
if i > 0 then sp w;
382
-
astring w p
383
-
) ps;
384
-
W.char w ')');
385
-
(* Return options - RFC 5258 Section 3.2 *)
386
-
(match return_opts with
387
-
| [] -> ()
388
-
| opts ->
389
-
sp w;
390
-
W.string w "RETURN (";
391
-
List.iteri (fun i opt ->
392
-
if i > 0 then sp w;
393
-
match opt with
394
-
| List_return_subscribed -> W.string w "SUBSCRIBED"
395
-
| List_return_children -> W.string w "CHILDREN"
396
-
| List_return_special_use -> W.string w "SPECIAL-USE"
397
-
) opts;
398
-
W.char w ')'))
399
-
| Namespace -> W.string w "NAMESPACE"
400
-
| Status { mailbox; items } ->
401
-
W.string w "STATUS ";
402
-
astring w mailbox;
403
-
sp w;
404
-
status_items w items
405
-
| Append { mailbox; flags; date; message } ->
406
-
W.string w "APPEND ";
407
-
astring w mailbox;
408
-
(match flags with
409
-
| [] -> ()
410
-
| flags ->
411
-
sp w;
412
-
flag_list w flags);
413
-
(match date with
414
-
| Some d ->
415
-
sp w;
416
-
quoted_string w d
417
-
| None -> ());
418
-
sp w;
419
-
literal w message
420
-
| Idle -> W.string w "IDLE"
421
-
| Close -> W.string w "CLOSE"
422
-
| Unselect -> W.string w "UNSELECT"
423
-
| Expunge -> W.string w "EXPUNGE"
424
-
| Search { charset; criteria } -> (
425
-
W.string w "SEARCH";
426
-
(match charset with
427
-
| Some cs ->
428
-
W.string w " CHARSET ";
429
-
astring w cs
430
-
| None -> ());
431
-
sp w;
432
-
search_key w criteria)
433
-
| Fetch { sequence; items } ->
434
-
W.string w "FETCH ";
435
-
sequence_set w sequence;
436
-
sp w;
437
-
fetch_items w items
438
-
| Store { sequence; silent; action; flags } ->
439
-
W.string w "STORE ";
440
-
sequence_set w sequence;
441
-
sp w;
442
-
store_action w action;
443
-
if silent then W.string w ".SILENT";
444
-
sp w;
445
-
flag_list w flags
446
-
| Copy { sequence; mailbox } ->
447
-
W.string w "COPY ";
448
-
sequence_set w sequence;
449
-
sp w;
450
-
astring w mailbox
451
-
| Move { sequence; mailbox } ->
452
-
W.string w "MOVE ";
453
-
sequence_set w sequence;
454
-
sp w;
455
-
astring w mailbox
456
-
| Uid cmd -> (
457
-
W.string w "UID ";
458
-
match cmd with
459
-
| Uid_fetch { sequence; items } ->
460
-
W.string w "FETCH ";
461
-
sequence_set w sequence;
462
-
sp w;
463
-
fetch_items w items
464
-
| Uid_store { sequence; silent; action; flags } ->
465
-
W.string w "STORE ";
466
-
sequence_set w sequence;
467
-
sp w;
468
-
store_action w action;
469
-
if silent then W.string w ".SILENT";
470
-
sp w;
471
-
flag_list w flags
472
-
| Uid_copy { sequence; mailbox } ->
473
-
W.string w "COPY ";
474
-
sequence_set w sequence;
475
-
sp w;
476
-
astring w mailbox
477
-
| Uid_move { sequence; mailbox } ->
478
-
W.string w "MOVE ";
479
-
sequence_set w sequence;
480
-
sp w;
481
-
astring w mailbox
482
-
| Uid_search { charset; criteria } ->
483
-
W.string w "SEARCH";
484
-
(match charset with
485
-
| Some cs ->
486
-
W.string w " CHARSET ";
487
-
astring w cs
488
-
| None -> ());
489
-
sp w;
490
-
search_key w criteria
491
-
| Uid_expunge set ->
492
-
W.string w "EXPUNGE ";
493
-
sequence_set w set
494
-
| Uid_thread { algorithm; charset; criteria } ->
495
-
W.string w "THREAD ";
496
-
(match algorithm with
497
-
| Thread_orderedsubject -> W.string w "ORDEREDSUBJECT"
498
-
| Thread_references -> W.string w "REFERENCES"
499
-
| Thread_extension ext -> astring w ext);
500
-
sp w;
501
-
astring w charset;
502
-
sp w;
503
-
search_key w criteria)
504
-
| Id params ->
505
-
W.string w "ID ";
506
-
id_params w params
507
-
(* QUOTA extension - RFC 9208 *)
508
-
| Getquota root ->
509
-
W.string w "GETQUOTA ";
510
-
astring w root
511
-
| Getquotaroot mailbox ->
512
-
W.string w "GETQUOTAROOT ";
513
-
astring w mailbox
514
-
| Setquota { root; limits } ->
515
-
W.string w "SETQUOTA ";
516
-
astring w root;
517
-
sp w;
518
-
W.char w '(';
519
-
List.iteri (fun i (res, limit) ->
520
-
if i > 0 then sp w;
521
-
(match res with
522
-
| Quota_storage -> W.string w "STORAGE"
523
-
| Quota_message -> W.string w "MESSAGE"
524
-
| Quota_mailbox -> W.string w "MAILBOX"
525
-
| Quota_annotation_storage -> W.string w "ANNOTATION-STORAGE");
526
-
sp w;
527
-
W.string w (Int64.to_string limit)
528
-
) limits;
529
-
W.char w ')'
530
-
(* THREAD extension - RFC 5256 *)
531
-
| Thread { algorithm; charset; criteria } ->
532
-
W.string w "THREAD ";
533
-
(match algorithm with
534
-
| Thread_orderedsubject -> W.string w "ORDEREDSUBJECT"
535
-
| Thread_references -> W.string w "REFERENCES"
536
-
| Thread_extension ext -> astring w ext);
537
-
sp w;
538
-
astring w charset;
539
-
sp w;
540
-
search_key w criteria
541
-
542
-
let command w ~tag cmd =
543
-
atom w tag;
544
-
sp w;
545
-
command_body w cmd;
546
-
crlf w
547
-
548
-
let idle_done w =
549
-
W.string w "DONE";
550
-
crlf w
551
-
552
-
let authenticate_response w data =
553
-
W.string w data;
554
-
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. *)
-24
test/dune
-24
test/dune
···
1
-
(test
2
-
(name test_types)
3
-
(libraries imapd alcotest))
4
-
5
-
(test
6
-
(name test_parser)
7
-
(libraries imapd alcotest))
8
-
9
-
(test
10
-
(name test_auth)
11
-
(libraries imapd alcotest))
12
-
13
-
(test
14
-
(name test_storage)
15
-
(libraries imapd alcotest eio_main))
16
-
17
-
(test
18
-
(name test_server)
19
-
(libraries imapd alcotest))
20
-
21
1
(test
22
2
(name test_write)
23
3
(libraries imap alcotest eio eio_main))
···
33
13
(test
34
14
(name test_subject)
35
15
(libraries imap alcotest))
36
-
37
-
(test
38
-
(name test_utf8)
39
-
(libraries imapd alcotest))
-54
test/test_auth.ml
-54
test/test_auth.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_auth module *)
7
-
8
-
open Imapd.Auth
9
-
10
-
let test_mock_auth_add_user () =
11
-
let auth = Mock_auth.create ~service_name:"test" in
12
-
Mock_auth.add_user auth ~username:"alice" ~password:"secret";
13
-
Alcotest.(check bool) "auth success" true
14
-
(Mock_auth.authenticate auth ~username:"alice" ~password:"secret");
15
-
Alcotest.(check bool) "auth fail wrong pass" false
16
-
(Mock_auth.authenticate auth ~username:"alice" ~password:"wrong");
17
-
Alcotest.(check bool) "auth fail unknown user" false
18
-
(Mock_auth.authenticate auth ~username:"bob" ~password:"secret")
19
-
20
-
let test_mock_auth_remove_user () =
21
-
let auth = Mock_auth.create ~service_name:"test" in
22
-
Mock_auth.add_user auth ~username:"alice" ~password:"secret";
23
-
Alcotest.(check bool) "auth before remove" true
24
-
(Mock_auth.authenticate auth ~username:"alice" ~password:"secret");
25
-
Mock_auth.remove_user auth ~username:"alice";
26
-
Alcotest.(check bool) "auth after remove" false
27
-
(Mock_auth.authenticate auth ~username:"alice" ~password:"secret")
28
-
29
-
let test_mock_auth_update_password () =
30
-
let auth = Mock_auth.create ~service_name:"test" in
31
-
Mock_auth.add_user auth ~username:"alice" ~password:"old";
32
-
Mock_auth.add_user auth ~username:"alice" ~password:"new";
33
-
Alcotest.(check bool) "old password fails" false
34
-
(Mock_auth.authenticate auth ~username:"alice" ~password:"old");
35
-
Alcotest.(check bool) "new password works" true
36
-
(Mock_auth.authenticate auth ~username:"alice" ~password:"new")
37
-
38
-
let test_pam_available () =
39
-
(* PAM should be available if compiled with PAM support *)
40
-
let available = Pam_auth.is_available () in
41
-
Alcotest.(check bool) "PAM available" true available
42
-
43
-
let () =
44
-
let open Alcotest in
45
-
run "imap_auth" [
46
-
"mock_auth", [
47
-
test_case "add_user and authenticate" `Quick test_mock_auth_add_user;
48
-
test_case "remove_user" `Quick test_mock_auth_remove_user;
49
-
test_case "update password" `Quick test_mock_auth_update_password;
50
-
];
51
-
"pam_auth", [
52
-
test_case "is_available" `Quick test_pam_available;
53
-
];
54
-
]
-154
test/test_parser.ml
-154
test/test_parser.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_parser module *)
7
-
8
-
open Imapd.Parser
9
-
10
-
let test_parse_capability () =
11
-
match parse_command "A001 CAPABILITY\r\n" with
12
-
| Ok { tag; command = Capability } ->
13
-
Alcotest.(check string) "tag" "A001" tag
14
-
| Ok _ -> Alcotest.fail "Wrong command parsed"
15
-
| Error msg -> Alcotest.fail msg
16
-
17
-
let test_parse_noop () =
18
-
match parse_command "A002 NOOP\r\n" with
19
-
| Ok { tag; command = Noop } ->
20
-
Alcotest.(check string) "tag" "A002" tag
21
-
| Ok _ -> Alcotest.fail "Wrong command parsed"
22
-
| Error msg -> Alcotest.fail msg
23
-
24
-
let test_parse_logout () =
25
-
match parse_command "A003 LOGOUT\r\n" with
26
-
| Ok { tag; command = Logout } ->
27
-
Alcotest.(check string) "tag" "A003" tag
28
-
| Ok _ -> Alcotest.fail "Wrong command parsed"
29
-
| Error msg -> Alcotest.fail msg
30
-
31
-
let test_parse_login () =
32
-
match parse_command "A004 LOGIN \"user\" \"pass\"\r\n" with
33
-
| Ok { tag; command = Login { username; password } } ->
34
-
Alcotest.(check string) "tag" "A004" tag;
35
-
Alcotest.(check string) "username" "user" username;
36
-
Alcotest.(check string) "password" "pass" password
37
-
| Ok _ -> Alcotest.fail "Wrong command parsed"
38
-
| Error msg -> Alcotest.fail msg
39
-
40
-
let test_parse_login_atom () =
41
-
match parse_command "A005 LOGIN user pass\r\n" with
42
-
| Ok { tag; command = Login { username; password } } ->
43
-
Alcotest.(check string) "tag" "A005" tag;
44
-
Alcotest.(check string) "username" "user" username;
45
-
Alcotest.(check string) "password" "pass" password
46
-
| Ok _ -> Alcotest.fail "Wrong command parsed"
47
-
| Error msg -> Alcotest.fail msg
48
-
49
-
let test_parse_select () =
50
-
match parse_command "A006 SELECT INBOX\r\n" with
51
-
| Ok { tag; command = Select mailbox } ->
52
-
Alcotest.(check string) "tag" "A006" tag;
53
-
Alcotest.(check string) "mailbox" "INBOX" mailbox
54
-
| Ok _ -> Alcotest.fail "Wrong command parsed"
55
-
| Error msg -> Alcotest.fail msg
56
-
57
-
let test_parse_examine () =
58
-
match parse_command "A007 EXAMINE \"Sent Items\"\r\n" with
59
-
| Ok { tag; command = Examine mailbox } ->
60
-
Alcotest.(check string) "tag" "A007" tag;
61
-
Alcotest.(check string) "mailbox" "Sent Items" mailbox
62
-
| Ok _ -> Alcotest.fail "Wrong command parsed"
63
-
| Error msg -> Alcotest.fail msg
64
-
65
-
let test_parse_list () =
66
-
match parse_command "A008 LIST \"\" \"*\"\r\n" with
67
-
| Ok { tag; command = List (List_basic { reference; pattern }) } ->
68
-
Alcotest.(check string) "tag" "A008" tag;
69
-
Alcotest.(check string) "reference" "" reference;
70
-
Alcotest.(check string) "pattern" "*" pattern
71
-
| Ok _ -> Alcotest.fail "Wrong command parsed"
72
-
| Error msg -> Alcotest.fail msg
73
-
74
-
let test_parse_fetch () =
75
-
match parse_command "A009 FETCH 1:* FLAGS\r\n" with
76
-
| Ok { tag; command = Fetch { sequence; items } } ->
77
-
Alcotest.(check string) "tag" "A009" tag;
78
-
Alcotest.(check int) "sequence length" 1 (List.length sequence);
79
-
Alcotest.(check int) "items length" 1 (List.length items)
80
-
| Ok _ -> Alcotest.fail "Wrong command parsed"
81
-
| Error msg -> Alcotest.fail msg
82
-
83
-
let test_parse_store () =
84
-
match parse_command "A010 STORE 1 +FLAGS (\\Seen)\r\n" with
85
-
| Ok { tag; command = Store { sequence = _; silent; action; flags } } ->
86
-
Alcotest.(check string) "tag" "A010" tag;
87
-
Alcotest.(check bool) "silent" false silent;
88
-
Alcotest.(check bool) "action is add" true (action = Imapd.Protocol.Store_add);
89
-
Alcotest.(check int) "flags length" 1 (List.length flags)
90
-
| Ok _ -> Alcotest.fail "Wrong command parsed"
91
-
| Error msg -> Alcotest.fail msg
92
-
93
-
let test_response_ok () =
94
-
let resp = response_to_string (Ok { tag = Some "A001"; code = None; text = "completed" }) in
95
-
Alcotest.(check string) "OK response" "A001 OK completed\r\n" resp
96
-
97
-
let test_response_capability () =
98
-
let resp = response_to_string (Capability_response ["IMAP4rev2"; "IDLE"]) in
99
-
Alcotest.(check string) "CAPABILITY response" "* CAPABILITY IMAP4rev2 IDLE\r\n" resp
100
-
101
-
let test_response_exists () =
102
-
let resp = response_to_string (Exists 42) in
103
-
Alcotest.(check string) "EXISTS response" "* 42 EXISTS\r\n" resp
104
-
105
-
let test_parse_id_nil () =
106
-
match parse_command "A011 ID NIL\r\n" with
107
-
| Ok { tag; command = Id None } ->
108
-
Alcotest.(check string) "tag" "A011" tag
109
-
| Ok _ -> Alcotest.fail "Wrong command parsed"
110
-
| Error msg -> Alcotest.fail msg
111
-
112
-
let test_parse_id_params () =
113
-
match parse_command "A012 ID (\"name\" \"test\" \"version\" \"1.0\")\r\n" with
114
-
| Ok { tag; command = Id (Some params) } ->
115
-
Alcotest.(check string) "tag" "A012" tag;
116
-
Alcotest.(check int) "params length" 2 (List.length params);
117
-
Alcotest.(check string) "first key" "name" (fst (List.hd params))
118
-
| Ok _ -> Alcotest.fail "Wrong command parsed"
119
-
| Error msg -> Alcotest.fail msg
120
-
121
-
let test_response_id () =
122
-
let resp = response_to_string (Id_response (Some [("name", "imapd"); ("version", "0.1.0")])) in
123
-
Alcotest.(check bool) "has ID" true (String.sub resp 0 5 = "* ID ");
124
-
Alcotest.(check bool) "has name" true (String.length resp > 10)
125
-
126
-
let test_response_id_nil () =
127
-
let resp = response_to_string (Id_response None) in
128
-
Alcotest.(check string) "ID NIL response" "* ID NIL\r\n" resp
129
-
130
-
let () =
131
-
let open Alcotest in
132
-
run "imap_parser" [
133
-
"commands", [
134
-
test_case "CAPABILITY" `Quick test_parse_capability;
135
-
test_case "NOOP" `Quick test_parse_noop;
136
-
test_case "LOGOUT" `Quick test_parse_logout;
137
-
test_case "LOGIN quoted" `Quick test_parse_login;
138
-
test_case "LOGIN atom" `Quick test_parse_login_atom;
139
-
test_case "SELECT" `Quick test_parse_select;
140
-
test_case "EXAMINE" `Quick test_parse_examine;
141
-
test_case "LIST" `Quick test_parse_list;
142
-
test_case "FETCH" `Quick test_parse_fetch;
143
-
test_case "STORE" `Quick test_parse_store;
144
-
test_case "ID NIL" `Quick test_parse_id_nil;
145
-
test_case "ID params" `Quick test_parse_id_params;
146
-
];
147
-
"responses", [
148
-
test_case "OK response" `Quick test_response_ok;
149
-
test_case "CAPABILITY response" `Quick test_response_capability;
150
-
test_case "EXISTS response" `Quick test_response_exists;
151
-
test_case "ID response" `Quick test_response_id;
152
-
test_case "ID NIL response" `Quick test_response_id_nil;
153
-
];
154
-
]
-275
test/test_server.ml
-275
test/test_server.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Integration tests for imap_server module *)
7
-
8
-
(* Note: Full connection handling tests require EIO mock flows which are complex to set up.
9
-
These tests focus on response serialization and parser integration. *)
10
-
11
-
open Imapd.Protocol
12
-
open Imapd.Parser
13
-
14
-
(* Helper: check if string contains substring *)
15
-
let contains_substring ~substring s =
16
-
let len = String.length substring in
17
-
let rec loop i =
18
-
if i + len > String.length s then false
19
-
else if String.sub s i len = substring then true
20
-
else loop (i + 1)
21
-
in
22
-
loop 0
23
-
24
-
(* Helper: check if string starts with prefix *)
25
-
let starts_with ~prefix s =
26
-
let len = String.length prefix in
27
-
String.length s >= len && String.sub s 0 len = prefix
28
-
29
-
(* Test response serialization *)
30
-
let test_ok_response () =
31
-
let response = Ok { tag = Some "A001"; code = None; text = "completed" } in
32
-
let serialized = response_to_string response in
33
-
Alcotest.(check bool) "has tag" true
34
-
(contains_substring ~substring:"A001" serialized);
35
-
Alcotest.(check bool) "has OK" true
36
-
(contains_substring ~substring:"OK" serialized);
37
-
Alcotest.(check bool) "has text" true
38
-
(contains_substring ~substring:"completed" serialized)
39
-
40
-
let test_no_response () =
41
-
let response = No { tag = Some "A002"; code = Some Code_nonexistent; text = "not found" } in
42
-
let serialized = response_to_string response in
43
-
Alcotest.(check bool) "has tag" true
44
-
(contains_substring ~substring:"A002" serialized);
45
-
Alcotest.(check bool) "has NO" true
46
-
(contains_substring ~substring:"NO" serialized);
47
-
Alcotest.(check bool) "has NONEXISTENT code" true
48
-
(contains_substring ~substring:"NONEXISTENT" serialized)
49
-
50
-
let test_bad_response () =
51
-
let response = Bad { tag = Some "A003"; code = None; text = "syntax error" } in
52
-
let serialized = response_to_string response in
53
-
Alcotest.(check bool) "has tag" true
54
-
(contains_substring ~substring:"A003" serialized);
55
-
Alcotest.(check bool) "has BAD" true
56
-
(contains_substring ~substring:"BAD" serialized)
57
-
58
-
let test_capability_response () =
59
-
let response = Capability_response ["IMAP4rev2"; "STARTTLS"; "IDLE"] in
60
-
let serialized = response_to_string response in
61
-
Alcotest.(check bool) "has CAPABILITY" true
62
-
(contains_substring ~substring:"CAPABILITY" serialized);
63
-
Alcotest.(check bool) "has IMAP4rev2" true
64
-
(contains_substring ~substring:"IMAP4rev2" serialized);
65
-
Alcotest.(check bool) "has STARTTLS" true
66
-
(contains_substring ~substring:"STARTTLS" serialized)
67
-
68
-
let test_list_response () =
69
-
let response = List_response { flags = []; delimiter = Some '/'; name = "INBOX"; extended = [] } in
70
-
let serialized = response_to_string response in
71
-
Alcotest.(check bool) "has LIST" true
72
-
(contains_substring ~substring:"LIST" serialized);
73
-
Alcotest.(check bool) "has delimiter" true
74
-
(contains_substring ~substring:"\"/\"" serialized);
75
-
Alcotest.(check bool) "has INBOX" true
76
-
(contains_substring ~substring:"INBOX" serialized)
77
-
78
-
let test_exists_response () =
79
-
let response = Exists 42 in
80
-
let serialized = response_to_string response in
81
-
Alcotest.(check bool) "has EXISTS" true
82
-
(contains_substring ~substring:"EXISTS" serialized);
83
-
Alcotest.(check bool) "has count" true
84
-
(contains_substring ~substring:"42" serialized)
85
-
86
-
let test_bye_response () =
87
-
let response = Bye { code = None; text = "Server shutting down" } in
88
-
let serialized = response_to_string response in
89
-
Alcotest.(check bool) "has BYE" true
90
-
(contains_substring ~substring:"BYE" serialized);
91
-
Alcotest.(check bool) "has text" true
92
-
(contains_substring ~substring:"Server shutting down" serialized)
93
-
94
-
let test_continuation_response () =
95
-
let response = Continuation (Some "Ready for data") in
96
-
let serialized = response_to_string response in
97
-
Alcotest.(check bool) "starts with +" true
98
-
(starts_with ~prefix:"+ " serialized)
99
-
100
-
let test_namespace_response () =
101
-
let response = Namespace_response {
102
-
personal = Some [{ prefix = ""; delimiter = Some '/' }];
103
-
other = None;
104
-
shared = None;
105
-
} in
106
-
let serialized = response_to_string response in
107
-
Alcotest.(check bool) "has NAMESPACE" true
108
-
(contains_substring ~substring:"NAMESPACE" serialized)
109
-
110
-
let test_status_response () =
111
-
let response = Status_response {
112
-
mailbox = "INBOX";
113
-
items = [(Status_messages, 10L); (Status_uidnext, 100L)];
114
-
} in
115
-
let serialized = response_to_string response in
116
-
Alcotest.(check bool) "has STATUS" true
117
-
(contains_substring ~substring:"STATUS" serialized);
118
-
Alcotest.(check bool) "has MESSAGES" true
119
-
(contains_substring ~substring:"MESSAGES 10" serialized)
120
-
121
-
let test_enabled_response () =
122
-
let response = Enabled ["IMAP4rev2"; "UTF8=ACCEPT"] in
123
-
let serialized = response_to_string response in
124
-
Alcotest.(check bool) "has ENABLED" true
125
-
(contains_substring ~substring:"ENABLED" serialized)
126
-
127
-
(* Test command parsing *)
128
-
let test_parse_login () =
129
-
match parse_command "A001 LOGIN user pass\r\n" with
130
-
| Result.Ok cmd ->
131
-
Alcotest.(check string) "tag" "A001" cmd.tag;
132
-
(match cmd.command with
133
-
| Login { username; password } ->
134
-
Alcotest.(check string) "username" "user" username;
135
-
Alcotest.(check string) "password" "pass" password
136
-
| _ -> Alcotest.fail "Expected Login command")
137
-
| Result.Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
138
-
139
-
let test_parse_select () =
140
-
match parse_command "A002 SELECT INBOX\r\n" with
141
-
| Result.Ok cmd ->
142
-
Alcotest.(check string) "tag" "A002" cmd.tag;
143
-
(match cmd.command with
144
-
| Select mb -> Alcotest.(check string) "mailbox" "INBOX" mb
145
-
| _ -> Alcotest.fail "Expected Select command")
146
-
| Result.Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
147
-
148
-
let test_parse_fetch () =
149
-
match parse_command "A003 FETCH 1:5 FLAGS\r\n" with
150
-
| Result.Ok cmd ->
151
-
Alcotest.(check string) "tag" "A003" cmd.tag;
152
-
(match cmd.command with
153
-
| Fetch { sequence; items } ->
154
-
Alcotest.(check int) "sequence length" 1 (List.length sequence);
155
-
Alcotest.(check int) "items length" 1 (List.length items)
156
-
| _ -> Alcotest.fail "Expected Fetch command")
157
-
| Result.Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
158
-
159
-
let test_parse_store () =
160
-
match parse_command "A004 STORE 1 +FLAGS (\\Seen)\r\n" with
161
-
| Result.Ok cmd ->
162
-
Alcotest.(check string) "tag" "A004" cmd.tag;
163
-
(match cmd.command with
164
-
| Store { action; flags; _ } ->
165
-
Alcotest.(check bool) "action is add" true (action = Store_add);
166
-
Alcotest.(check int) "one flag" 1 (List.length flags)
167
-
| _ -> Alcotest.fail "Expected Store command")
168
-
| Result.Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
169
-
170
-
let test_parse_list () =
171
-
match parse_command "A005 LIST \"\" \"*\"\r\n" with
172
-
| Result.Ok cmd ->
173
-
Alcotest.(check string) "tag" "A005" cmd.tag;
174
-
(match cmd.command with
175
-
| List (List_basic { reference; pattern }) ->
176
-
Alcotest.(check string) "reference" "" reference;
177
-
Alcotest.(check string) "pattern" "*" pattern
178
-
| List (List_extended _) -> Alcotest.fail "Expected basic List command"
179
-
| _ -> Alcotest.fail "Expected List command")
180
-
| Result.Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
181
-
182
-
let test_parse_create () =
183
-
match parse_command "A006 CREATE Drafts\r\n" with
184
-
| Result.Ok cmd ->
185
-
Alcotest.(check string) "tag" "A006" cmd.tag;
186
-
(match cmd.command with
187
-
| Create mb -> Alcotest.(check string) "mailbox" "Drafts" mb
188
-
| _ -> Alcotest.fail "Expected Create command")
189
-
| Result.Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
190
-
191
-
let test_parse_namespace () =
192
-
match parse_command "A007 NAMESPACE\r\n" with
193
-
| Result.Ok cmd ->
194
-
Alcotest.(check string) "tag" "A007" cmd.tag;
195
-
(match cmd.command with
196
-
| Namespace -> ()
197
-
| _ -> Alcotest.fail "Expected Namespace command")
198
-
| Result.Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
199
-
200
-
let test_parse_idle () =
201
-
match parse_command "A008 IDLE\r\n" with
202
-
| Result.Ok cmd ->
203
-
Alcotest.(check string) "tag" "A008" cmd.tag;
204
-
(match cmd.command with
205
-
| Idle -> ()
206
-
| _ -> Alcotest.fail "Expected Idle command")
207
-
| Result.Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
208
-
209
-
let test_parse_starttls () =
210
-
match parse_command "A009 STARTTLS\r\n" with
211
-
| Result.Ok cmd ->
212
-
Alcotest.(check string) "tag" "A009" cmd.tag;
213
-
(match cmd.command with
214
-
| Starttls -> ()
215
-
| _ -> Alcotest.fail "Expected Starttls command")
216
-
| Result.Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
217
-
218
-
let test_parse_capability () =
219
-
match parse_command "A010 CAPABILITY\r\n" with
220
-
| Result.Ok cmd ->
221
-
Alcotest.(check string) "tag" "A010" cmd.tag;
222
-
(match cmd.command with
223
-
| Capability -> ()
224
-
| _ -> Alcotest.fail "Expected Capability command")
225
-
| Result.Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
226
-
227
-
let test_parse_logout () =
228
-
match parse_command "A011 LOGOUT\r\n" with
229
-
| Result.Ok cmd ->
230
-
Alcotest.(check string) "tag" "A011" cmd.tag;
231
-
(match cmd.command with
232
-
| Logout -> ()
233
-
| _ -> Alcotest.fail "Expected Logout command")
234
-
| Result.Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
235
-
236
-
let test_parse_uid_fetch () =
237
-
match parse_command "A012 UID FETCH 100:200 FLAGS\r\n" with
238
-
| Result.Ok cmd ->
239
-
Alcotest.(check string) "tag" "A012" cmd.tag;
240
-
(match cmd.command with
241
-
| Uid (Uid_fetch _) -> ()
242
-
| _ -> Alcotest.fail "Expected UID FETCH command")
243
-
| Result.Error msg -> Alcotest.fail ("Parse failed: " ^ msg)
244
-
245
-
let () =
246
-
let open Alcotest in
247
-
run "imap_server" [
248
-
"response_serialization", [
249
-
test_case "ok_response" `Quick test_ok_response;
250
-
test_case "no_response" `Quick test_no_response;
251
-
test_case "bad_response" `Quick test_bad_response;
252
-
test_case "capability_response" `Quick test_capability_response;
253
-
test_case "list_response" `Quick test_list_response;
254
-
test_case "exists_response" `Quick test_exists_response;
255
-
test_case "bye_response" `Quick test_bye_response;
256
-
test_case "continuation_response" `Quick test_continuation_response;
257
-
test_case "namespace_response" `Quick test_namespace_response;
258
-
test_case "status_response" `Quick test_status_response;
259
-
test_case "enabled_response" `Quick test_enabled_response;
260
-
];
261
-
"command_parsing", [
262
-
test_case "login" `Quick test_parse_login;
263
-
test_case "select" `Quick test_parse_select;
264
-
test_case "fetch" `Quick test_parse_fetch;
265
-
test_case "store" `Quick test_parse_store;
266
-
test_case "list" `Quick test_parse_list;
267
-
test_case "create" `Quick test_parse_create;
268
-
test_case "namespace" `Quick test_parse_namespace;
269
-
test_case "idle" `Quick test_parse_idle;
270
-
test_case "starttls" `Quick test_parse_starttls;
271
-
test_case "capability" `Quick test_parse_capability;
272
-
test_case "logout" `Quick test_parse_logout;
273
-
test_case "uid_fetch" `Quick test_parse_uid_fetch;
274
-
];
275
-
]
-339
test/test_storage.ml
-339
test/test_storage.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_storage module *)
7
-
8
-
open Imapd.Storage
9
-
open Imapd.Protocol
10
-
11
-
let test_memory_create_mailbox () =
12
-
let storage = Memory_storage.create () in
13
-
Memory_storage.add_test_user storage ~username:"test";
14
-
15
-
(* Create a new mailbox *)
16
-
let result = Memory_storage.create_mailbox storage ~username:"test" "Drafts" in
17
-
Alcotest.(check bool) "create success" true (Result.is_ok result);
18
-
19
-
(* Creating same mailbox again should fail *)
20
-
let result2 = Memory_storage.create_mailbox storage ~username:"test" "Drafts" in
21
-
Alcotest.(check bool) "duplicate fails" true (Result.is_error result2)
22
-
23
-
let test_memory_delete_mailbox () =
24
-
let storage = Memory_storage.create () in
25
-
Memory_storage.add_test_user storage ~username:"test";
26
-
ignore (Memory_storage.create_mailbox storage ~username:"test" "ToDelete");
27
-
28
-
(* Delete the mailbox *)
29
-
let result = Memory_storage.delete_mailbox storage ~username:"test" "ToDelete" in
30
-
Alcotest.(check bool) "delete success" true (Result.is_ok result);
31
-
32
-
(* Deleting INBOX should fail *)
33
-
let result2 = Memory_storage.delete_mailbox storage ~username:"test" "INBOX" in
34
-
Alcotest.(check bool) "delete inbox fails" true (Result.is_error result2)
35
-
36
-
let test_memory_select_mailbox () =
37
-
let storage = Memory_storage.create () in
38
-
Memory_storage.add_test_user storage ~username:"test";
39
-
40
-
(* Select INBOX *)
41
-
let result = Memory_storage.select_mailbox storage ~username:"test" "INBOX" ~readonly:false in
42
-
match result with
43
-
| Ok state ->
44
-
Alcotest.(check string) "mailbox name" "INBOX" state.name;
45
-
Alcotest.(check bool) "not readonly" false state.readonly
46
-
| Error _ -> Alcotest.fail "select failed"
47
-
48
-
let test_memory_list_mailboxes () =
49
-
let storage = Memory_storage.create () in
50
-
Memory_storage.add_test_user storage ~username:"test";
51
-
ignore (Memory_storage.create_mailbox storage ~username:"test" "Sent");
52
-
ignore (Memory_storage.create_mailbox storage ~username:"test" "Drafts");
53
-
54
-
let mailboxes = Memory_storage.list_mailboxes storage ~username:"test" ~reference:"" ~pattern:"*" in
55
-
Alcotest.(check bool) "has mailboxes" true (List.length mailboxes >= 3) (* INBOX + 2 created *)
56
-
57
-
let test_memory_append_message () =
58
-
let storage = Memory_storage.create () in
59
-
Memory_storage.add_test_user storage ~username:"test";
60
-
61
-
let result = Memory_storage.append storage
62
-
~username:"test"
63
-
~mailbox:"INBOX"
64
-
~flags:[System Seen]
65
-
~date:None
66
-
~message:"From: test@example.com\r\nSubject: Test\r\n\r\nHello World"
67
-
in
68
-
match result with
69
-
| Ok uid ->
70
-
Alcotest.(check bool) "uid is positive" true (uid > 0l)
71
-
| Error _ -> Alcotest.fail "append failed"
72
-
73
-
let test_memory_fetch_messages () =
74
-
let storage = Memory_storage.create () in
75
-
Memory_storage.add_test_user storage ~username:"test";
76
-
ignore (Memory_storage.append storage
77
-
~username:"test"
78
-
~mailbox:"INBOX"
79
-
~flags:[]
80
-
~date:None
81
-
~message:"Test message");
82
-
83
-
let result = Memory_storage.fetch_messages storage
84
-
~username:"test"
85
-
~mailbox:"INBOX"
86
-
~sequence:[Single 1]
87
-
~items:[Fetch_flags]
88
-
in
89
-
match result with
90
-
| Ok msgs ->
91
-
Alcotest.(check int) "one message" 1 (List.length msgs)
92
-
| Error _ -> Alcotest.fail "fetch failed"
93
-
94
-
let test_memory_store_flags () =
95
-
let storage = Memory_storage.create () in
96
-
Memory_storage.add_test_user storage ~username:"test";
97
-
ignore (Memory_storage.append storage
98
-
~username:"test"
99
-
~mailbox:"INBOX"
100
-
~flags:[]
101
-
~date:None
102
-
~message:"Test");
103
-
104
-
let result = Memory_storage.store_flags storage
105
-
~username:"test"
106
-
~mailbox:"INBOX"
107
-
~sequence:[Single 1]
108
-
~action:Store_add
109
-
~flags:[System Seen]
110
-
in
111
-
match result with
112
-
| Ok msgs ->
113
-
let msg = List.hd msgs in
114
-
Alcotest.(check bool) "has Seen flag" true (List.mem (System Seen) msg.flags)
115
-
| Error _ -> Alcotest.fail "store failed"
116
-
117
-
let test_memory_expunge () =
118
-
let storage = Memory_storage.create () in
119
-
Memory_storage.add_test_user storage ~username:"test";
120
-
ignore (Memory_storage.append storage
121
-
~username:"test"
122
-
~mailbox:"INBOX"
123
-
~flags:[System Deleted]
124
-
~date:None
125
-
~message:"To be deleted");
126
-
127
-
let result = Memory_storage.expunge storage ~username:"test" ~mailbox:"INBOX" in
128
-
match result with
129
-
| Ok uids ->
130
-
Alcotest.(check int) "one expunged" 1 (List.length uids)
131
-
| Error _ -> Alcotest.fail "expunge failed"
132
-
133
-
(* ===== Maildir Storage Tests ===== *)
134
-
135
-
(* Helper to create a temporary directory *)
136
-
let with_temp_dir f =
137
-
let base = Filename.get_temp_dir_name () in
138
-
let rec try_create n =
139
-
let path = Printf.sprintf "%s/imapd_test_%d_%d" base (Unix.getpid ()) n in
140
-
if Sys.file_exists path then try_create (n + 1)
141
-
else begin
142
-
Unix.mkdir path 0o700;
143
-
Fun.protect ~finally:(fun () ->
144
-
(* Clean up recursively *)
145
-
let rec rm path =
146
-
if Sys.is_directory path then begin
147
-
Array.iter (fun name -> rm (Filename.concat path name)) (Sys.readdir path);
148
-
Unix.rmdir path
149
-
end else
150
-
Sys.remove path
151
-
in
152
-
(try rm path with _ -> ())
153
-
) (fun () -> f path)
154
-
end
155
-
in
156
-
try_create 0
157
-
158
-
let test_maildir_create_mailbox () =
159
-
with_temp_dir @@ fun tmp_path ->
160
-
let storage = Maildir_storage.create_with_path ~base_path:tmp_path in
161
-
Maildir_storage.ensure_user storage ~username:"test";
162
-
163
-
(* Create a new mailbox *)
164
-
let result = Maildir_storage.create_mailbox storage ~username:"test" "Drafts" in
165
-
Alcotest.(check bool) "create success" true (Result.is_ok result);
166
-
167
-
(* Creating same mailbox again should fail *)
168
-
let result2 = Maildir_storage.create_mailbox storage ~username:"test" "Drafts" in
169
-
Alcotest.(check bool) "duplicate fails" true (Result.is_error result2)
170
-
171
-
let test_maildir_delete_mailbox () =
172
-
with_temp_dir @@ fun tmp_path ->
173
-
let storage = Maildir_storage.create_with_path ~base_path:tmp_path in
174
-
Maildir_storage.ensure_user storage ~username:"test";
175
-
ignore (Maildir_storage.create_mailbox storage ~username:"test" "ToDelete");
176
-
177
-
(* Delete the mailbox *)
178
-
let result = Maildir_storage.delete_mailbox storage ~username:"test" "ToDelete" in
179
-
Alcotest.(check bool) "delete success" true (Result.is_ok result);
180
-
181
-
(* Deleting INBOX should fail *)
182
-
let result2 = Maildir_storage.delete_mailbox storage ~username:"test" "INBOX" in
183
-
Alcotest.(check bool) "delete inbox fails" true (Result.is_error result2)
184
-
185
-
let test_maildir_select_mailbox () =
186
-
with_temp_dir @@ fun tmp_path ->
187
-
let storage = Maildir_storage.create_with_path ~base_path:tmp_path in
188
-
Maildir_storage.ensure_user storage ~username:"test";
189
-
190
-
(* Select INBOX *)
191
-
let result = Maildir_storage.select_mailbox storage ~username:"test" "INBOX" ~readonly:false in
192
-
match result with
193
-
| Ok state ->
194
-
Alcotest.(check string) "mailbox name" "INBOX" state.name;
195
-
Alcotest.(check bool) "not readonly" false state.readonly
196
-
| Error _ -> Alcotest.fail "select failed"
197
-
198
-
let test_maildir_list_mailboxes () =
199
-
with_temp_dir @@ fun tmp_path ->
200
-
let storage = Maildir_storage.create_with_path ~base_path:tmp_path in
201
-
Maildir_storage.ensure_user storage ~username:"test";
202
-
ignore (Maildir_storage.create_mailbox storage ~username:"test" "Sent");
203
-
ignore (Maildir_storage.create_mailbox storage ~username:"test" "Drafts");
204
-
205
-
let mailboxes = Maildir_storage.list_mailboxes storage ~username:"test" ~reference:"" ~pattern:"*" in
206
-
Alcotest.(check bool) "has mailboxes" true (List.length mailboxes >= 3) (* INBOX + 2 created *)
207
-
208
-
let test_maildir_append_message () =
209
-
with_temp_dir @@ fun tmp_path ->
210
-
let storage = Maildir_storage.create_with_path ~base_path:tmp_path in
211
-
Maildir_storage.ensure_user storage ~username:"test";
212
-
213
-
let result = Maildir_storage.append storage
214
-
~username:"test"
215
-
~mailbox:"INBOX"
216
-
~flags:[System Seen]
217
-
~date:None
218
-
~message:"From: test@example.com\r\nSubject: Test\r\n\r\nHello World"
219
-
in
220
-
match result with
221
-
| Ok uid ->
222
-
Alcotest.(check bool) "uid is positive" true (uid > 0l)
223
-
| Error _ -> Alcotest.fail "append failed"
224
-
225
-
let test_maildir_fetch_messages () =
226
-
with_temp_dir @@ fun tmp_path ->
227
-
let storage = Maildir_storage.create_with_path ~base_path:tmp_path in
228
-
Maildir_storage.ensure_user storage ~username:"test";
229
-
ignore (Maildir_storage.append storage
230
-
~username:"test"
231
-
~mailbox:"INBOX"
232
-
~flags:[]
233
-
~date:None
234
-
~message:"Test message");
235
-
236
-
let result = Maildir_storage.fetch_messages storage
237
-
~username:"test"
238
-
~mailbox:"INBOX"
239
-
~sequence:[Single 1]
240
-
~items:[Fetch_flags]
241
-
in
242
-
match result with
243
-
| Ok msgs ->
244
-
Alcotest.(check int) "one message" 1 (List.length msgs)
245
-
| Error _ -> Alcotest.fail "fetch failed"
246
-
247
-
let test_maildir_store_flags () =
248
-
with_temp_dir @@ fun tmp_path ->
249
-
let storage = Maildir_storage.create_with_path ~base_path:tmp_path in
250
-
Maildir_storage.ensure_user storage ~username:"test";
251
-
ignore (Maildir_storage.append storage
252
-
~username:"test"
253
-
~mailbox:"INBOX"
254
-
~flags:[]
255
-
~date:None
256
-
~message:"Test");
257
-
258
-
let result = Maildir_storage.store_flags storage
259
-
~username:"test"
260
-
~mailbox:"INBOX"
261
-
~sequence:[Single 1]
262
-
~action:Store_add
263
-
~flags:[System Seen]
264
-
in
265
-
match result with
266
-
| Ok msgs ->
267
-
let msg = List.hd msgs in
268
-
Alcotest.(check bool) "has Seen flag" true (List.mem (System Seen) msg.flags)
269
-
| Error _ -> Alcotest.fail "store failed"
270
-
271
-
let test_maildir_expunge () =
272
-
with_temp_dir @@ fun tmp_path ->
273
-
let storage = Maildir_storage.create_with_path ~base_path:tmp_path in
274
-
Maildir_storage.ensure_user storage ~username:"test";
275
-
ignore (Maildir_storage.append storage
276
-
~username:"test"
277
-
~mailbox:"INBOX"
278
-
~flags:[System Deleted]
279
-
~date:None
280
-
~message:"To be deleted");
281
-
282
-
let result = Maildir_storage.expunge storage ~username:"test" ~mailbox:"INBOX" in
283
-
match result with
284
-
| Ok uids ->
285
-
Alcotest.(check int) "one expunged" 1 (List.length uids)
286
-
| Error _ -> Alcotest.fail "expunge failed"
287
-
288
-
let test_maildir_flag_persistence () =
289
-
with_temp_dir @@ fun tmp_path ->
290
-
let storage = Maildir_storage.create_with_path ~base_path:tmp_path in
291
-
Maildir_storage.ensure_user storage ~username:"test";
292
-
293
-
(* Append message with flags *)
294
-
ignore (Maildir_storage.append storage
295
-
~username:"test"
296
-
~mailbox:"INBOX"
297
-
~flags:[System Seen; System Flagged]
298
-
~date:None
299
-
~message:"Test with flags");
300
-
301
-
(* Fetch and verify flags are preserved *)
302
-
let result = Maildir_storage.fetch_messages storage
303
-
~username:"test"
304
-
~mailbox:"INBOX"
305
-
~sequence:[Single 1]
306
-
~items:[Fetch_flags]
307
-
in
308
-
match result with
309
-
| Ok msgs ->
310
-
let msg = List.hd msgs in
311
-
Alcotest.(check bool) "has Seen" true (List.mem (System Seen) msg.flags);
312
-
Alcotest.(check bool) "has Flagged" true (List.mem (System Flagged) msg.flags)
313
-
| Error _ -> Alcotest.fail "fetch failed"
314
-
315
-
let () =
316
-
let open Alcotest in
317
-
run "imap_storage" [
318
-
"memory_storage", [
319
-
test_case "create_mailbox" `Quick test_memory_create_mailbox;
320
-
test_case "delete_mailbox" `Quick test_memory_delete_mailbox;
321
-
test_case "select_mailbox" `Quick test_memory_select_mailbox;
322
-
test_case "list_mailboxes" `Quick test_memory_list_mailboxes;
323
-
test_case "append_message" `Quick test_memory_append_message;
324
-
test_case "fetch_messages" `Quick test_memory_fetch_messages;
325
-
test_case "store_flags" `Quick test_memory_store_flags;
326
-
test_case "expunge" `Quick test_memory_expunge;
327
-
];
328
-
"maildir_storage", [
329
-
test_case "create_mailbox" `Quick test_maildir_create_mailbox;
330
-
test_case "delete_mailbox" `Quick test_maildir_delete_mailbox;
331
-
test_case "select_mailbox" `Quick test_maildir_select_mailbox;
332
-
test_case "list_mailboxes" `Quick test_maildir_list_mailboxes;
333
-
test_case "append_message" `Quick test_maildir_append_message;
334
-
test_case "fetch_messages" `Quick test_maildir_fetch_messages;
335
-
test_case "store_flags" `Quick test_maildir_store_flags;
336
-
test_case "expunge" `Quick test_maildir_expunge;
337
-
test_case "flag_persistence" `Quick test_maildir_flag_persistence;
338
-
];
339
-
]
-50
test/test_types.ml
-50
test/test_types.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_types module *)
7
-
8
-
open Imapd.Protocol
9
-
10
-
let test_normalize_mailbox_name () =
11
-
Alcotest.(check string) "INBOX uppercase" "INBOX" (normalize_mailbox_name "INBOX");
12
-
Alcotest.(check string) "inbox lowercase" "INBOX" (normalize_mailbox_name "inbox");
13
-
Alcotest.(check string) "InBoX mixed" "INBOX" (normalize_mailbox_name "InBoX");
14
-
Alcotest.(check string) "Other mailbox" "Sent" (normalize_mailbox_name "Sent")
15
-
16
-
let test_is_inbox () =
17
-
Alcotest.(check bool) "INBOX is inbox" true (is_inbox "INBOX");
18
-
Alcotest.(check bool) "inbox is inbox" true (is_inbox "inbox");
19
-
Alcotest.(check bool) "Sent is not inbox" false (is_inbox "Sent")
20
-
21
-
let test_flag_to_string () =
22
-
Alcotest.(check string) "Seen flag" "\\Seen" (flag_to_string (System Seen));
23
-
Alcotest.(check string) "Answered flag" "\\Answered" (flag_to_string (System Answered));
24
-
Alcotest.(check string) "Flagged flag" "\\Flagged" (flag_to_string (System Flagged));
25
-
Alcotest.(check string) "Deleted flag" "\\Deleted" (flag_to_string (System Deleted));
26
-
Alcotest.(check string) "Draft flag" "\\Draft" (flag_to_string (System Draft));
27
-
Alcotest.(check string) "Keyword flag" "$Forwarded" (flag_to_string (Keyword "$Forwarded"))
28
-
29
-
let test_string_to_flag () =
30
-
let flag_testable = Alcotest.testable
31
-
(fun fmt f -> Format.pp_print_string fmt (match f with Some fl -> flag_to_string fl | None -> "None"))
32
-
(fun a b -> a = b)
33
-
in
34
-
Alcotest.(check flag_testable) "Parse \\Seen" (Some (System Seen)) (string_to_flag "\\Seen");
35
-
Alcotest.(check flag_testable) "Parse \\SEEN" (Some (System Seen)) (string_to_flag "\\SEEN");
36
-
Alcotest.(check flag_testable) "Parse keyword" (Some (Keyword "$Junk")) (string_to_flag "$Junk");
37
-
Alcotest.(check flag_testable) "Parse invalid" None (string_to_flag "\\Invalid")
38
-
39
-
let () =
40
-
let open Alcotest in
41
-
run "imap_types" [
42
-
"mailbox_name", [
43
-
test_case "normalize_mailbox_name" `Quick test_normalize_mailbox_name;
44
-
test_case "is_inbox" `Quick test_is_inbox;
45
-
];
46
-
"flags", [
47
-
test_case "flag_to_string" `Quick test_flag_to_string;
48
-
test_case "string_to_flag" `Quick test_string_to_flag;
49
-
];
50
-
]
-104
test/test_utf8.ml
-104
test/test_utf8.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Tests for UTF-8 validation per RFC 6855.
7
-
@see <https://datatracker.ietf.org/doc/html/rfc6855> RFC 6855: IMAP Support for UTF-8
8
-
@see <https://datatracker.ietf.org/doc/html/rfc3629> RFC 3629: UTF-8 encoding *)
9
-
10
-
open Imapd.Utf8
11
-
12
-
(* Test is_valid_utf8 function *)
13
-
14
-
let test_valid_utf8_ascii () =
15
-
Alcotest.(check bool) "empty string" true (is_valid_utf8 "");
16
-
Alcotest.(check bool) "ASCII string" true (is_valid_utf8 "Hello, World!");
17
-
Alcotest.(check bool) "ASCII with digits" true (is_valid_utf8 "Test123");
18
-
Alcotest.(check bool) "ASCII with special chars" true (is_valid_utf8 "a@b.com")
19
-
20
-
let test_valid_utf8_multibyte () =
21
-
(* 2-byte UTF-8: U+00E9 (e with acute) = 0xC3 0xA9 *)
22
-
Alcotest.(check bool) "2-byte UTF-8: cafe" true (is_valid_utf8 "caf\xc3\xa9");
23
-
(* 3-byte UTF-8: U+4E2D (Chinese character) = 0xE4 0xB8 0xAD *)
24
-
Alcotest.(check bool) "3-byte UTF-8: Chinese" true (is_valid_utf8 "\xe4\xb8\xad\xe6\x96\x87");
25
-
(* 4-byte UTF-8: U+1F600 (grinning face emoji) = 0xF0 0x9F 0x98 0x80 *)
26
-
Alcotest.(check bool) "4-byte UTF-8: emoji" true (is_valid_utf8 "\xf0\x9f\x98\x80");
27
-
(* Mixed ASCII and UTF-8 *)
28
-
Alcotest.(check bool) "mixed" true (is_valid_utf8 "Hello \xe4\xb8\x96\xe7\x95\x8c")
29
-
30
-
let test_invalid_utf8 () =
31
-
(* Invalid start bytes *)
32
-
Alcotest.(check bool) "invalid 0xFF" false (is_valid_utf8 "\xff");
33
-
Alcotest.(check bool) "invalid 0xFE" false (is_valid_utf8 "\xfe");
34
-
(* Continuation byte without start *)
35
-
Alcotest.(check bool) "orphan continuation" false (is_valid_utf8 "\x80");
36
-
(* Truncated sequences *)
37
-
Alcotest.(check bool) "truncated 2-byte" false (is_valid_utf8 "\xc3");
38
-
Alcotest.(check bool) "truncated 3-byte" false (is_valid_utf8 "\xe4\xb8");
39
-
Alcotest.(check bool) "truncated 4-byte" false (is_valid_utf8 "\xf0\x9f\x98");
40
-
(* Overlong encodings (RFC 3629 explicitly forbids these) *)
41
-
Alcotest.(check bool) "overlong NUL" false (is_valid_utf8 "\xc0\x80"); (* U+0000 as 2 bytes *)
42
-
Alcotest.(check bool) "overlong /" false (is_valid_utf8 "\xc0\xaf"); (* U+002F as 2 bytes *)
43
-
(* Surrogate pairs (U+D800..U+DFFF are invalid in UTF-8) *)
44
-
Alcotest.(check bool) "surrogate D800" false (is_valid_utf8 "\xed\xa0\x80"); (* U+D800 *)
45
-
Alcotest.(check bool) "surrogate DFFF" false (is_valid_utf8 "\xed\xbf\xbf"); (* U+DFFF *)
46
-
(* Code points above U+10FFFF *)
47
-
Alcotest.(check bool) "above max" false (is_valid_utf8 "\xf4\x90\x80\x80") (* U+110000 *)
48
-
49
-
(* Test has_non_ascii function *)
50
-
51
-
let test_has_non_ascii () =
52
-
Alcotest.(check bool) "ASCII only" false (has_non_ascii "Hello");
53
-
Alcotest.(check bool) "empty" false (has_non_ascii "");
54
-
Alcotest.(check bool) "with accented" true (has_non_ascii "caf\xc3\xa9");
55
-
Alcotest.(check bool) "all high bytes" true (has_non_ascii "\x80\x81\x82")
56
-
57
-
(* Test is_valid_utf8_mailbox_name function *)
58
-
59
-
let test_valid_mailbox_names () =
60
-
Alcotest.(check bool) "INBOX" true (is_valid_utf8_mailbox_name "INBOX");
61
-
Alcotest.(check bool) "Sent/2024" true (is_valid_utf8_mailbox_name "Sent/2024");
62
-
Alcotest.(check bool) "Drafts" true (is_valid_utf8_mailbox_name "Drafts");
63
-
(* Chinese "Sent" folder *)
64
-
Alcotest.(check bool) "Chinese mailbox" true
65
-
(is_valid_utf8_mailbox_name "\xe5\x8f\x91\xe4\xbb\xb6\xe7\xae\xb1");
66
-
(* Japanese "Inbox" folder *)
67
-
Alcotest.(check bool) "Japanese mailbox" true
68
-
(is_valid_utf8_mailbox_name "\xe5\x8f\x97\xe4\xbf\xa1\xe7\xae\xb1")
69
-
70
-
let test_invalid_mailbox_names () =
71
-
(* C0 control characters (U+0000..U+001F) *)
72
-
Alcotest.(check bool) "NUL char" false (is_valid_utf8_mailbox_name "INBOX\x00");
73
-
Alcotest.(check bool) "control 0x01" false (is_valid_utf8_mailbox_name "Test\x01Name");
74
-
Alcotest.(check bool) "control 0x1F" false (is_valid_utf8_mailbox_name "Test\x1f");
75
-
(* DELETE (U+007F) *)
76
-
Alcotest.(check bool) "DELETE char" false (is_valid_utf8_mailbox_name "Test\x7fName");
77
-
(* C1 control characters (U+0080..U+009F) - these are 2-byte UTF-8 sequences *)
78
-
Alcotest.(check bool) "C1 control 0x80" false (is_valid_utf8_mailbox_name "Test\xc2\x80Name");
79
-
Alcotest.(check bool) "C1 control 0x9F" false (is_valid_utf8_mailbox_name "Test\xc2\x9fName");
80
-
(* Line separator U+2028 = 0xE2 0x80 0xA8 *)
81
-
Alcotest.(check bool) "line separator" false
82
-
(is_valid_utf8_mailbox_name "Test\xe2\x80\xa8Name");
83
-
(* Paragraph separator U+2029 = 0xE2 0x80 0xA9 *)
84
-
Alcotest.(check bool) "paragraph separator" false
85
-
(is_valid_utf8_mailbox_name "Test\xe2\x80\xa9Name");
86
-
(* Invalid UTF-8 should also fail *)
87
-
Alcotest.(check bool) "invalid UTF-8" false (is_valid_utf8_mailbox_name "\xff\xfe")
88
-
89
-
let () =
90
-
let open Alcotest in
91
-
run "utf8" [
92
-
"is_valid_utf8", [
93
-
test_case "ASCII strings" `Quick test_valid_utf8_ascii;
94
-
test_case "multibyte UTF-8" `Quick test_valid_utf8_multibyte;
95
-
test_case "invalid UTF-8" `Quick test_invalid_utf8;
96
-
];
97
-
"has_non_ascii", [
98
-
test_case "detect non-ASCII" `Quick test_has_non_ascii;
99
-
];
100
-
"is_valid_utf8_mailbox_name", [
101
-
test_case "valid mailbox names" `Quick test_valid_mailbox_names;
102
-
test_case "invalid mailbox names" `Quick test_invalid_mailbox_names;
103
-
];
104
-
]