Permalink
Browse files

[enhance] Email: send functions now also take Email.options, only con…

…taining custom_headers for the moment
  • Loading branch information...
1 parent f47a7ab commit d1e4f0f1d0591aef9a6c34e6d68d5c78d4942409 @Aqua-Ye Aqua-Ye committed Dec 16, 2011
Showing with 56 additions and 26 deletions.
  1. +9 −5 libnet/smtpClient.ml
  2. +4 −3 opabsl/mlbsl/bslMail.ml
  3. +2 −0 opabsl/mlbsl/bslNativeLib.ml
  4. +41 −18 stdlib/web/mail/email.opa
View
@@ -128,7 +128,10 @@ let attach_files files mdata ?(charset="UTF-8") () =
attach_one_file boundary mime filename charset cte content) files in
attach_content boundary mdata fs
-let full_email ?(subject="") mfrom mto mdata ?return_path ?html ?(files=[]) ?cte ?charset () =
+let attach_custom_headers(custom_headers) =
+ List.fold_left (fun acc (name, value) -> Printf.sprintf "%s%s: %s\r\n" acc name value) "" custom_headers
+
+let full_email ?(subject="") mfrom mto mdata ?return_path ?html ?(files=[]) ?(custom_headers=[]) ?cte ?charset () =
let mdata = match html with
| Some html -> mail_content_html ?charset ?cte ~ascii_part:mdata html
| None -> mail_content ?charset ?cte mdata
@@ -138,9 +141,10 @@ let full_email ?(subject="") mfrom mto mdata ?return_path ?html ?(files=[]) ?cte
| Some return_path -> return_path
| None -> mfrom
in
- (Printf.sprintf "From: %s\r\nReturn-Path:<%s>\r\nTo: %s\r\nMessage-ID: <%s.%s>\r\nX-Mailer: MLstate mailclient\r\nDate: %s\r\nMime-Version: 1.0\r\n%s"
+ (Printf.sprintf "From: %s\r\nReturn-Path:<%s>\r\nTo: %s\r\nMessage-ID: <%s.%s>\r\nX-Mailer: MLstate mailclient\r\nDate: %s\r\nMime-Version: 1.0\r\n%s%s"
mfrom return_path mto (String.random 10) mfrom (Date.rfc1123 (Time.gmtime (Time.now())))
- (if subject = "" then "" else sprintf "Subject: %s\r\n" subject))
+ (if subject = "" then "" else sprintf "Subject: %s\r\n" subject)
+ (attach_custom_headers custom_headers))
^(if files = []
then mdata
else attach_files files mdata ?charset ())
@@ -203,9 +207,9 @@ 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 ?cte ?charset nb_attempt ?(port=25) cont () =
+ ?subject mfrom mto mdata ?return_path ?html ?files ?custom_headers ?cte ?charset nb_attempt ?(port=25) cont () =
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 ?cte ?charset () 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
View
@@ -29,9 +29,10 @@
##register [cps-bypass] mail_send_fun : 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 cont k =
+ let mail_send_fun mfrom mto subject mdata html files custom_headers cont k =
let cont = BslUtils.proj_cps k cont in
let cont x =
let res =
@@ -54,8 +55,8 @@
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 10 cont ()
- else SmtpClient.mail_send_aux BslScheduler.opa ~charset:"UTF-8" ~subject mfrom mto mdata ~html ~files 10 cont ());
+ 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 ());
QmlCpsServerLib.return k ServerLib.void
##endmodule
@@ -106,6 +106,7 @@ let unwrap_option proj opa =
(**
caml_tuple_* as known by OCaml
*)
+##extern-type caml_tuple_2('a,'b) = ('a*'b)
##extern-type caml_tuple_4('a,'b,'c,'d) = ('a*'b*'c*'d)
(**
@@ -122,6 +123,7 @@ let f4 = ServerLib.static_field_of_name "f4"
+##register ocaml_tuple_2 : opa[tuple_2('a,'b)] -> caml_tuple_2('a,'b)
let ocaml_tuple_2 opa =
let record = unwrap_opa_tuple_2 opa in
let a = ServerLib.unsafe_dot record f1 in
View
@@ -70,15 +70,24 @@ type Email.send_status =
/ { ok }
/ { error : string }
+type Email.options = {
+ custom_headers : list((string, string))
+}
+
+type caml_tuple_2('a,'b) = external
type caml_tuple_4('a,'b,'c,'d) = external
/**
* This module is meant to deal with email address and email sending
*/
Email = {{
+ default_options = {
+ custom_headers = []
+ } : Email.options
+
@private
- send_mail = %% BslMail.Mailserve.mail_send_fun %% : string , string , string , string, string, caml_list(caml_tuple_4(string,string,string,string)), (Email.send_status -> void) -> void
+ 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}
@@ -191,8 +200,21 @@ Email = {{
| { error=e } -> "error : {e}"
@private
- private_send_async(from : Email.email, to : Email.email, subject : string, mail_content : Email.content, files : option(Email.attachments), k : (Email.send_status -> void)) : void =
- caml_list(l) =
+ 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
@@ -204,7 +226,7 @@ Email = {{
| {~html} -> (Xhtml.to_readable_string(html),Xhtml.serialize_as_standalone_html(html))
end
files = match files with
- | {none} -> caml_list([])
+ | {none} -> caml_list4([])
| {some=list_files} ->
files = List.filter_map((x -> match x with
| ~{filename content mime_type} ->
@@ -221,30 +243,31 @@ Email = {{
| {none} -> {none}
end))
,list_files)
- caml_list(files)
+ caml_list4(files)
end
- send_mail(to_string_only_address(from), to_string_only_address(to), subject, text, html, files, k)
+ custom_headers = caml_list2(options.custom_headers)
+ send_mail(to_string_only_address(from), to_string_only_address(to), subject, text, html, files, custom_headers, k)
/** Try to send a mail synchronously */
- try_send(from : Email.email, to : Email.email, subject : string, content : Email.content) : Email.send_status =
- k(cont)=
- f(r)= Continuation.return(cont, r)
- private_send_async(from, to, subject, content, none, f)
+ 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)
@callcc(k)
/** Try to send a mail asynchronously */
- try_send_async(from : Email.email, to : Email.email, subject : string, content :Email.content, continuation : (Email.send_status -> void)) : void =
- private_send_async(from, to, subject, content, none, k)
+ 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) : Email.send_status =
- k(cont)=
- f(r)= Continuation.return(cont, r)
- private_send_async(from, to, subject, content, some(files), f)
+ 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, continuation : (Email.send_status -> void)) : void =
- private_send_async(from, to, subject, content, some(files), continuation)
+ 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)
}}

0 comments on commit d1e4f0f

Please sign in to comment.