forked from
anil.recoil.org/ocaml-imap
IMAP in OCaml
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6(** IMAP Command Serialization
7
8 Serializes IMAP commands to the wire format using Eio.Buf_write. *)
9
10module W = Eio.Buf_write
11
12(** {1 Abstract Type} *)
13
14type t = W.t
15(** A command writer backed by Eio.Buf_write. *)
16
17let pp ppf _ = Fmt.string ppf "<Imap.Write.t>"
18let to_string _ = "<Imap.Write.t>"
19
20(** {1 Low-level Writers} *)
21
22let sp w = W.char w ' '
23let crlf w = W.string w "\r\n"
24
25let is_atom_char = function
26 | '(' | ')' | '{' | ' ' | '\x00' .. '\x1f' | '\x7f' | '%' | '*' | '"' | '\\'
27 | ']' ->
28 false
29 | c -> c >= '\x21' && c <= '\x7e'
30
31let is_atom s = String.length s > 0 && String.for_all is_atom_char s
32
33let atom w s = W.string w s
34
35let quoted_string w s =
36 W.char w '"';
37 String.iter
38 (fun c ->
39 match c with
40 | '"' | '\\' ->
41 W.char w '\\';
42 W.char w c
43 | _ -> W.char w c)
44 s;
45 W.char w '"'
46
47let literal w s =
48 W.char w '{';
49 W.string w (string_of_int (String.length s));
50 W.string w "}\r\n";
51 W.string w s
52
53let literal_plus w s =
54 W.char w '{';
55 W.string w (string_of_int (String.length s));
56 W.string w "+}\r\n";
57 W.string w s
58
59let needs_literal s =
60 String.exists (function '\r' | '\n' | '\x00' -> true | _ -> false) s
61
62let astring w s =
63 if is_atom s then atom w s
64 else if needs_literal s then literal w s
65 else quoted_string w s
66
67let nstring w = function
68 | None -> W.string w "NIL"
69 | Some s -> if needs_literal s then literal w s else quoted_string w s
70
71let number w n = W.string w (string_of_int n)
72let number32 w n = W.string w (Int32.to_string n)
73let number64 w n = W.string w (Int64.to_string n)
74
75(** {1 Sequence Sets} *)
76
77let sequence_range w = function
78 | Seq.Single n -> number w n
79 | Seq.Range (a, b) ->
80 number w a;
81 W.char w ':';
82 number w b
83 | Seq.From n ->
84 number w n;
85 W.string w ":*"
86 | Seq.All -> W.char w '*'
87
88let sequence_set w set =
89 List.iteri
90 (fun i r ->
91 if i > 0 then W.char w ',';
92 sequence_range w r)
93 set
94
95(** {1 Flags} *)
96
97let system_flag w = function
98 | `Seen -> W.string w "\\Seen"
99 | `Answered -> W.string w "\\Answered"
100 | `Flagged -> W.string w "\\Flagged"
101 | `Deleted -> W.string w "\\Deleted"
102 | `Draft -> W.string w "\\Draft"
103
104let flag w = function
105 | Flag.System f -> system_flag w f
106 | Flag.Keyword k -> W.string w (Mail_flag.Keyword.to_imap_string k)
107
108let flag_list w flags =
109 W.char w '(';
110 List.iteri
111 (fun i f ->
112 if i > 0 then sp w;
113 flag w f)
114 flags;
115 W.char w ')'
116
117(** {1 Search Return Options (RFC 4731 ESEARCH)} *)
118
119let search_return_opt w = function
120 | Command.Return_min -> W.string w "MIN"
121 | Command.Return_max -> W.string w "MAX"
122 | Command.Return_all -> W.string w "ALL"
123 | Command.Return_count -> W.string w "COUNT"
124
125let search_return_opts w opts =
126 W.string w "RETURN (";
127 List.iteri (fun i opt ->
128 if i > 0 then sp w;
129 search_return_opt w opt
130 ) opts;
131 W.char w ')'
132
133(** {1 Search Keys} *)
134
135let rec search_key w = function
136 | Search.All -> W.string w "ALL"
137 | Search.Answered -> W.string w "ANSWERED"
138 | Search.Bcc s ->
139 W.string w "BCC ";
140 astring w s
141 | Search.Before s ->
142 W.string w "BEFORE ";
143 atom w s
144 | Search.Body s ->
145 W.string w "BODY ";
146 astring w s
147 | Search.Cc s ->
148 W.string w "CC ";
149 astring w s
150 | Search.Deleted -> W.string w "DELETED"
151 | Search.Flagged -> W.string w "FLAGGED"
152 | Search.From s ->
153 W.string w "FROM ";
154 astring w s
155 | Search.Keyword s ->
156 W.string w "KEYWORD ";
157 atom w s
158 | Search.New -> W.string w "NEW"
159 | Search.Not k ->
160 W.string w "NOT ";
161 search_key w k
162 | Search.Old -> W.string w "OLD"
163 | Search.On s ->
164 W.string w "ON ";
165 atom w s
166 | Search.Or (k1, k2) ->
167 W.string w "OR ";
168 search_key w k1;
169 sp w;
170 search_key w k2
171 | Search.Seen -> W.string w "SEEN"
172 | Search.Since s ->
173 W.string w "SINCE ";
174 atom w s
175 | Search.Subject s ->
176 W.string w "SUBJECT ";
177 astring w s
178 | Search.Text s ->
179 W.string w "TEXT ";
180 astring w s
181 | Search.To s ->
182 W.string w "TO ";
183 astring w s
184 | Search.Unanswered -> W.string w "UNANSWERED"
185 | Search.Undeleted -> W.string w "UNDELETED"
186 | Search.Unflagged -> W.string w "UNFLAGGED"
187 | Search.Unkeyword s ->
188 W.string w "UNKEYWORD ";
189 atom w s
190 | Search.Unseen -> W.string w "UNSEEN"
191 | Search.Draft -> W.string w "DRAFT"
192 | Search.Undraft -> W.string w "UNDRAFT"
193 | Search.Header (field, value) ->
194 W.string w "HEADER ";
195 astring w field;
196 sp w;
197 astring w value
198 | Search.Larger n ->
199 W.string w "LARGER ";
200 number64 w n
201 | Search.Smaller n ->
202 W.string w "SMALLER ";
203 number64 w n
204 | Search.Uid set ->
205 W.string w "UID ";
206 sequence_set w set
207 | Search.Sequence_set set -> sequence_set w set
208 | Search.And keys ->
209 W.char w '(';
210 List.iteri
211 (fun i k ->
212 if i > 0 then sp w;
213 search_key w k)
214 keys;
215 W.char w ')'
216 | Search.Sentbefore s ->
217 W.string w "SENTBEFORE ";
218 atom w s
219 | Search.Senton s ->
220 W.string w "SENTON ";
221 atom w s
222 | Search.Sentsince s ->
223 W.string w "SENTSINCE ";
224 atom w s
225
226(** {1 Fetch Items} *)
227
228let write_partial w = function
229 | Some (offset, len) ->
230 W.char w '<';
231 number w offset;
232 W.char w '.';
233 number w len;
234 W.char w '>'
235 | None -> ()
236
237let fetch_item w = function
238 | Fetch.Envelope -> W.string w "ENVELOPE"
239 | Fetch.Flags -> W.string w "FLAGS"
240 | Fetch.Internaldate -> W.string w "INTERNALDATE"
241 | Fetch.Rfc822 -> W.string w "RFC822"
242 | Fetch.Rfc822_size -> W.string w "RFC822.SIZE"
243 | Fetch.Rfc822_header -> W.string w "RFC822.HEADER"
244 | Fetch.Rfc822_text -> W.string w "RFC822.TEXT"
245 | Fetch.Uid -> W.string w "UID"
246 | Fetch.Body -> W.string w "BODY"
247 | Fetch.Bodystructure -> W.string w "BODYSTRUCTURE"
248 | Fetch.Body_section (section, partial) ->
249 W.string w "BODY["; W.string w section; W.char w ']';
250 write_partial w partial
251 | Fetch.Body_peek (section, partial) ->
252 W.string w "BODY.PEEK["; W.string w section; W.char w ']';
253 write_partial w partial
254 | Fetch.Binary (section, partial) ->
255 W.string w "BINARY["; W.string w section; W.char w ']';
256 write_partial w partial
257 | Fetch.Binary_peek (section, partial) ->
258 W.string w "BINARY.PEEK["; W.string w section; W.char w ']';
259 write_partial w partial
260 | Fetch.Binary_size section ->
261 W.string w "BINARY.SIZE["; W.string w section; W.char w ']'
262 | Fetch.Modseq ->
263 (* RFC 7162 Section 3.1.5: MODSEQ fetch data item *)
264 W.string w "MODSEQ"
265
266let fetch_items w = function
267 | [ item ] -> fetch_item w item
268 | items ->
269 W.char w '(';
270 List.iteri
271 (fun i item ->
272 if i > 0 then sp w;
273 fetch_item w item)
274 items;
275 W.char w ')'
276
277(** {1 Status Items} *)
278
279let status_item w = function
280 | Status.Messages -> W.string w "MESSAGES"
281 | Status.Uidnext -> W.string w "UIDNEXT"
282 | Status.Uidvalidity -> W.string w "UIDVALIDITY"
283 | Status.Unseen -> W.string w "UNSEEN"
284 | Status.Deleted -> W.string w "DELETED"
285 | Status.Size -> W.string w "SIZE"
286 | Status.Highestmodseq -> W.string w "HIGHESTMODSEQ" (* RFC 7162 CONDSTORE *)
287
288let status_items w items =
289 W.char w '(';
290 List.iteri
291 (fun i item ->
292 if i > 0 then sp w;
293 status_item w item)
294 items;
295 W.char w ')'
296
297(** {1 Store Actions} *)
298
299let store_action w = function
300 | Store.Set -> W.string w "FLAGS"
301 | Store.Add -> W.string w "+FLAGS"
302 | Store.Remove -> W.string w "-FLAGS"
303
304(** {1 Sort Criteria} *)
305
306let sort_key w = function
307 | Sort.Arrival -> W.string w "ARRIVAL"
308 | Sort.Cc -> W.string w "CC"
309 | Sort.Date -> W.string w "DATE"
310 | Sort.From -> W.string w "FROM"
311 | Sort.Size -> W.string w "SIZE"
312 | Sort.Subject -> W.string w "SUBJECT"
313 | Sort.To -> W.string w "TO"
314
315let sort_criterion w c =
316 if c.Sort.reverse then W.string w "REVERSE ";
317 sort_key w c.Sort.key
318
319let sort_criteria w criteria =
320 W.char w '(';
321 List.iteri
322 (fun i c ->
323 if i > 0 then sp w;
324 sort_criterion w c)
325 criteria;
326 W.char w ')'
327
328(** {1 Thread Algorithm} *)
329
330let thread_algorithm w = function
331 | Thread.Orderedsubject -> W.string w "ORDEREDSUBJECT"
332 | Thread.References -> W.string w "REFERENCES"
333 | Thread.Extension s -> W.string w (String.uppercase_ascii s)
334
335(** {1 ID Parameters} *)
336
337let id_params w = function
338 | None -> W.string w "NIL"
339 | Some pairs ->
340 W.char w '(';
341 List.iteri
342 (fun i (k, v) ->
343 if i > 0 then sp w;
344 quoted_string w k;
345 sp w;
346 quoted_string w v)
347 pairs;
348 W.char w ')'
349
350(** {1 Commands} *)
351
352let write_search w charset criteria return_opts =
353 W.string w "SEARCH";
354 Option.iter (fun opts -> sp w; search_return_opts w opts) return_opts;
355 Option.iter (fun cs -> W.string w " CHARSET "; astring w cs) charset;
356 sp w;
357 search_key w criteria
358
359let write_sort w charset criteria search =
360 W.string w "SORT ";
361 sort_criteria w criteria;
362 sp w;
363 astring w charset;
364 sp w;
365 search_key w search
366
367let write_thread w algorithm charset search =
368 W.string w "THREAD ";
369 thread_algorithm w algorithm;
370 sp w;
371 astring w charset;
372 sp w;
373 search_key w search
374
375let command_body w = function
376 | Command.Capability -> W.string w "CAPABILITY"
377 | Command.Noop -> W.string w "NOOP"
378 | Command.Logout -> W.string w "LOGOUT"
379 | Command.Starttls -> W.string w "STARTTLS"
380 | Command.Login { username; password } ->
381 W.string w "LOGIN ";
382 astring w username;
383 sp w;
384 astring w password
385 | Command.Authenticate { mechanism; initial_response } ->
386 W.string w "AUTHENTICATE ";
387 atom w mechanism;
388 Option.iter (fun r -> sp w; W.string w r) initial_response
389 | Command.Enable caps ->
390 W.string w "ENABLE";
391 List.iter (fun c -> sp w; atom w c) caps
392 | Command.Select mailbox ->
393 W.string w "SELECT ";
394 astring w mailbox
395 | Command.Examine mailbox ->
396 W.string w "EXAMINE ";
397 astring w mailbox
398 | Command.Create mailbox ->
399 W.string w "CREATE ";
400 astring w mailbox
401 | Command.Delete mailbox ->
402 W.string w "DELETE ";
403 astring w mailbox
404 | Command.Rename { old_name; new_name } ->
405 W.string w "RENAME ";
406 astring w old_name;
407 sp w;
408 astring w new_name
409 | Command.Subscribe mailbox ->
410 W.string w "SUBSCRIBE ";
411 astring w mailbox
412 | Command.Unsubscribe mailbox ->
413 W.string w "UNSUBSCRIBE ";
414 astring w mailbox
415 | Command.List { reference; pattern } ->
416 W.string w "LIST ";
417 astring w reference;
418 sp w;
419 astring w pattern
420 | Command.Namespace -> W.string w "NAMESPACE"
421 | Command.Status { mailbox; items } ->
422 W.string w "STATUS ";
423 astring w mailbox;
424 sp w;
425 status_items w items
426 | Command.Append { mailbox; flags; date; message } ->
427 W.string w "APPEND ";
428 astring w mailbox;
429 (match flags with
430 | [] -> ()
431 | flags -> sp w; flag_list w flags);
432 Option.iter (fun d -> sp w; quoted_string w d) date;
433 sp w;
434 (* Use LITERAL+ to avoid synchronization issues *)
435 literal_plus w message
436 | Command.Idle -> W.string w "IDLE"
437 | Command.Close -> W.string w "CLOSE"
438 | Command.Unselect -> W.string w "UNSELECT"
439 | Command.Expunge -> W.string w "EXPUNGE"
440 | Command.Search { charset; criteria; return_opts } ->
441 write_search w charset criteria return_opts
442 | Command.Sort { charset; criteria; search } ->
443 write_sort w charset criteria search
444 | Command.Thread { algorithm; charset; search } ->
445 write_thread w algorithm charset search
446 | Command.Fetch { sequence; items; changedsince } ->
447 W.string w "FETCH ";
448 sequence_set w sequence;
449 sp w;
450 fetch_items w items;
451 Option.iter (fun modseq ->
452 W.string w " (CHANGEDSINCE ";
453 number64 w modseq;
454 W.char w ')') changedsince
455 | Command.Store { sequence; silent; action; flags; unchangedsince } ->
456 W.string w "STORE ";
457 sequence_set w sequence;
458 sp w;
459 (match unchangedsince with
460 | Some modseq ->
461 W.string w "(UNCHANGEDSINCE ";
462 number64 w modseq;
463 W.string w ") "
464 | None -> ());
465 store_action w action;
466 if silent then W.string w ".SILENT";
467 sp w;
468 flag_list w flags
469 | Command.Copy { sequence; mailbox } ->
470 W.string w "COPY ";
471 sequence_set w sequence;
472 sp w;
473 astring w mailbox
474 | Command.Move { sequence; mailbox } ->
475 W.string w "MOVE ";
476 sequence_set w sequence;
477 sp w;
478 astring w mailbox
479 | Command.Uid cmd -> (
480 W.string w "UID ";
481 match cmd with
482 | Command.Uid_fetch { sequence; items; changedsince } ->
483 W.string w "FETCH ";
484 sequence_set w sequence;
485 sp w;
486 fetch_items w items;
487 Option.iter (fun modseq ->
488 W.string w " (CHANGEDSINCE ";
489 number64 w modseq;
490 W.char w ')') changedsince
491 | Command.Uid_store { sequence; silent; action; flags; unchangedsince } ->
492 W.string w "STORE ";
493 sequence_set w sequence;
494 sp w;
495 (match unchangedsince with
496 | Some modseq ->
497 W.string w "(UNCHANGEDSINCE ";
498 number64 w modseq;
499 W.string w ") "
500 | None -> ());
501 store_action w action;
502 if silent then W.string w ".SILENT";
503 sp w;
504 flag_list w flags
505 | Command.Uid_copy { sequence; mailbox } ->
506 W.string w "COPY ";
507 sequence_set w sequence;
508 sp w;
509 astring w mailbox
510 | Command.Uid_move { sequence; mailbox } ->
511 W.string w "MOVE ";
512 sequence_set w sequence;
513 sp w;
514 astring w mailbox
515 | Command.Uid_search { charset; criteria; return_opts } ->
516 write_search w charset criteria return_opts
517 | Command.Uid_sort { charset; criteria; search } ->
518 write_sort w charset criteria search
519 | Command.Uid_thread { algorithm; charset; search } ->
520 write_thread w algorithm charset search
521 | Command.Uid_expunge set ->
522 W.string w "EXPUNGE ";
523 sequence_set w set)
524 | Command.Id params ->
525 W.string w "ID ";
526 id_params w params
527
528let command w ~tag cmd =
529 atom w tag;
530 sp w;
531 command_body w cmd;
532 crlf w
533
534let idle_done w =
535 W.string w "DONE";
536 crlf w
537
538let authenticate_response w data =
539 W.string w data;
540 crlf w