-
Notifications
You must be signed in to change notification settings - Fork 125
/
mailserve.ml
412 lines (358 loc) · 13.8 KB
/
mailserve.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(** implements http://www.rfcsearch.org/rfcview/RFC/821.html
@author Henri Binsztok *)
module String = Base.String
module List = Base.List
let (|>) = InfixOperator.(|>)
let sprintf = Printf.sprintf
(** communication type for statistics *)
let smtp = NetAddr.mk_protocol "SMTP"
type email = string
(** SMTP envelope *)
type envel = { mfrom : email
; mto : email list
; mdata : string
; mquit : bool
; datamode : bool
}
let resolve_UNIX name =
try
(Unix.gethostbyname name).Unix.h_addr_list.(0)
|> Unix.string_of_inet_addr
|> String.slice '.'
|> List.map int_of_string
|> function [a;b;c;d] -> Some (a,b,c,d) | _ -> None
with Unix.Unix_error _ -> None
let resolve_additional r n =
let rec aux = function
| hd :: tl ->
if hd.Dig.domain = n then
match hd.Dig.dst with
| Dig.Ip i -> Some i
| _ -> aux tl
else aux tl
| _ -> resolve_UNIX (List.fold_left (fun acc x -> sprintf "%s.%s" acc x) (List.hd n) (List.tl n))
in
aux (List.assoc "ADDITIONAL" r)
external get_mx_dns : string -> (string * int) array = "get_mx_dns"
let get_mx name : string list =
let arr = get_mx_dns name in
Array.sort (fun x y -> compare (snd x) (snd y)) arr;
arr
|> Array.to_list
|> List.map fst
let resolve_mx name =
let output = File.process_output (sprintf "dig %s MX" name) in
try
let _pos, r = Dig.parse_dig_dig output in
List.assoc "ANSWER" r
|> List.filter_map (fun x ->
match x.Dig.category with
| Dig.Mx pri -> Some (pri, x.Dig.dst)
| _ -> None)
|> List.sort (fun (pri1, _) (pri2, _) -> compare pri1 pri2)
|> List.filter_map (function
| (_, Dig.Ip i) -> Some i
| (_, Dig.Name n) ->
if List.mem_assoc "ADDITIONAL" r then resolve_additional r n
else resolve_UNIX (String.concat "." n)
)
with _ ->
[]
let empty = { mfrom = "" ; mto = [] ; mdata = "" ; mquit = false ; datamode = false}
let make_email mfrom mto mdata =
{ mfrom = mfrom
; mto = mto
; mdata = mdata
; mquit = true
; datamode = true }
let errors = [
(** Temporary *)
(* This may be a reply to any command if the service knows it must shut down *)
(421, "Service not available, closing transmission channel");
(* E.g., mailbox busy *)
(450, "Requested mail action not taken: mailbox unavailable");
(451, "Requested action aborted: local error in processing");
(452, "Requested action not taken: insufficient system storage");
(** Permanent *)
(* This may include errors such as command line too long *)
(500, "Syntax error, command unrecognized") ;
(501, "Syntax error in parameters or arguments") ;
(502, "Command not implemented") ;
(503, "Bad sequence of commands") ;
(504, "Command parameter not implemented") ;
(* E.g., mailbox not found, no access *)
(550, "Requested action not taken: mailbox unavailable") ;
(551, "User not local; please try") ;
(552, "Requested mail action aborted: exceeded storage allocation") ;
(* E.g., mailbox syntax incorrect *)
(553, "Requested action not taken: mailbox name not allowed") ;
(554, "Transaction fail") ]
let others = [
(211, "System status, or system help reply") ;
(* Information on how to use the receiver or the meaning of a particular non-standard command; this reply is useful only to the human user *)
(214, "Help message") ;
(220, "Service ready SMTP HMS (MLstate Mail Server)") ;
(221, "Service closing transmission channel") ;
(250, "Ok") ;
(251, "User not local; will forward to") ;
(354, "Start mail input; end with . (a dot)") ]
let error n = sprintf "%d Error: %s" n (List.assoc n errors)
let msg n = sprintf "%d %s" n (List.assoc n others)
let crlf = "\r\n"
(* Commands required by RFC 821 *)
(** Identify the SMTP sender to the SMTP receiver *)
let helo e hostname =
e, "250 Hello " ^ hostname
(** Set the envelope return path (sender) and clear the list of envelope recipient addresses *)
let mail e address =
{ e with mfrom=address ; mto = [] }, msg 250
(** Add one address to the list of envelope recipient addresses *)
let default_valid_emails = ["contact" ; "henri" ; "henri.binsztok" ; "hb"]
let default_validate a = List.mem a default_valid_emails
let id address =
let re = Str.regexp ".*<\\([^@]+\\).+" in
if Str.string_match re address 0 then Str.replace_matched "\\1" address
else address
let rcpt ?(validate=default_validate) e address =
if e.mfrom = "" then e, error 503
else
if validate (id address) then
{ e with mto = address::e.mto }, msg 250
else (* Attention, anti-spam, non valide / RFC *)
{ e with mquit=true }, error 553
(** Consider the lines following the command to be e-mail from the sender *)
let data e =
if e.mto = [] then e, error 503
else { e with datamode=true }, msg 354
(** Reset the envelope *)
let rset _e = empty, msg 250
(** Ask the receiver to send a valid reply (but specify no other action) *)
let noop e = e, msg 250
(** Ask the receiver to send a valid reply, and then close the transmission channel *)
let quit e = {e with mquit=true}, msg 221
(* Evaluation *)
let zero_arg e f arg = if arg=[] then f e else e, error 501
let one_arg e f = function [arg] -> f e arg | _ -> e, error 501
let two_arg e f test = function
| [t2; arg] when (String.uppercase t2=test) -> f e arg
| _ -> e, error 501
let eval e s =
let re = Str.regexp "[ :\n\r]+" in
match Str.split re s with
| command::arg ->
begin match String.uppercase command with
| "HELO" -> one_arg e helo arg
| "MAIL" -> two_arg e mail "FROM" arg
| "RCPT" -> two_arg e rcpt "TO" arg
| "DATA" -> zero_arg e data arg
| "RSET" -> zero_arg e rset arg
| "NOOP" -> zero_arg e noop arg
| "QUIT" -> zero_arg e quit arg
| _ -> e, error 502 end
| _ -> e, error 500
(* Dialog *)
let read_line (sched: Scheduler.t) conn cont =
let rec retry buf =
Scheduler.read_more sched conn buf ~timeout:(Time.seconds 300) (fun (_, buf) ->
let str = FBuffer.contents buf in
if not (String.is_contained "\r\n" str) then
retry buf
else (
Logger.debug "<<< %s" str;
cont str
)
)
in retry (FBuffer.make 0)
let write_line (sched: Scheduler.t) str conn cont =
Logger.debug ">>> %s" str;
Scheduler.write sched conn (str ^ crlf) cont
let mail_recv save_mail conn (sched: Scheduler.t) cont =
let send s cont =
Logger.debug "OUT: %s" s;
write_line sched s conn cont in
let rec f e cont =
if e.mquit then ()
else
read_line sched conn (fun inp ->
Logger.debug "IN: %s" inp;
if e.datamode then
if Str.string_match (Str.regexp "^\\.[\r\n]+") inp 0 then
begin save_mail e ;
send (msg 250 ^ ": queued as " ^ string_of_int (Random.int max_int)) (fun _ ->
f empty cont) end
else f { e with mdata=e.mdata ^ inp ^ "\n" } cont
else
let ne, out = eval e inp in
send out (fun _ -> f ne cont)
) in
try
send (msg 220) (fun _ ->
f empty cont )
with
_ -> cont()
let read_code s =
let get i = int_of_char (String.unsafe_get s i) - 48 in
let l = String.length s in
if l > 3 then 100 * get 0 + 10 * get 1 + get 2, String.sub s 4 (4 - 3)
else 0, "unknown server answer"
exception Bad_address of string
exception Unknown_address of string
let simple_mail s =
try
let _, (_, (user, domain)) = Email.parse_email_email s in
sprintf "%s@%s" user domain
with _ -> raise (Bad_address s)
let valid_email s =
try
ignore (Email.parse_email_email s);
true
with _ -> false
module MailSend =
struct
(* Error_MX = can't connect to the MX server, let's try another one *)
type mail_res = Ok | Error | Error_MX | Delayed of int
let analyze_error = Mailerror.parse_mailerror_error
let mail_send_fun_aux (sched: Scheduler.t) domain mfrom mto mdata back_fun attempt conn cont =
let wait_and_retry x mdata attempt cont =
Scheduler.remove_connection sched conn;
ignore(Scheduler.sleep sched x (fun () ->
back_fun mdata (succ attempt) cont))
in
let send expect s cont =
write_line sched s (conn: Scheduler.connection_info) (fun _ ->
let rec aux res code cont =
if code = 220 then
read_line sched conn (fun res ->
let code, _ = read_code res in
aux res code cont)
else
cont (res, code)
in
aux "" 220 (fun (res, code) ->
if List.mem code expect then cont None
else cont (Some res)))
in
let dialog_list =
[ (sprintf "HELO %s" domain, [250])
; (sprintf "MAIL FROM:<%s>" (simple_mail mfrom), [250])
; (sprintf "RCPT TO:<%s>" (simple_mail mto), [250])
; ("DATA", [354])
; (mdata, [250])
; ("QUIT", [221])
] in
let rec aux x cont = match x with
| (message, expected) :: tl ->
begin
send expected message (function
| None -> aux tl cont
| Some err ->
begin
Logger.debug "mail_send_fun_new error : %s" err;
try
let _pos, res = analyze_error err in
match res with
| Mailerror.GreylistedSec x ->
let x = if x < 90 then 90 else x in
Logger.debug "::: greylisted (%d secs)" x;
wait_and_retry (Time.seconds x) mdata (succ attempt) cont
| Mailerror.GreylistedMin x ->
Logger.debug "::: greylisted (%d mins)" x;
let x = x * 60 in
wait_and_retry (Time.seconds x) mdata (succ attempt) cont
| Mailerror.Add_cc s ->
wait_and_retry (Time.seconds 1) (sprintf "Cc: %s\r\n%s" s mdata) (succ attempt) cont
| _ when fst (read_code err) = 451 ->
let x = 60 * attempt * attempt in
Logger.debug "::: waiting (%d sec)" x;
wait_and_retry (Time.seconds x) mdata (succ attempt) cont
| _ -> cont Error
with _ -> cont Error
end)
end
| _ -> cont Ok
in
read_line sched conn (fun sr ->
if fst (read_code sr) = 220 then
aux dialog_list cont
else
let error () =
Logger.debug "couldn't initiate server dialog";
cont Error_MX
in
try
let _pos, res = analyze_error sr in
match res with
| Mailerror.GreylistedSec x ->
let x = max x 60 in
Logger.debug "::: greylisted (%d secs)" x;
Logger.debug "waiting %d secs" x;
wait_and_retry (Time.seconds x) mdata (succ attempt) cont
| Mailerror.GreylistedMin x ->
Logger.debug "::: greylisted (%d mins)" x;
let x = x * 60 in
Logger.debug "waiting %d secs" x;
wait_and_retry (Time.seconds x) mdata (succ attempt) cont
| Mailerror.Add_cc s ->
wait_and_retry Time.zero (sprintf "Cc: %s\r\n%s" s mdata) (succ attempt) cont
| _ -> error ()
with _ -> error ()
)
let mail_send_fun_new (sched: Scheduler.t) domain mfrom mto mdata back_fun attempt conn cont =
let rec aux acc =
try
mail_send_fun_aux (sched: Scheduler.t) domain mfrom mto mdata back_fun attempt conn cont
with | Unix.Unix_error(_,"recv","") as err ->
if acc >= 10 then raise err
else aux (acc + 1)
in aux 0
end
let split_email s =
try
let _, (_, user_domain) = Email.parse_email_email s in
user_domain
with _ -> raise (Bad_address s)
exception Too_much_try
let full_email mfrom mto mdata =
sprintf "From: %s\r\nTo: %s\r\nMessage-ID: <%s.%s>\r\nX-Mailer: MLstate mailserve\r\n%s\r\n."
mfrom mto (String.random 10) mfrom mdata
let mail_send (sched: Scheduler.t) mfrom mto mdata attempt cont =
let mdata = full_email mfrom mto mdata in
let _user_from, domain_from = split_email mfrom
and _user_to, dst = split_email mto in
let ip_list = resolve_mx dst in
let rec try_mx ip_list mdata attempt cont =
match ip_list with
| [] ->
Logger.warning "No working MX server found - can't send mail to %s" mto;
cont MailSend.Error
| _ when attempt >= 10 -> cont MailSend.Error
| dst_ip :: mx_servers ->
let addr = Network.addr_of_ipv4 dst_ip in
let port_spec = Network.make_port_spec ~protocol:smtp addr 25 in
let connect_cont conn =
let rec retry_fun mdata attempt cont =
MailSend.mail_send_fun_new sched domain_from mfrom mto mdata (try_mx ip_list) attempt conn
(function
| MailSend.Error_MX -> Scheduler.remove_connection sched conn; try_mx mx_servers mdata attempt cont
| res -> Scheduler.remove_connection sched conn; cont res)
in
retry_fun mdata attempt cont
in
Network.connect sched port_spec Network.Unsecured connect_cont
in
try_mx ip_list mdata attempt cont
let mail_content ?(charset="ISO-8859-1") subject body =
sprintf "Content-Type: text/plain; charset=%s\r\nSubject: %s\r\n\r\n%s\r\n" charset subject body