forked from
anil.recoil.org/ocaml-imap
IMAP in OCaml
imap: fix writer lifecycle, add logging, and parse wildcard flags
- Fix "cannot write to closed writer" by storing TLS flow instead of
Buf_write.t, creating fresh writer for each command
- Add Logs library integration with imap.client source for debugging
- Add --plain flag to use AUTHENTICATE PLAIN instead of LOGIN
- Add Command.pp for safe logging (passwords redacted)
- Fix parsing of \* wildcard flag in PERMANENTFLAGS response
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+169
-50
+1
-1
bin/dune
+1
-1
bin/dune
+36
-7
bin/imap_client.ml
+36
-7
bin/imap_client.ml
···
99
99
status email.uid padded_date padded_from subject_display
100
100
101
101
(** Main IMAP client function *)
102
-
let run_client ~host ~port ~username ~password ~limit ~unread_only =
102
+
let run_client ~host ~port ~username ~password ~limit ~unread_only ~use_plain =
103
103
Mirage_crypto_rng_unix.use_default ();
104
104
105
105
Eio_main.run @@ fun env ->
···
116
116
exit 1
117
117
in
118
118
119
+
let caps = Imap.Client.capabilities client in
119
120
Printf.printf "Connected. Server capabilities: %s\n%!"
120
-
(String.concat ", " (Imap.Client.capabilities client));
121
+
(String.concat ", " caps);
122
+
123
+
(* Determine authentication method *)
124
+
let login_disabled = Imap.Client.has_capability client "LOGINDISABLED" in
125
+
let should_use_plain = use_plain || login_disabled in
126
+
127
+
if login_disabled && not use_plain then
128
+
Printf.printf "Note: Server has LOGINDISABLED, using AUTH PLAIN\n%!";
121
129
122
130
(* Login *)
123
-
Printf.printf "Logging in as %s...\n%!" username;
131
+
let auth_method = if should_use_plain then "AUTH PLAIN" else "LOGIN" in
132
+
Printf.printf "Logging in as %s (using %s)...\n%!" username auth_method;
124
133
(try
125
-
Imap.Client.login client ~username ~password
134
+
if should_use_plain then
135
+
Imap.Client.authenticate_plain client ~username ~password
136
+
else
137
+
Imap.Client.login client ~username ~password
126
138
with exn ->
127
139
Printf.eprintf "Login failed: %s\n" (Printexc.to_string exn);
128
140
Imap.Client.disconnect client;
···
203
215
Printf.eprintf "Usage: IMAP_PASSWORD=xxx %s [options]\n" Sys.argv.(0);
204
216
exit 1
205
217
218
+
(** Logging setup *)
219
+
let setup_log style_renderer level =
220
+
Fmt_tty.setup_std_outputs ?style_renderer ();
221
+
Logs.set_level level;
222
+
Logs.set_reporter (Logs_fmt.reporter ())
223
+
206
224
(** Command line interface *)
207
225
let host =
208
226
let doc = "IMAP server hostname" in
···
224
242
let doc = "Show only unread messages" in
225
243
Arg.(value & flag & info ["unread"] ~doc)
226
244
245
+
let use_plain =
246
+
let doc = "Use AUTHENTICATE PLAIN instead of LOGIN command" in
247
+
Arg.(value & flag & info ["plain"] ~doc)
248
+
227
249
let cmd =
228
250
let doc = "IMAP client - list recent emails" in
229
251
let man = [
···
240
262
`Pre " IMAP_PASSWORD=xxx $(tname) --host mail.example.com --user me --unread";
241
263
`P "Fetch the last 50 messages:";
242
264
`Pre " IMAP_PASSWORD=xxx $(tname) --host mail.example.com --user me --limit 50";
265
+
`P "Use AUTH PLAIN for authentication:";
266
+
`Pre " IMAP_PASSWORD=xxx $(tname) --host mail.example.com --user me --plain";
267
+
`P "Enable verbose logging:";
268
+
`Pre " IMAP_PASSWORD=xxx $(tname) --host mail.example.com --user me -v";
269
+
`P "Enable debug logging:";
270
+
`Pre " IMAP_PASSWORD=xxx $(tname) --host mail.example.com --user me -v -v";
243
271
] in
244
272
let info = Cmd.info "imap-client" ~version:"0.1.0" ~doc ~man in
245
-
Cmd.v info Term.(const (fun host port username limit unread_only ->
273
+
Cmd.v info Term.(const (fun style_renderer level host port username limit unread_only use_plain ->
274
+
setup_log style_renderer level;
246
275
let password = get_password () in
247
-
run_client ~host ~port ~username ~password ~limit ~unread_only
248
-
) $ host $ port $ username $ limit $ unread_only)
276
+
run_client ~host ~port ~username ~password ~limit ~unread_only ~use_plain
277
+
) $ Fmt_cli.style_renderer () $ Logs_cli.level () $ host $ port $ username $ limit $ unread_only $ use_plain)
249
278
250
279
let () = exit (Cmd.eval cmd)
+68
-34
lib/imap/client.ml
+68
-34
lib/imap/client.ml
···
7
7
8
8
High-level IMAP client implementing RFC 9051 IMAP4rev2. *)
9
9
10
+
let src = Logs.Src.create "imap.client" ~doc:"IMAP client"
11
+
module Log = (val Logs.src_log src : Logs.LOG)
12
+
10
13
(** {1 Types} *)
11
14
12
15
type connection_state =
···
60
63
61
64
type t = {
62
65
reader : Eio.Buf_read.t;
63
-
writer : Eio.Buf_write.t;
66
+
flow : Eio.Flow.two_way_ty Eio.Resource.t;
64
67
close_fn : unit -> unit;
65
68
mutable state : connection_state;
66
69
mutable capabilities : string list;
···
87
90
88
91
let send_command t cmd =
89
92
let tag = next_tag t in
90
-
Write.command t.writer ~tag cmd;
93
+
Log.debug (fun f -> f "C: %s %a" tag Command.pp cmd);
94
+
Eio.Buf_write.with_flow t.flow (fun writer ->
95
+
Write.command writer ~tag cmd);
91
96
tag
92
97
93
-
let receive_responses t tag = Read.responses_until_tagged t.reader tag
98
+
let receive_responses t tag =
99
+
let untagged, final = Read.responses_until_tagged t.reader tag in
100
+
List.iter (fun r -> Log.debug (fun f -> f "S: %a" Response.pp r)) untagged;
101
+
Log.debug (fun f -> f "S: %a" Response.pp final);
102
+
(untagged, final)
94
103
95
104
let check_ok tag _responses final =
96
105
match final with
···
124
133
(** {1 Connection Management} *)
125
134
126
135
let connect ~sw ~env ~host ?(port = 993) ?tls_config () =
136
+
Log.info (fun f -> f "Connecting to %s:%d" host port);
127
137
let net = Eio.Stdenv.net env in
128
138
let addr =
129
139
match Eio.Net.getaddrinfo_stream net host ~service:(string_of_int port) with
130
140
| [] -> Error.raise (Connection_error { reason = "Could not resolve host" })
131
141
| addr :: _ -> addr
132
142
in
133
-
let flow = Eio.Net.connect ~sw net addr in
143
+
Log.debug (fun f -> f "Resolved address, establishing TCP connection");
144
+
let tcp_flow = Eio.Net.connect ~sw net addr in
134
145
let tls_config =
135
146
match tls_config with
136
147
| Some c -> c
···
139
150
| Ok c -> c
140
151
| Error (`Msg msg) -> Error.raise (Connection_error { reason = msg })
141
152
in
142
-
let tls_flow = Tls_eio.client_of_flow tls_config flow in
153
+
Log.debug (fun f -> f "TCP connected, starting TLS handshake");
154
+
let tls_flow = Tls_eio.client_of_flow tls_config tcp_flow in
155
+
Log.debug (fun f -> f "TLS handshake complete");
143
156
let reader = Eio.Buf_read.of_flow ~max_size:(16 * 1024 * 1024) tls_flow in
144
157
let close_fn () =
145
158
try Eio.Flow.close tls_flow with _ -> ()
146
159
in
147
160
let t =
148
-
ref
149
-
{
150
-
reader;
151
-
writer = Obj.magic ();
152
-
close_fn;
153
-
state = Not_authenticated;
154
-
capabilities = [];
155
-
tag_counter = 0;
156
-
sw;
157
-
}
161
+
{
162
+
reader;
163
+
flow = (tls_flow :> Eio.Flow.two_way_ty Eio.Resource.t);
164
+
close_fn;
165
+
state = Not_authenticated;
166
+
capabilities = [];
167
+
tag_counter = 0;
168
+
sw;
169
+
}
158
170
in
159
-
Eio.Buf_write.with_flow tls_flow (fun writer ->
160
-
t := { !t with writer };
161
-
let greeting = Read.response reader in
162
-
(match greeting with
163
-
| Response.Ok { code; _ } -> (
164
-
match code with
165
-
| Some (Code.Capability caps) -> (!t).capabilities <- caps
166
-
| _ -> ())
167
-
| Response.Preauth { code; _ } ->
168
-
(match code with
169
-
| Some (Code.Capability caps) -> (!t).capabilities <- caps
170
-
| _ -> ());
171
-
(!t).state <- Authenticated { username = "" }
172
-
| _ -> Error.raise (Protocol_error { code = None; text = "Bad greeting" }));
173
-
!t)
171
+
(* Read server greeting - no write needed *)
172
+
Log.debug (fun f -> f "Waiting for server greeting");
173
+
let greeting = Read.response reader in
174
+
Log.debug (fun f -> f "S: %a" Response.pp greeting);
175
+
(match greeting with
176
+
| Response.Ok { code; _ } -> (
177
+
match code with
178
+
| Some (Code.Capability caps) ->
179
+
Log.info (fun f -> f "Server capabilities: %s" (String.concat ", " caps));
180
+
t.capabilities <- caps
181
+
| _ -> ())
182
+
| Response.Preauth { code; _ } ->
183
+
Log.info (fun f -> f "Server pre-authenticated");
184
+
(match code with
185
+
| Some (Code.Capability caps) -> t.capabilities <- caps
186
+
| _ -> ());
187
+
t.state <- Authenticated { username = "" }
188
+
| _ -> Error.raise (Protocol_error { code = None; text = "Bad greeting" }));
189
+
t
174
190
175
191
let disconnect t =
176
192
t.state <- Logout;
···
221
237
Error.raise (Protocol_error { code = None; text = "STARTTLS not implemented for IMAPS connections" })
222
238
223
239
let login t ~username ~password =
240
+
Log.info (fun f -> f "Logging in as %s using LOGIN command" username);
224
241
(match t.state with
225
242
| Not_authenticated -> ()
226
243
| _ -> Error.raise (State_error { expected = "Not authenticated"; actual = "Already authenticated" }));
227
244
let tag = send_command t (Command.Login { username; password }) in
228
245
let untagged, final = receive_responses t tag in
229
246
check_ok tag [] final;
247
+
Log.info (fun f -> f "Login successful for %s" username);
230
248
t.state <- Authenticated { username };
231
249
List.iter
232
250
(function Response.Capability caps -> t.capabilities <- caps | _ -> ())
233
251
untagged
234
252
235
253
let authenticate t ~mechanism ?initial_response ~respond () =
254
+
Log.info (fun f -> f "Authenticating using %s mechanism" mechanism);
236
255
(match t.state with
237
256
| Not_authenticated -> ()
238
257
| _ -> Error.raise (State_error { expected = "Not authenticated"; actual = "Already authenticated" }));
239
258
let tag = send_command t (Command.Authenticate { mechanism; initial_response }) in
240
259
let rec auth_loop () =
241
260
let resp = Read.response t.reader in
261
+
Log.debug (fun f -> f "S: %a" Response.pp resp);
242
262
match resp with
243
263
| Response.Continuation (Some challenge) ->
264
+
Log.debug (fun f -> f "Received challenge, sending response");
244
265
let response = respond challenge in
245
-
Write.authenticate_response t.writer response;
266
+
Eio.Buf_write.with_flow t.flow (fun writer ->
267
+
Write.authenticate_response writer response);
246
268
auth_loop ()
247
269
| Response.Continuation None ->
270
+
Log.debug (fun f -> f "Received empty continuation, sending response");
248
271
let response = respond "" in
249
-
Write.authenticate_response t.writer response;
272
+
Eio.Buf_write.with_flow t.flow (fun writer ->
273
+
Write.authenticate_response writer response);
250
274
auth_loop ()
251
275
| Response.Ok { tag = Some t_tag; _ } when t_tag = tag ->
276
+
Log.info (fun f -> f "Authentication successful using %s" mechanism);
252
277
()
253
278
| Response.No { text; _ } ->
279
+
Log.err (fun f -> f "Authentication failed: %s" text);
254
280
Error.raise (Authentication_error { mechanism; reason = text })
255
281
| Response.Bad { text; _ } ->
282
+
Log.err (fun f -> f "Authentication error: %s" text);
256
283
Error.raise (Authentication_error { mechanism; reason = text })
257
284
| _ -> auth_loop ()
258
285
in
···
260
287
t.state <- Authenticated { username = "" }
261
288
262
289
let authenticate_plain t ~username ~password =
290
+
Log.info (fun f -> f "Logging in as %s using AUTHENTICATE PLAIN (SASL-IR)" username);
263
291
let ir = Printf.sprintf "\x00%s\x00%s" username password in
264
292
let encoded = Base64.encode_string ir in
265
293
authenticate t ~mechanism:"PLAIN" ~initial_response:encoded ~respond:(fun _ -> "") ();
···
269
297
270
298
let select_impl t mailbox readonly =
271
299
require_authenticated t;
300
+
Log.info (fun f -> f "%s mailbox %s" (if readonly then "Examining" else "Selecting") mailbox);
272
301
let cmd = if readonly then Command.Examine mailbox else Command.Select mailbox in
273
302
let tag = send_command t cmd in
274
303
let untagged, final = receive_responses t tag in
···
307
336
| _ -> ""
308
337
in
309
338
t.state <- Selected { username; mailbox; readonly = !info.readonly };
339
+
Log.info (fun f -> f "Mailbox %s: %d messages, uidnext=%ld, uidvalidity=%ld"
340
+
mailbox !info.exists !info.uidnext !info.uidvalidity);
310
341
!info
311
342
312
343
let select t mailbox = select_impl t mailbox false
···
584
615
| _ -> loop ()
585
616
in
586
617
(try loop () with _ -> ());
587
-
Write.idle_done t.writer;
618
+
Eio.Buf_write.with_flow t.flow (fun writer ->
619
+
Write.idle_done writer);
588
620
let _, _ = receive_responses t tag in
589
621
List.rev !events
590
622
591
-
let idle_done t = Write.idle_done t.writer
623
+
let idle_done t =
624
+
Eio.Buf_write.with_flow t.flow (fun writer ->
625
+
Write.idle_done writer)
592
626
593
627
(** {1 Extensions} *)
594
628
+46
lib/imap/command.ml
+46
lib/imap/command.ml
···
62
62
| Uid_expunge of Seq.t
63
63
64
64
type tagged = { tag : string; command : t }
65
+
66
+
(** Pretty-printer for commands (passwords redacted for security) *)
67
+
let rec pp ppf = function
68
+
| Capability -> Fmt.string ppf "CAPABILITY"
69
+
| Noop -> Fmt.string ppf "NOOP"
70
+
| Logout -> Fmt.string ppf "LOGOUT"
71
+
| Starttls -> Fmt.string ppf "STARTTLS"
72
+
| Login { username; _ } -> Fmt.pf ppf "LOGIN %s ***" username
73
+
| Authenticate { mechanism; initial_response } ->
74
+
Fmt.pf ppf "AUTHENTICATE %s%s" mechanism
75
+
(if Option.is_some initial_response then " <initial-response>" else "")
76
+
| Enable caps -> Fmt.pf ppf "ENABLE %s" (String.concat " " caps)
77
+
| Select mailbox -> Fmt.pf ppf "SELECT %s" mailbox
78
+
| Examine mailbox -> Fmt.pf ppf "EXAMINE %s" mailbox
79
+
| Create mailbox -> Fmt.pf ppf "CREATE %s" mailbox
80
+
| Delete mailbox -> Fmt.pf ppf "DELETE %s" mailbox
81
+
| Rename { old_name; new_name } -> Fmt.pf ppf "RENAME %s %s" old_name new_name
82
+
| Subscribe mailbox -> Fmt.pf ppf "SUBSCRIBE %s" mailbox
83
+
| Unsubscribe mailbox -> Fmt.pf ppf "UNSUBSCRIBE %s" mailbox
84
+
| List { reference; pattern } -> Fmt.pf ppf "LIST %S %S" reference pattern
85
+
| Namespace -> Fmt.string ppf "NAMESPACE"
86
+
| Status { mailbox; _ } -> Fmt.pf ppf "STATUS %s (...)" mailbox
87
+
| Append { mailbox; _ } -> Fmt.pf ppf "APPEND %s (...)" mailbox
88
+
| Idle -> Fmt.string ppf "IDLE"
89
+
| Close -> Fmt.string ppf "CLOSE"
90
+
| Unselect -> Fmt.string ppf "UNSELECT"
91
+
| Expunge -> Fmt.string ppf "EXPUNGE"
92
+
| Search _ -> Fmt.string ppf "SEARCH (...)"
93
+
| Fetch { sequence; _ } -> Fmt.pf ppf "FETCH %a (...)" Seq.pp sequence
94
+
| Store { sequence; action; _ } ->
95
+
let action_str = match action with Store.Set -> "FLAGS" | Store.Add -> "+FLAGS" | Store.Remove -> "-FLAGS" in
96
+
Fmt.pf ppf "STORE %a %s (...)" Seq.pp sequence action_str
97
+
| Copy { sequence; mailbox } -> Fmt.pf ppf "COPY %a %s" Seq.pp sequence mailbox
98
+
| Move { sequence; mailbox } -> Fmt.pf ppf "MOVE %a %s" Seq.pp sequence mailbox
99
+
| Uid cmd -> Fmt.pf ppf "UID %a" pp_uid cmd
100
+
| Id _ -> Fmt.string ppf "ID (...)"
101
+
102
+
and pp_uid ppf = function
103
+
| Uid_fetch { sequence; _ } -> Fmt.pf ppf "FETCH %a (...)" Seq.pp sequence
104
+
| Uid_store { sequence; action; _ } ->
105
+
let action_str = match action with Store.Set -> "FLAGS" | Store.Add -> "+FLAGS" | Store.Remove -> "-FLAGS" in
106
+
Fmt.pf ppf "STORE %a %s (...)" Seq.pp sequence action_str
107
+
| Uid_copy { sequence; mailbox } -> Fmt.pf ppf "COPY %a %s" Seq.pp sequence mailbox
108
+
| Uid_move { sequence; mailbox } -> Fmt.pf ppf "MOVE %a %s" Seq.pp sequence mailbox
109
+
| Uid_search _ -> Fmt.string ppf "SEARCH (...)"
110
+
| Uid_expunge seq -> Fmt.pf ppf "EXPUNGE %a" Seq.pp seq
+3
lib/imap/command.mli
+3
lib/imap/command.mli
+14
-8
lib/imap/read.ml
+14
-8
lib/imap/read.ml
···
110
110
111
111
let system_flag r =
112
112
R.char '\\' r;
113
-
let name = atom r in
114
-
match String.uppercase_ascii name with
115
-
| "SEEN" -> Flag.System Flag.Seen
116
-
| "ANSWERED" -> Flag.System Flag.Answered
117
-
| "FLAGGED" -> Flag.System Flag.Flagged
118
-
| "DELETED" -> Flag.System Flag.Deleted
119
-
| "DRAFT" -> Flag.System Flag.Draft
120
-
| _ -> Flag.Keyword ("\\" ^ name)
113
+
(* Handle \* (wildcard) flag - means server accepts client-defined keywords *)
114
+
match R.peek_char r with
115
+
| Some '*' ->
116
+
R.char '*' r;
117
+
Flag.Keyword "\\*"
118
+
| _ ->
119
+
let name = atom r in
120
+
match String.uppercase_ascii name with
121
+
| "SEEN" -> Flag.System Flag.Seen
122
+
| "ANSWERED" -> Flag.System Flag.Answered
123
+
| "FLAGGED" -> Flag.System Flag.Flagged
124
+
| "DELETED" -> Flag.System Flag.Deleted
125
+
| "DRAFT" -> Flag.System Flag.Draft
126
+
| _ -> Flag.Keyword ("\\" ^ name)
121
127
122
128
let flag r =
123
129
match R.peek_char r with