Skip to content
Browse files

[enhance] Email: big commit, see details below

          - ability to give custom To: or Cc: addresses (in Email.options)
          - bug: when sending an email, the To: field is not necessarily the recipient
          - better error handling for mx_resolution, especially when no MX found (retry)
          - files are now in Email.options, and not directly as a function parameter
          - some cleanup, format and doc
  • Loading branch information...
1 parent ce878b5 commit 96634d54b0d54ad965be90a6d41c584039759612 @Aqua-Ye Aqua-Ye committed Jan 2, 2012
Showing with 156 additions and 116 deletions.
  1. +25 −15 libnet/smtpClient.ml
  2. +6 −6 opabsl/mlbsl/bslMail.ml
  3. +125 −95 stdlib/web/mail/email.opa
View
40 libnet/smtpClient.ml
@@ -207,29 +207,39 @@ let resolve_mx name =
Logger.error "resolve_mx: parsing failed!" ; []
let mail_send_aux ?client_certificate ?verify_params ?(secure=false) sched
- ?subject mfrom mto mdata ?return_path ?html ?files ?custom_headers ?cte ?charset nb_attempt ?(port=25) cont () =
+ ?subject mfrom mdst ?mto mdata ?return_path ?html ?files ?custom_headers ?cte ?charset nb_attempt ?(port=25) cont () =
+ let mto = match mto with
+ | Some tos -> tos
+ | None -> mdst in
let wait_and_retry x k = ignore(Scheduler.sleep sched x k) in
let mdata = full_email ?subject mfrom mto mdata ?return_path ?html ?files ?custom_headers ?cte ?charset () in
#<If:PROTOCOL_DEBUG$minlevel 10>Logger.debug "mdata='%s'" mdata#<End>;
let from = split_email mfrom
- and dst = split_email mto in
+ and dst = split_email mdst in
match from, dst with
| None,_ -> cont SCC.Bad_Sender
| _,None -> cont SCC.Bad_Recipient
| (Some (_,domain_from)),(Some (_,dst)) ->
- let ip_list = resolve_mx dst in
- let mail = { SCC.from = simple_mail mfrom ; dests = [mto] ; body = mdata } in
- let rec try_mx mail attempt cont = function
+ let mail = { SCC.from = simple_mail mfrom ; dests = [mdst] ; body = mdata } in
+ let rec try_mx mail attempt ?ip_list cont =
+ let ip_list =
+ match ip_list with
+ | Some list -> list
+ | None -> resolve_mx dst in
+ match ip_list with
| [] ->
- Logger.warning "No working MX server found - can't send mail to %s" mto;
- cont SCC.Error_MX
+ if attempt < 0 then
+ let _ = Logger.warning "No working MX server found - can't send mail to %s" mdst in
+ cont SCC.Error_MX
+ else
+ wait_and_retry (Time.seconds 60) (fun () -> try_mx mail (pred attempt) cont)
| _ when attempt < 0 -> Logger.error "Too many failures" ; cont SCC.Error_MX
| dst_ip :: mx_servers as ips ->
let tools = {
SCC.log = _log " " ;
elog = _log "-" ;
k = (function
- | SCC.Error_MX -> try_mx mail (pred attempt) cont mx_servers
+ | SCC.Error_MX -> try_mx mail (pred attempt) ~ip_list:mx_servers cont
| SCC.Error msg ->
( prerr_endline ("ERROR: " ^ msg) ;
try
@@ -238,18 +248,18 @@ let mail_send_aux ?client_certificate ?verify_params ?(secure=false) sched
| 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) (fun () -> try_mx mail (pred attempt) cont ips)
+ wait_and_retry (Time.seconds x) (fun () -> try_mx mail (pred attempt) ~ip_list:ips cont)
| Mailerror.GreylistedMin x ->
Logger.debug "::: greylisted (%d mins)" x;
let x = x * 60 in
- wait_and_retry (Time.seconds x) (fun () -> try_mx mail (pred attempt) cont ips)
+ wait_and_retry (Time.seconds x) (fun () -> try_mx mail (pred attempt) ~ip_list:ips cont)
| Mailerror.Add_cc s ->
let new_mail = { mail with SCC.body = Printf.sprintf "Cc: %s\r\n%s" s mail.SCC.body } in
- wait_and_retry (Time.seconds 1) (fun () -> try_mx new_mail (pred attempt) cont ips)
+ wait_and_retry (Time.seconds 1) (fun () -> try_mx new_mail (pred attempt) ~ip_list:ips cont)
| _ when fst (read_code msg) = 451 ->
let x = 60 * attempt * attempt in
Logger.debug "::: waiting (%d sec)" x;
- wait_and_retry (Time.seconds x) (fun () -> try_mx mail (pred attempt) cont ips)
+ wait_and_retry (Time.seconds x) (fun () -> try_mx mail (pred attempt) ~ip_list:ips cont)
| _ -> cont (SCC.Error msg)
with Not_found | Failure _ | Trx_runtime.SyntaxError _ -> cont (SCC.Error msg))
| res -> cont res) ;
@@ -272,10 +282,10 @@ let mail_send_aux ?client_certificate ?verify_params ?(secure=false) sched
else Network.Unsecured
in
SCC.connect client ~secure_mode sched dst_string port
- in try_mx mail nb_attempt cont ip_list
+ in try_mx mail nb_attempt cont
let mail_send ?client_certificate ?verify_params ?secure sched
- ?subject mfrom mto mdata ?return_path ?html ?files ?cte ?charset nb_attempt
+ ?subject mfrom mdst ?mto mdata ?return_path ?html ?files ?cte ?charset nb_attempt
?port cont () =
let files = match files with
| Some l -> Some(List.map (fun (file,filename) ->
@@ -284,6 +294,6 @@ let mail_send ?client_certificate ?verify_params ?secure sched
(filename,content_type,base,content)) l)
| None -> None in
mail_send_aux ?client_certificate ?verify_params ?secure sched
- ?subject mfrom mto mdata ?return_path ?html ?files ?cte ?charset nb_attempt
+ ?subject mfrom mdst ?mto mdata ?return_path ?html ?files ?cte ?charset nb_attempt
?port cont ()
View
12 opabsl/mlbsl/bslMail.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -27,12 +27,12 @@
##opa-type Email.send_status
- ##register [cps-bypass] mail_send_fun : string, string, string, string, string,\
+ ##register [cps-bypass] mail_send_fun : string, string, string, string, string, string, string,\
caml_list(caml_tuple_4(string,string,string,string)), \
caml_list(caml_tuple_2(string,string)), \
(opa[email_send_status], continuation(opa[void]) -> void), \
continuation(opa[void]) -> void
- let mail_send_fun mfrom mto subject mdata html files custom_headers cont k =
+ let mail_send_fun mfrom mfrom_address_only mdst mto subject mdata html files custom_headers cont k =
let cont = BslUtils.proj_cps k cont in
let cont x =
let res =
@@ -54,9 +54,9 @@
ServerLib.make_record rc
in cont (wrap_opa_email_send_status res)
in
- (if html = ""
- then SmtpClient.mail_send_aux BslScheduler.opa ~charset:"UTF-8" ~subject mfrom mto mdata ~files ~custom_headers 10 cont ()
- else SmtpClient.mail_send_aux BslScheduler.opa ~charset:"UTF-8" ~subject mfrom mto mdata ~html ~files ~custom_headers 10 cont ());
+ let html = if html = "" then None else Some html
+ and mto = if mto = "" then None else Some mto in
+ SmtpClient.mail_send_aux BslScheduler.opa ~charset:"UTF-8" ~subject mfrom mdst ?mto:mto mdata ?html:html ~files ~custom_headers ~return_path:mfrom_address_only 10 cont ();
QmlCpsServerLib.return k ServerLib.void
##endmodule
View
220 stdlib/web/mail/email.opa
@@ -1,5 +1,5 @@
/*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -18,6 +18,7 @@
/**
* @author Adam Koprowski, Hugo Heuzard 2011
+ * @author Frederic Ye 2012
*
* @destination public
*/
@@ -70,8 +71,17 @@ type Email.send_status =
/ { ok }
/ { error : string }
+/**
+ * Options for sending an email.
+ * Most fields correspond to the email headers.
+ * If to is an empty list, the recipient address will be used for the {b To} field.
+ * We do NOT check if custom_headers already contains {b To:} or {b Cc:} fields.
+ */
type Email.options = {
+ to : list(Email.email)
+ cc : list(Email.email)
custom_headers : list((string, string))
+ files : Email.attachments
}
type caml_tuple_2('a,'b) = external
@@ -83,48 +93,19 @@ type caml_tuple_4('a,'b,'c,'d) = external
Email = {{
default_options = {
+ to = []
+ cc = []
custom_headers = []
+ files = []
} : Email.options
- @private
- send_mail = %% BslMail.Mailserve.mail_send_fun %% : string , string , string , string, string, caml_list(caml_tuple_4(string,string,string,string)), caml_list(caml_tuple_2(string, string)), (Email.send_status -> void) -> void
-
/**
* {1 Parsing email addresses}
*/
- /**
- * A parser for an email address giving a value of type {!Email.email}.
- * An email address should be of the form:
- * John Smith <john.smith@some.server.com>
- * or
- * john.smith@some.server.com
- *
- * For a more detailed description of the accepted format of emails see:
- * {{:http://en.wikipedia.org/wiki/E-mail_address#RFC_specification}E-mail address: RFC specification (Wikipedia)}
- */
@private
dblquote = parser [\"];
- email_parser : Parser.general_parser(Email.email) =
- email_name =
- parser
- // we either have a name in double quotes (needs to be followed by "<" for the address), "..." <...>
- | dblquote name=(!dblquote .)* dblquote Rule.ws &[<] -> Text.ltconcat(name) |> Text.to_string |> some
- // or a name without double quotes (again needs to be followed by "<"), ... <...>
- | name=(![<] .)* &[<] -> Text.ltconcat(name) |> Text.to_string |> String.trim |> some
- // otherwise there's no name component
- | {Rule.succeed} -> none
- email_address =
- parser
- // email address can be in between angle brackets <...>
- | [<] Rule.ws email=address_parser Rule.ws [>] -> email
- // ... or without them
- | email=address_parser -> email
- parser Rule.ws name=email_name Rule.ws address=email_address Rule.ws -> ~{name address}
-
- email_simple_parser : Parser.general_parser(Email.email) = parser Rule.ws email=address_parser Rule.ws -> {name=none ; address=email}
-
/**
* A parser accepting characters allowed as parts of an email
* address, that is:
@@ -157,10 +138,48 @@ Email = {{
address_parser : Parser.general_parser(Email.address) = parser local=local [@] domain=UriParser.domain -> {local=String.concat(".",local) ~domain};
/**
- * Convertion from a string to email.
+ * A parser for a rich email address giving a value of type {!Email.email}.
+ * An email address should be of the form:
+ * "John Smith" <john.smith@some.server.com>
+ * or
+ * John Smith <john.smith@some.server.com>
+ * or
+ * john.smith@some.server.com
+ *
+ * For a more detailed description of the accepted format of emails see:
+ * {{:http://en.wikipedia.org/wiki/E-mail_address#RFC_specification}E-mail address: RFC specification (Wikipedia)}
+ */
+ email_parser : Parser.general_parser(Email.email) =
+ email_name =
+ parser
+ // we either have a name in double quotes (needs to be followed by "<" for the address), "..." <...>
+ | dblquote name=(!dblquote .)* dblquote Rule.ws &[<] -> Text.ltconcat(name) |> Text.to_string |> some
+ // or a name without double quotes (again needs to be followed by "<"), ... <...>
+ | name=(![<] .)* &[<] -> Text.ltconcat(name) |> Text.to_string |> String.trim |> some
+ // otherwise there's no name component
+ | {Rule.succeed} -> none
+ email_address =
+ parser
+ // email address can be in between angle brackets <...>
+ | [<] Rule.ws email=address_parser Rule.ws [>] -> email
+ // ... or without them
+ | email=address_parser -> email
+ parser Rule.ws name=email_name Rule.ws address=email_address Rule.ws -> ~{name address}
+
+ /**
+ * A simpler parser, not looking for email name.
+ */
+ email_simple_parser : Parser.general_parser(Email.email) = parser Rule.ws email=address_parser Rule.ws -> {name=none ; address=email}
+
+ /**
+ * {1 String conversion}
+ */
+
+ /**
+ * Convertion from a string to {!Email.email}.
*
* @param s string for conversion.
- * @return optional email represented by the given string.
+ * @return an optional email represented by the given string.
*/
of_string_opt(s:string) = Parser.try_parse(Email.email_parser, s)
@@ -174,18 +193,21 @@ Email = {{
of_string(s:string) =
of_string_opt(s) ? error("Wrong email: {s}")
- @stringifier(Email.email) to_string(email) =
+ @stringifier(Email.email) to_string(email:Email.email) =
match email.name with
- | {~some} -> "\"{some}\" <{email.address.local}@{email.address.domain}>"
- | {none} -> "{email.address.local}@{email.address.domain}"
+ | {~some} -> "\"{some}\" <{email.address.local}@{email.address.domain}>"
+ | {none} -> "{email.address.local}@{email.address.domain}"
@xmlizer(Email.email) to_xml(email) =
<>{"{email}"}</>
- to_string_only_address(email) =
+ address_to_string(address:Email.address) =
+ "{address.local}@{address.domain}"
+
+ to_string_only_address(email:Email.email) =
"{email.address.local}@{email.address.domain}"
- is_valid_string(s : string) = Option.is_some(of_string_opt(s))
+ is_valid_string(s:string) = Option.is_some(of_string_opt(s))
/**
* {1} Sending Email.
@@ -200,74 +222,82 @@ Email = {{
| { error=e } -> "error : {e}"
@private
- private_send_async(
+ caml_list2(l) =
+ rec aux(l,acc) =
+ match l with
+ | [] -> acc
+ | [hd|tl] -> aux(tl, %%BslNativeLib.cons%%(%%BslNativeLib.ocaml_tuple_2%%(hd),acc))
+ aux(List.rev(l),%%BslNativeLib.empty_list%%)
+
+ @private
+ caml_list4(l) =
+ rec aux(l,acc) =
+ match l with
+ | [] -> acc
+ | [hd|tl] -> aux(tl, %%BslNativeLib.cons%%(%%BslNativeLib.ocaml_tuple_4%%(hd),acc))
+ aux(List.rev(l),%%BslNativeLib.empty_list%%)
+
+ @private
+ send_mail = %% BslMail.Mailserve.mail_send_fun %% : string , string, string , string , string , string, string, caml_list(caml_tuple_4(string,string,string,string)), caml_list(caml_tuple_2(string, string)), (Email.send_status -> void) -> void
+
+ @private
+ send_async(
from : Email.email,
to : Email.email,
subject : string,
mail_content : Email.content,
- files : option(Email.attachments),
options : Email.options,
k : (Email.send_status -> void)) : void =
- caml_list2(l) =
- rec aux(l,acc) =
- match l with
- | [] -> acc
- | [hd|tl] -> aux(tl, %%BslNativeLib.cons%%(%%BslNativeLib.ocaml_tuple_2%%(hd),acc))
- aux(List.rev(l),%%BslNativeLib.empty_list%%)
- caml_list4(l) =
- rec aux(l,acc) =
- match l with
- | [] -> acc
- | [hd|tl] -> aux(tl, %%BslNativeLib.cons%%(%%BslNativeLib.ocaml_tuple_4%%(hd),acc))
- aux(List.rev(l),%%BslNativeLib.empty_list%%)
- (text,html) = match mail_content with
- | {~text} -> (text,"")
- | {~text ~html} -> (text,Xhtml.serialize_as_standalone_html(html))
- | {~html} -> (Xhtml.to_readable_string(html),Xhtml.serialize_as_standalone_html(html))
- end
- files = match files with
- | {none} -> caml_list4([])
- | {some=list_files} ->
- files = List.filter_map((x -> match x with
- | ~{filename content mime_type} ->
- if String.check_substring(mime_type,0,"text/")
- then some((filename,mime_type,"8bit",content))
- else some((filename,mime_type,"base64",Crypto.Base64.encode(content)))
- | ~{filename content mime_type encoding} -> some((filename,mime_type,encoding,content))
- | ~{filename resource} ->
- (match Resource.export_data(resource) with
- | {some=~{data mimetype}} ->
- if String.check_substring(mimetype,0,"text/")
- then some((filename,mimetype,"8bit",data))
- else some((filename,mimetype,"base64",Crypto.Base64.encode(data)))
- | {none} -> {none}
- end))
- ,list_files)
- caml_list4(files)
- end
+ (text, html) = match mail_content with
+ | {~text} -> (text, "")
+ | {~text ~html} -> (text, Xhtml.serialize_as_standalone_html(html))
+ | {~html} -> (Xhtml.to_readable_string(html), Xhtml.serialize_as_standalone_html(html))
+ end
+ files = List.filter_map(x ->
+ match x with
+ | ~{filename content mime_type} ->
+ if String.has_prefix("text/", mime_type)
+ then some((filename,mime_type,"8bit",content))
+ else some((filename,mime_type,"base64",Crypto.Base64.encode(content)))
+ | ~{filename content mime_type encoding} -> some((filename,mime_type,encoding,content))
+ | ~{filename resource} ->
+ match Resource.export_data(resource) with
+ | {some=~{data mimetype}} ->
+ if String.has_prefix("text/", mimetype)
+ then some((filename,mimetype,"8bit",data))
+ else some((filename,mimetype,"base64",Crypto.Base64.encode(data)))
+ | {none} -> {none}
+ end
+ , options.files) |> caml_list4(_)
custom_headers = caml_list2(options.custom_headers)
- send_mail(to_string(from), to_string_only_address(to), subject, text, html, files, custom_headers, k)
+ custom_headers = if List.is_empty(options.cc) then custom_headers
+ else
+ s = List.foldi(i, e, acc ->
+ if i == 0 then to_string(e)
+ else acc ^ ", " ^ to_string(e)
+ , options.cc, "")
+ %%BslNativeLib.cons%%(%%BslNativeLib.ocaml_tuple_2%%(("Cc", s)), custom_headers)
+ mto = if List.is_empty(options.to) then ""
+ else
+ List.foldi(i, e, acc ->
+ if i == 0 then to_string(e)
+ else acc ^ ", " ^ to_string(e)
+ , options.to, "")
+ send_mail(to_string(from), to_string_only_address(from), to_string_only_address(to), mto, subject, text, html, files, custom_headers, k)
- /** Try to send a mail synchronously */
+ /**
+ * Try to send a mail {b synchronously}
+ */
try_send(from : Email.email, to : Email.email, subject : string, content : Email.content, options : Email.options) : Email.send_status =
k(cont) =
f(r) = Continuation.return(cont, r)
- private_send_async(from, to, subject, content, none, options, f)
+ send_async(from, to, subject, content, options, f)
@callcc(k)
- /** Try to send a mail asynchronously */
+ /**
+ * Try to send a mail {b asynchronously}
+ */
try_send_async(from : Email.email, to : Email.email, subject : string, content : Email.content, options : Email.options, continuation : (Email.send_status -> void)) : void =
- private_send_async(from, to, subject, content, none, options, continuation)
-
- /** Try to send a mail containing files synchronously */
- try_send_with_files(from : Email.email, to : Email.email, subject : string, content : Email.content, files : Email.attachments, options : Email.options) : Email.send_status =
- k(cont) =
- f(r) = Continuation.return(cont, r)
- private_send_async(from, to, subject, content, some(files), options, f)
- @callcc(k)
-
- /** Try to send a mail containing files asynchronously */
- try_send_with_files_async(from : Email.email, to : Email.email, subject : string, content : Email.content, files : Email.attachments, options : Email.options, continuation : (Email.send_status -> void)) : void =
- private_send_async(from, to, subject, content, some(files), options, continuation)
+ send_async(from, to, subject, content, options, continuation)
}}

0 comments on commit 96634d5

Please sign in to comment.
Something went wrong with that request. Please try again.