Sending email via a specified Smtp Server #20

Closed
wants to merge 3 commits into
from
View
@@ -203,7 +203,7 @@ 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 ?cte ?charset nb_attempt ?(port=25) cont via () =
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
#<If:PROTOCOL_DEBUG$minlevel 10>Logger.debug "mdata='%s'" mdata#<End>;
@@ -216,10 +216,58 @@ let mail_send_aux ?client_certificate ?verify_params ?(secure=false) sched
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
+ | _ when attempt < 0 -> Logger.error "Too many failures" ; cont SCC.Error_MX
+ | _ when via != None ->
+ let tools = {
+ SCC.log = _log " " ;
+ elog = _log "-" ;
+ k = (function
+ | SCC.Error_MX -> Logger.warning "No working MX server found - can't send mail to %s" mto; cont SCC.Error_MX
+ | SCC.Error msg ->
+ ( prerr_endline ("ERROR: " ^ msg) ;
+ try
+ let _pos, res = analyze_error msg 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) (fun () -> try_mx mail (pred attempt) cont ip_list)
+ | 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 ip_list)
+ | 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 ip_list)
+ | _ 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 ip_list)
+ | _ -> cont (SCC.Error msg)
+ with Not_found | Failure _ | Trx_runtime.SyntaxError _ -> cont (SCC.Error msg))
+ | res -> cont res) ;
+ } in
+ let client = { SCC.runtime = { SCC.rt_plim = 128; rt_proto = { SCC.rt_name = "";
+ rt_addr = "";
+ rt_port = 0;
+ rt_secure_mode = Network.Unsecured;
+ rt_block_size = 4096;
+ rt_backtrace = true;
+ rt_server_write_timeout = Time.hours 2;
+ rt_payload = ();
+ }; };
+ err_cont = None;
+ extra_params = (mail,domain_from,tools) } in
+ let str_server = Option.get via in
+ let secure_mode =
+ if secure
+ then Network.Secured (client_certificate, verify_params)
+ else Network.Unsecured
+ in
+ SCC.connect client ~secure_mode sched str_server port
| [] ->
Logger.warning "No working MX server found - can't send mail to %s" mto;
cont SCC.Error_MX
- | _ when attempt < 0 -> Logger.error "Too many failures" ; cont SCC.Error_MX
| dst_ip :: mx_servers as ips ->
let tools = {
SCC.log = _log " " ;
@@ -281,5 +329,5 @@ let mail_send ?client_certificate ?verify_params ?secure sched
| None -> None in
mail_send_aux ?client_certificate ?verify_params ?secure sched
?subject mfrom mto mdata ?return_path ?html ?files ?cte ?charset nb_attempt
- ?port cont ()
+ ?port cont None ()
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)), \
+ option(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 via 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 10 cont via ()
+ else SmtpClient.mail_send_aux BslScheduler.opa ~charset:"UTF-8" ~subject mfrom mto mdata ~html ~files 10 cont via ());
QmlCpsServerLib.return k ServerLib.void
##endmodule
@@ -42,7 +42,7 @@
* - icon-plus, icon-minus, icon-close, icon-check, icon-help, icon-notice ...
*/
-import stdlib.themes.bootstrap.core
+// import stdlib.themes.bootstrap.core
current_bootstrap_version = "1.3.0"
current_bootstrap_url = "http://twitter.github.com/bootstrap/{current_bootstrap_version}/bootstrap.min.css"
View
@@ -80,7 +80,7 @@ type caml_tuple_4('a,'b,'c,'d) = external
Email = {{
@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)), option(string), (Email.send_status -> void) -> void
/**
* {1 Parsing email addresses}
@@ -185,6 +185,7 @@ Email = {{
* {1} Sending Email.
*/
+ @stringifier(Email.send_status)
string_of_send_status( s : Email.send_status ) =
match s with
| { bad_sender } -> "bad sender"
@@ -194,7 +195,7 @@ Email = {{
| { error=s } -> "error : {s}"
@private
- private_send_async(from : Email.email,to : Email.email, subject : string, mail_content : Email.content, files : option(Email.attachment), k : (Email.send_status -> void)) : void =
+ private_send_async(from : Email.email,to : Email.email, subject : string, mail_content : Email.content, files : option(Email.attachment), via : option(string), k : (Email.send_status -> void)) : void =
caml_list(l) =
rec aux(l,acc) =
match l with
@@ -226,24 +227,43 @@ Email = {{
,list_files)
caml_list(files)
end
- send_mail(to_string_only_address(from), to_string_only_address(to), subject, text, html, files, k)
+ send_mail(to_string_only_address(from), to_string_only_address(to), subject, text, html, files, via, k)
+
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)
+ private_send_async(from,to,subject,content,none,none,f)
@callcc(k)
try_send_async(from : Email.email,to : Email.email, subject : string, content :Email.content , k : (Email.send_status -> void)) : void =
- private_send_async(from,to,subject,content,none,k)
+ private_send_async(from,to,subject,content,none,none,k)
try_send_with_files(from : Email.email,to : Email.email, subject : string, content : Email.content, files : Email.attachment) : Email.send_status =
k(cont)=
f(r)= Continuation.return(cont,r)
- private_send_async(from,to,subject,content,some(files),f)
+ private_send_async(from,to,subject,content,some(files),none,f)
@callcc(k)
try_send_with_files_async(from : Email.email,to : Email.email, subject : string, content :Email.content, files : Email.attachment, k : (Email.send_status -> void)) : void =
- private_send_async(from,to,subject,content,some(files),k)
+ private_send_async(from,to,subject,content,some(files),none,k)
+
+ try_send_via(from : Email.email,to : Email.email, subject : string, content : Email.content, via : string) : Email.send_status =
+ k(cont)=
+ f(r)= Continuation.return(cont,r)
+ private_send_async(from,to,subject,content,none,some(via),f)
+ @callcc(k)
+
+ try_send_async_via(from : Email.email,to : Email.email, subject : string, content :Email.content ,via : string, k : (Email.send_status -> void)) : void =
+ private_send_async(from,to,subject,content,none,some(via),k)
+
+ try_send_with_files_via(from : Email.email,to : Email.email, subject : string, content : Email.content, files : Email.attachment, via : string) : Email.send_status =
+ k(cont)=
+ f(r)= Continuation.return(cont,r)
+ private_send_async(from,to,subject,content,some(files),some(via),f)
+ @callcc(k)
+
+ try_send_with_files_async_via(from : Email.email,to : Email.email, subject : string, content :Email.content, files : Email.attachment, via : string, k : (Email.send_status -> void)) : void =
+ private_send_async(from,to,subject,content,some(files),some(via),k)
}}