anil.recoil.org
IMAP in OCaml
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6(** IMAP4rev2 Server Entry Point
7
8 Implements {{:https://datatracker.ietf.org/doc/html/rfc9051}RFC 9051} IMAP4rev2 server.
9
10 Default ports:
11 - 143: Cleartext (STARTTLS available)
12 - 993: Implicit TLS per {{:https://datatracker.ietf.org/doc/html/rfc8314}RFC 8314} *)
13
14open Cmdliner
15
16(* Storage backend type *)
17type storage_backend =
18 | Memory
19 | Maildir of string option (* None = use ~/Maildir, Some path = use shared base *)
20
21(* Load TLS configuration from certificate and key files *)
22let load_tls_config ~cert_file ~key_file =
23 let cert_pem = In_channel.with_open_bin cert_file In_channel.input_all in
24 let key_pem = In_channel.with_open_bin key_file In_channel.input_all in
25 let certs = X509.Certificate.decode_pem_multiple cert_pem in
26 let key = X509.Private_key.decode_pem key_pem in
27 match certs, key with
28 | Ok certs, Ok key ->
29 let cert = `Single (certs, key) in
30 (match Tls.Config.server ~certificates:cert () with
31 | Ok config -> Some config
32 | Error _ -> None)
33 | _ -> None
34
35(* Parse IP address *)
36let parse_ipaddr host =
37 match host with
38 | "127.0.0.1" | "localhost" -> Eio.Net.Ipaddr.V4.loopback
39 | "0.0.0.0" -> Eio.Net.Ipaddr.V4.any
40 | _ ->
41 match String.split_on_char '.' host with
42 | [a; b; c; d] ->
43 let bytes = Bytes.create 4 in
44 Bytes.set bytes 0 (Char.chr (int_of_string a));
45 Bytes.set bytes 1 (Char.chr (int_of_string b));
46 Bytes.set bytes 2 (Char.chr (int_of_string c));
47 Bytes.set bytes 3 (Char.chr (int_of_string d));
48 Eio.Net.Ipaddr.of_raw (Bytes.to_string bytes)
49 | _ -> Eio.Net.Ipaddr.V4.loopback
50
51(* Run the server with memory storage - single process mode *)
52let run_with_memory_single ~port ~host ~tls_config ~implicit_tls =
53 let module Server = Imapd.Server.Make(Imapd.Storage.Memory_storage)(Imapd.Auth.Pam_auth) in
54 Eio_main.run @@ fun env ->
55 let net = Eio.Stdenv.net env in
56 let storage = Imapd.Storage.Memory_storage.create () in
57 let auth = Imapd.Auth.Pam_auth.create ~service_name:"imapd" in
58
59 (* Add test user for development *)
60 Imapd.Storage.Memory_storage.add_test_user storage ~username:"test";
61
62 let config = {
63 Imapd.Server.default_config with
64 hostname = host;
65 tls_config;
66 } in
67 let server = Server.create ~config ~storage ~auth in
68
69 let tls_mode = if implicit_tls then " (implicit TLS)" else if tls_config <> None then " (STARTTLS available)" else "" in
70 Eio.traceln "IMAP server starting on %s:%d (memory storage, single-process)%s" host port tls_mode;
71
72 Eio.Switch.run @@ fun sw ->
73 let ipaddr = parse_ipaddr host in
74 let addr = `Tcp (ipaddr, port) in
75 if implicit_tls then
76 match tls_config with
77 | Some tls -> Server.run_tls server ~sw ~net ~addr ~tls_config:tls ()
78 | None -> failwith "TLS config required for implicit TLS"
79 else
80 Server.run server ~sw ~net ~addr ()
81
82(* Run the server with Maildir storage - single process mode *)
83let run_with_maildir_single ~port ~host ~tls_config ~maildir_path ~implicit_tls =
84 let module Server = Imapd.Server.Make(Imapd.Storage.Maildir_storage)(Imapd.Auth.Pam_auth) in
85 Eio_main.run @@ fun env ->
86 let net = Eio.Stdenv.net env in
87 let storage = Imapd.Storage.Maildir_storage.create_with_path ~base_path:maildir_path in
88 let auth = Imapd.Auth.Pam_auth.create ~service_name:"imapd" in
89
90 let config = {
91 Imapd.Server.default_config with
92 hostname = host;
93 tls_config;
94 } in
95 let server = Server.create ~config ~storage ~auth in
96
97 let tls_mode = if implicit_tls then " (implicit TLS)" else if tls_config <> None then " (STARTTLS available)" else "" in
98 Eio.traceln "IMAP server starting on %s:%d (maildir: %s, single-process)%s" host port maildir_path tls_mode;
99
100 Eio.Switch.run @@ fun sw ->
101 let ipaddr = parse_ipaddr host in
102 let addr = `Tcp (ipaddr, port) in
103 if implicit_tls then
104 match tls_config with
105 | Some tls -> Server.run_tls server ~sw ~net ~addr ~tls_config:tls ()
106 | None -> failwith "TLS config required for implicit TLS"
107 else
108 Server.run server ~sw ~net ~addr ()
109
110(* Run the server with Maildir storage - forked mode with per-user privileges *)
111let run_with_maildir_forked ~port ~host ~tls_config ~maildir_path =
112 let module Server = Imapd.Server.Make(Imapd.Storage.Maildir_storage)(Imapd.Auth.Pam_auth) in
113 let storage = match maildir_path with
114 | Some path -> Imapd.Storage.Maildir_storage.create_with_path ~base_path:path
115 | None -> Imapd.Storage.Maildir_storage.create_home_directory ()
116 in
117 let auth = Imapd.Auth.Pam_auth.create ~service_name:"imapd" in
118
119 let config = {
120 Imapd.Server.default_config with
121 hostname = host;
122 tls_config;
123 } in
124 let server = Server.create ~config ~storage ~auth in
125
126 let storage_desc = match maildir_path with
127 | Some path -> Printf.sprintf "maildir: %s" path
128 | None -> "~/Maildir"
129 in
130 let tls_mode = if tls_config <> None then " (implicit TLS)" else "" in
131 Printf.eprintf "+IMAP server starting on %s:%d (%s, fork-per-connection)%s\n%!" host port storage_desc tls_mode;
132
133 (* run_forked uses its own accept loop, not EIO's *)
134 Eio_main.run @@ fun _env ->
135 Eio.Switch.run @@ fun sw ->
136 let ipaddr = parse_ipaddr host in
137 let addr = `Tcp (ipaddr, port) in
138 let net = Eio.Stdenv.net _env in
139 Server.run_forked server ~sw ~net ~addr ~tls_config
140
141(* Main entry point *)
142let run port host cert_file key_file backend maildir_path implicit_tls forked =
143 (* Initialize cryptographic RNG for TLS *)
144 Mirage_crypto_rng_unix.use_default ();
145
146 (* Forked mode requires implicit TLS (STARTTLS not supported) *)
147 if forked && not implicit_tls && (cert_file <> None || key_file <> None) then begin
148 Printf.eprintf "Warning: STARTTLS not supported in forked mode. Use --tls for implicit TLS.\n%!";
149 end;
150
151 (* Check that cert and key are provided if implicit TLS is enabled *)
152 if implicit_tls && (cert_file = None || key_file = None) then begin
153 Printf.eprintf "Error: --cert and --key are required when using --tls\n";
154 exit 1
155 end;
156
157 (* Load TLS config if cert and key provided *)
158 let tls_config =
159 match cert_file, key_file with
160 | Some cert, Some key -> load_tls_config ~cert_file:cert ~key_file:key
161 | _ -> None
162 in
163
164 (* Verify TLS config loaded successfully if implicit TLS is enabled *)
165 if implicit_tls && tls_config = None then begin
166 Printf.eprintf "Error: Failed to load TLS certificate or key\n";
167 exit 1
168 end;
169
170 (* Forked mode only works with Maildir *)
171 if forked && backend = "memory" then begin
172 Printf.eprintf "Error: --fork requires --storage maildir (memory storage not supported)\n";
173 exit 1
174 end;
175
176 (* Determine storage backend *)
177 let storage_backend = match backend with
178 | "memory" -> Memory
179 | "maildir" ->
180 (* In forked mode with no explicit path, use ~/Maildir (home directory) *)
181 (* In single-process mode, require explicit path or use /var/mail *)
182 let path = match maildir_path, forked with
183 | Some p, _ -> Some p
184 | None, true -> None (* Use ~/Maildir in forked mode *)
185 | None, false -> Some "/var/mail" (* Default for non-forked *)
186 in
187 Maildir path
188 | _ ->
189 Printf.eprintf "Unknown storage backend: %s\n" backend;
190 exit 1
191 in
192
193 match storage_backend, forked with
194 | Memory, false -> run_with_memory_single ~port ~host ~tls_config ~implicit_tls
195 | Maildir (Some path), false -> run_with_maildir_single ~port ~host ~tls_config ~maildir_path:path ~implicit_tls
196 | Maildir path, true -> run_with_maildir_forked ~port ~host ~tls_config ~maildir_path:path
197 | Maildir None, false -> failwith "unreachable"
198 | Memory, true -> failwith "unreachable"
199
200(* Command-line arguments *)
201let port =
202 let doc = "Port to listen on (default: 143 for cleartext, 993 for TLS)." in
203 Arg.(value & opt int 143 & info ["p"; "port"] ~docv:"PORT" ~doc)
204
205let host =
206 let doc = "Host address to bind to." in
207 Arg.(value & opt string "127.0.0.1" & info ["h"; "host"] ~docv:"HOST" ~doc)
208
209let cert_file =
210 let doc = "TLS certificate file (PEM format). Required for --tls." in
211 Arg.(value & opt (some string) None & info ["cert"] ~docv:"FILE" ~doc)
212
213let key_file =
214 let doc = "TLS private key file (PEM format). Required for --tls." in
215 Arg.(value & opt (some string) None & info ["key"] ~docv:"FILE" ~doc)
216
217let backend =
218 let doc = "Storage backend to use (memory or maildir)." in
219 Arg.(value & opt string "memory" & info ["s"; "storage"] ~docv:"BACKEND" ~doc)
220
221let maildir_path =
222 let doc = "Base path for Maildir storage. In single-process mode, defaults to /var/mail. \
223 In fork mode (--fork), defaults to using each user's home directory (~/Maildir)." in
224 Arg.(value & opt (some string) None & info ["maildir-path"] ~docv:"PATH" ~doc)
225
226let implicit_tls =
227 let doc = "Enable implicit TLS (RFC 8314). TLS starts immediately on connection. Requires --cert and --key." in
228 Arg.(value & flag & info ["tls"] ~doc)
229
230let forked =
231 let doc = "Fork a new process for each connection and drop privileges to the \
232 authenticated user after login. Provides strong per-user isolation. \
233 Requires running as root. Only works with Maildir storage." in
234 Arg.(value & flag & info ["fork"] ~doc)
235
236let cmd =
237 let doc = "IMAP4rev2 server" in
238 let man = [
239 `S Manpage.s_description;
240 `P "An IMAP4rev2 server (RFC 9051) implemented in OCaml.";
241 `S Manpage.s_options;
242 `S "OPERATING MODES";
243 `P "$(b,Single-process) (default) - All connections handled in one process. \
244 Efficient but all sessions share the same privileges.";
245 `P "$(b,Fork-per-connection) (--fork) - Each connection forks a child process. \
246 After authentication, the child drops privileges to the authenticated user \
247 via setuid. Provides strong isolation between users. Requires running as root.";
248 `S "TLS MODES";
249 `P "$(b,STARTTLS) (default) - Start cleartext, upgrade to TLS via STARTTLS command. \
250 Provide --cert and --key to enable STARTTLS capability. Not supported with --fork.";
251 `P "$(b,Implicit TLS) (--tls) - TLS starts immediately on connection per RFC 8314. \
252 Typically used on port 993. Recommended for --fork mode.";
253 `S "STORAGE BACKENDS";
254 `P "$(b,memory) - In-memory storage for development and testing.";
255 `P "$(b,maildir) - Maildir-based storage for production use. Required for --fork mode.";
256 `S Manpage.s_examples;
257 `P "Development server with memory storage:";
258 `Pre " $(tname) -s memory -p 10143";
259 `P "Production server with fork-per-connection isolation (recommended):";
260 `Pre " sudo $(tname) --fork -s maildir --tls --cert server.crt --key server.key -p 993";
261 `Noblank;
262 `P "Uses ~/Maildir for each user (traditional Unix location).";
263 `P "Production server with shared mail directory:";
264 `Pre " sudo $(tname) --fork -s maildir --maildir-path /var/mail --tls --cert server.crt --key server.key -p 993";
265 `P "Single-process server with STARTTLS:";
266 `Pre " $(tname) -s maildir --maildir-path /var/mail --cert server.crt --key server.key -p 143";
267 `S Manpage.s_bugs;
268 `P "Report bugs at https://github.com/mtelvers/imapd/issues";
269 ] in
270 let info = Cmd.info "imapd" ~version:"0.1.0" ~doc ~man in
271 Cmd.v info Term.(const run $ port $ host $ cert_file $ key_file $ backend $ maildir_path $ implicit_tls $ forked)
272
273let () = exit (Cmd.eval cmd)