Permalink
Browse files

[enhance] smtp server: binding for Opa

  • Loading branch information...
1 parent 1572ce1 commit df15ccf3fe55db6204a88500b21e72774451155e Damien Graux committed Jul 4, 2011
Showing with 95 additions and 21 deletions.
  1. +34 −21 libnet/smtpServer.ml
  2. +26 −0 opabsl/mlbsl/bslMail.ml
  3. +35 −0 stdlib/web/mail/server.opa
View
55 libnet/smtpServer.ml
@@ -41,11 +41,20 @@ type options =
opt_ssl_ca_path : string;
opt_ssl_client_ca_file : string;
opt_ssl_client_cert_path : string;
+ opt_ssl_certificate : SslAS.ssl_certificate option;
+ opt_ssl_verify_params : SslAS.ssl_verify_params option;
opt_dialog: string;
opt_on_server_close : Scheduler.t -> unit;
opt_name: string;
+ opt_email_handler : SCC.email -> int * string
}
+let handle_email { SCC.from=_from; dests=_dests; body=_body } =
+ #<If$minlevel 10>Logger.debug "handle_email:\n";
+ Logger.debug "FROM: %s TO: [%s]\n" _from (String.concat ", " _dests);
+ Logger.debug "%s\n" (Rcontent.get_content _body)#<End>;
+ 250, "Ok"
+
let default_options =
{ opt_addr = "0.0.0.0";
opt_port = 2525;
@@ -59,9 +68,12 @@ let default_options =
opt_ssl_ca_path = "";
opt_ssl_client_ca_file = "";
opt_ssl_client_cert_path = "";
+ opt_ssl_certificate = None;
+ opt_ssl_verify_params = None;
opt_dialog = "default";
opt_on_server_close = (fun _ -> ());
opt_name = "smtpServerPort";
+ opt_email_handler = handle_email
}
let prefixed_opt name opt = [Printf.sprintf "--%s-%s" name opt; Printf.sprintf "--%s" opt]
@@ -100,29 +112,30 @@ let spec_args name =
]
let make_ssl_cert opt =
- if opt.opt_ssl_cert <> "" then
- if opt.opt_ssl_key <> "" then
- Some (SslAS.make_ssl_certificate opt.opt_ssl_cert opt.opt_ssl_key opt.opt_ssl_pass)
- else begin
- Logger.critical "Error : ssl-cert option MUST be used with ssl-key option";
- exit 1
- end
- else
- None
+ match opt.opt_ssl_certificate with
+ | Some x -> Some x
+ | None ->
+ if opt.opt_ssl_cert <> "" then
+ if opt.opt_ssl_key <> "" then
+ Some (SslAS.make_ssl_certificate opt.opt_ssl_cert opt.opt_ssl_key opt.opt_ssl_pass)
+ else begin
+ Logger.critical "Error : ssl-cert option MUST be used with ssl-key option";
+ exit 1
+ end
+ else
+ None
let make_ssl_verify opt =
- if opt.opt_ssl_ca_file <> "" || opt.opt_ssl_ca_path <> "" || opt.opt_ssl_client_cert_path <> "" then
- Some (SslAS.make_ssl_verify_params ~client_ca_file:opt.opt_ssl_client_ca_file
- ~accept_fun:opt.opt_ssl_accept_fun ~always:opt.opt_ssl_always
- opt.opt_ssl_ca_file opt.opt_ssl_ca_path opt.opt_ssl_client_cert_path)
- else
- None
+ match opt.opt_ssl_verify_params with
+ | Some x -> Some x
+ | None ->
+ if opt.opt_ssl_ca_file <> "" || opt.opt_ssl_ca_path <> "" || opt.opt_ssl_client_cert_path <> "" then
+ Some (SslAS.make_ssl_verify_params ~client_ca_file:opt.opt_ssl_client_ca_file
+ ~accept_fun:opt.opt_ssl_accept_fun ~always:opt.opt_ssl_always
+ opt.opt_ssl_ca_file opt.opt_ssl_ca_path opt.opt_ssl_client_cert_path)
+ else
+ None
-let handle_email { SCC.from=_from; dests=_dests; body=_body } =
- #<If$minlevel 10>Logger.debug "handle_email:\n";
- Logger.debug "FROM: %s TO: [%s]\n" _from (String.concat ", " _dests);
- Logger.debug "%s\n" (Rcontent.get_content _body)#<End>;
- 250, "Ok"
let handle_verify = function
| _ -> (551,"User not local")
@@ -153,7 +166,7 @@ let make (_name:string) (opt:options) (_sched:Scheduler.t) : t =
server_port = 2525;
hello_message = "";
client_domain = "";
- callback = handle_email;
+ callback = opt.opt_email_handler;
verify = handle_verify;
expand = handle_expand;
extended = false;
View
26 opabsl/mlbsl/bslMail.ml
@@ -59,3 +59,29 @@
QmlCpsServerLib.return k ServerLib.void
##endmodule
+
+
+##module mailserver
+
+##register init_server : int, string, SSL.secure_type, \
+ (opa[string], opa[list(string)], opa[string] -> opa[tuple_2(int, string)]) -> void
+let init_server port addr secure_type handler =
+ let ssl_certificate,ssl_verify_params=secure_type in
+ let caml_handler email =
+ let f = ServerLib.wrap_string email.SmtpServerCore.from in
+ let c = Rcontent.get_content email.SmtpServerCore.body in
+ let c = ServerLib.wrap_string c in
+ let t = BslNativeLib.caml_list_to_opa_list ServerLib.wrap_string email.SmtpServerCore.dests in
+ let res = handler f t c in
+ let i, s = BslNativeLib.ocaml_tuple_2 res in
+ ServerLib.unwrap_int i, ServerLib.unwrap_string s
+ in
+ Runtime.add_smtpServer "name" {SmtpServer.default_options with
+ SmtpServer.opt_addr = addr;
+ SmtpServer.opt_port = port;
+ SmtpServer.opt_ssl_certificate = ssl_certificate;
+ SmtpServer.opt_ssl_verify_params = ssl_verify_params;
+ SmtpServer.opt_email_handler = caml_handler;
+ }
+
+##endmodule
View
35 stdlib/web/mail/server.opa
@@ -0,0 +1,35 @@
+type SmtpServer.failure = {dont_exist}
+ / {undisponible}
+ / {stopped}
+ / {unfound}
+ / {forbidden}
+ / {error : string}
+
+type SmtpServer.result = { success }
+ / { failure : SmtpServer.failure}
+
+type SmtpServer.handler = string, list(string), string -> SmtpServer.result
+
+SmtpServer= {{
+ @private
+ init_server = %% BslMail.Mailserver.init_server %%
+ start(ip : ip ,port : int, ssl : option(SSL.secure_type), handler : SmtpServer.handler)=
+ new_handler(f,t,c) = match handler(f,t,c) with
+ | {success} -> (200,"done!")
+ | {failure = {undisponible}} -> (450,"undone because mail box not disponible")
+ | {failure = {stopped}} -> (451,"treatment error")
+ | {failure = {unfound}} -> (550,"No access to mail box => unfound")
+ | {failure = {dont_exist}} -> (553,"mail box's name is not allowed")
+ | {failure = {forbidden}} -> (553,"mail box's name is not allowed")
+ | {failure = {error = txt}} -> (503,txt)
+
+ st = match ssl with
+ | {~some} -> some
+ | {none} -> SSL.make_secure_type({none},{none})
+
+ init_server(port, IPv4.string_of_ip(ip), st, new_handler)
+
+
+
+
+}}

0 comments on commit df15ccf

Please sign in to comment.