Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tag: v520
Fetching contributors…

Cannot retrieve contributors at this time

413 lines (358 sloc) 14.087 kb
(*
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
Jump to Line
Something went wrong with that request. Please try again.