jon.recoil.org
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 Commands
7
8 Client-to-server commands as specified in RFC 9051. *)
9
10(** ESEARCH return options (RFC 4731) *)
11type search_return_opt =
12 | Return_min (** Return minimum matching sequence number/UID *)
13 | Return_max (** Return maximum matching sequence number/UID *)
14 | Return_all (** Return all matching sequence numbers/UIDs as a sequence set *)
15 | Return_count (** Return count of matching messages *)
16
17type t =
18 | Capability
19 | Noop
20 | Logout
21 | Starttls
22 | Login of { username : string; password : string }
23 | Authenticate of { mechanism : string; initial_response : string option }
24 | Enable of string list
25 | Select of Mailbox.t
26 | Examine of Mailbox.t
27 | Create of Mailbox.t
28 | Delete of Mailbox.t
29 | Rename of { old_name : Mailbox.t; new_name : Mailbox.t }
30 | Subscribe of Mailbox.t
31 | Unsubscribe of Mailbox.t
32 | List of { reference : string; pattern : string }
33 | Namespace
34 | Status of { mailbox : Mailbox.t; items : Status.item list }
35 | Append of {
36 mailbox : Mailbox.t;
37 flags : Flag.t list;
38 date : string option;
39 message : string;
40 }
41 | Idle
42 | Close
43 | Unselect
44 | Expunge
45 | Search of { charset : string option; criteria : Search.t; return_opts : search_return_opt list option }
46 | Sort of { charset : string; criteria : Sort.t; search : Search.t }
47 | Thread of { algorithm : Thread.algorithm; charset : string; search : Search.t }
48 | Fetch of { sequence : Seq.t; items : Fetch.request list; changedsince : int64 option }
49 | Store of {
50 sequence : Seq.t;
51 silent : bool;
52 action : Store.t;
53 flags : Flag.t list;
54 unchangedsince : int64 option;
55 }
56 | Copy of { sequence : Seq.t; mailbox : Mailbox.t }
57 | Move of { sequence : Seq.t; mailbox : Mailbox.t }
58 | Uid of uid_command
59 | Id of (string * string) list option
60
61and uid_command =
62 | Uid_fetch of { sequence : Seq.t; items : Fetch.request list; changedsince : int64 option }
63 | Uid_store of {
64 sequence : Seq.t;
65 silent : bool;
66 action : Store.t;
67 flags : Flag.t list;
68 unchangedsince : int64 option;
69 }
70 | Uid_copy of { sequence : Seq.t; mailbox : Mailbox.t }
71 | Uid_move of { sequence : Seq.t; mailbox : Mailbox.t }
72 | Uid_search of { charset : string option; criteria : Search.t; return_opts : search_return_opt list option }
73 | Uid_sort of { charset : string; criteria : Sort.t; search : Search.t }
74 | Uid_thread of { algorithm : Thread.algorithm; charset : string; search : Search.t }
75 | Uid_expunge of Seq.t
76
77type tagged = { tag : string; command : t }
78
79(** Pretty-printer for commands (passwords redacted for security) *)
80let rec pp ppf = function
81 | Capability -> Fmt.string ppf "CAPABILITY"
82 | Noop -> Fmt.string ppf "NOOP"
83 | Logout -> Fmt.string ppf "LOGOUT"
84 | Starttls -> Fmt.string ppf "STARTTLS"
85 | Login { username; _ } -> Fmt.pf ppf "LOGIN %s ***" username
86 | Authenticate { mechanism; initial_response } ->
87 Fmt.pf ppf "AUTHENTICATE %s%s" mechanism
88 (if Option.is_some initial_response then " <initial-response>" else "")
89 | Enable caps -> Fmt.pf ppf "ENABLE %s" (String.concat " " caps)
90 | Select mailbox -> Fmt.pf ppf "SELECT %s" mailbox
91 | Examine mailbox -> Fmt.pf ppf "EXAMINE %s" mailbox
92 | Create mailbox -> Fmt.pf ppf "CREATE %s" mailbox
93 | Delete mailbox -> Fmt.pf ppf "DELETE %s" mailbox
94 | Rename { old_name; new_name } -> Fmt.pf ppf "RENAME %s %s" old_name new_name
95 | Subscribe mailbox -> Fmt.pf ppf "SUBSCRIBE %s" mailbox
96 | Unsubscribe mailbox -> Fmt.pf ppf "UNSUBSCRIBE %s" mailbox
97 | List { reference; pattern } -> Fmt.pf ppf "LIST %S %S" reference pattern
98 | Namespace -> Fmt.string ppf "NAMESPACE"
99 | Status { mailbox; _ } -> Fmt.pf ppf "STATUS %s (...)" mailbox
100 | Append { mailbox; _ } -> Fmt.pf ppf "APPEND %s (...)" mailbox
101 | Idle -> Fmt.string ppf "IDLE"
102 | Close -> Fmt.string ppf "CLOSE"
103 | Unselect -> Fmt.string ppf "UNSELECT"
104 | Expunge -> Fmt.string ppf "EXPUNGE"
105 | Search _ -> Fmt.string ppf "SEARCH (...)"
106 | Sort _ -> Fmt.string ppf "SORT (...)"
107 | Thread _ -> Fmt.string ppf "THREAD (...)"
108 | Fetch { sequence; _ } -> Fmt.pf ppf "FETCH %a (...)" Seq.pp sequence
109 | Store { sequence; action; _ } ->
110 let action_str = match action with Store.Set -> "FLAGS" | Store.Add -> "+FLAGS" | Store.Remove -> "-FLAGS" in
111 Fmt.pf ppf "STORE %a %s (...)" Seq.pp sequence action_str
112 | Copy { sequence; mailbox } -> Fmt.pf ppf "COPY %a %s" Seq.pp sequence mailbox
113 | Move { sequence; mailbox } -> Fmt.pf ppf "MOVE %a %s" Seq.pp sequence mailbox
114 | Uid cmd -> Fmt.pf ppf "UID %a" pp_uid cmd
115 | Id _ -> Fmt.string ppf "ID (...)"
116
117and pp_uid ppf = function
118 | Uid_fetch { sequence; _ } -> Fmt.pf ppf "FETCH %a (...)" Seq.pp sequence
119 | Uid_store { sequence; action; _ } ->
120 let action_str = match action with Store.Set -> "FLAGS" | Store.Add -> "+FLAGS" | Store.Remove -> "-FLAGS" in
121 Fmt.pf ppf "STORE %a %s (...)" Seq.pp sequence action_str
122 | Uid_copy { sequence; mailbox } -> Fmt.pf ppf "COPY %a %s" Seq.pp sequence mailbox
123 | Uid_move { sequence; mailbox } -> Fmt.pf ppf "MOVE %a %s" Seq.pp sequence mailbox
124 | Uid_search _ -> Fmt.string ppf "SEARCH (...)"
125 | Uid_sort _ -> Fmt.string ppf "SORT (...)"
126 | Uid_thread _ -> Fmt.string ppf "THREAD (...)"
127 | Uid_expunge seq -> Fmt.pf ppf "EXPUNGE %a" Seq.pp seq