Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 184 lines (156 sloc) 6.447 kb
fccc685 Initial open-source release
MLstate authored
1 (*
32e2e4d @Aqua-Ye [enhance] bslMail: switched the smtpServer into CPS
Aqua-Ye authored
2 Copyright © 2011, 2012 MLstate
fccc685 Initial open-source release
MLstate authored
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* smtpServer:
19 SMTP server.
20 *)
21 module SCCp = SmtpServerCore_parse
22 module SCC = SmtpServerCore
23
24 #<Debugvar:HTTP_DEBUG>
25
26 let name = "smtpServer"
27 let version = "1.0beta"
28
29 type t = SCC.t
30
31 type options =
32 { opt_addr: string;
33 opt_port: int;
34 opt_ssl_cert : string;
35 opt_ssl_key : string;
36 opt_ssl_pass : string;
37 opt_ssl_accept_fun : Ssl.certificate -> bool;
38 opt_ssl_always : bool;
39 opt_ssl_ca_file : string;
40 opt_ssl_ca_path : string;
41 opt_ssl_client_ca_file : string;
42 opt_ssl_client_cert_path : string;
df15ccf [enhance] smtp server: binding for Opa
Damien Graux authored
43 opt_ssl_certificate : SslAS.ssl_certificate option;
44 opt_ssl_verify_params : SslAS.ssl_verify_params option;
fccc685 Initial open-source release
MLstate authored
45 opt_dialog: string;
46 opt_on_server_close : Scheduler.t -> unit;
47 opt_name: string;
32e2e4d @Aqua-Ye [enhance] bslMail: switched the smtpServer into CPS
Aqua-Ye authored
48 opt_email_handler : SCC.email -> ((int * string) -> unit) -> unit
fccc685 Initial open-source release
MLstate authored
49 }
50
32e2e4d @Aqua-Ye [enhance] bslMail: switched the smtpServer into CPS
Aqua-Ye authored
51 let handle_email { SCC.from=_from; dests=_dests; body=_body } k =
df15ccf [enhance] smtp server: binding for Opa
Damien Graux authored
52 #<If$minlevel 10>Logger.debug "handle_email:\n";
53 Logger.debug "FROM: %s TO: [%s]\n" _from (String.concat ", " _dests);
54 Logger.debug "%s\n" (Rcontent.get_content _body)#<End>;
32e2e4d @Aqua-Ye [enhance] bslMail: switched the smtpServer into CPS
Aqua-Ye authored
55 k (250, "Ok")
df15ccf [enhance] smtp server: binding for Opa
Damien Graux authored
56
fccc685 Initial open-source release
MLstate authored
57 let default_options =
58 { opt_addr = "0.0.0.0";
59 opt_port = 2525;
60 opt_ssl_cert = "";
61 opt_ssl_key = "";
62 opt_ssl_pass = "";
63 opt_ssl_accept_fun = (fun _ -> true);
64 opt_ssl_always = false;
65 opt_ssl_ca_file = "";
66 opt_ssl_ca_path = "";
67 opt_ssl_client_ca_file = "";
68 opt_ssl_client_cert_path = "";
df15ccf [enhance] smtp server: binding for Opa
Damien Graux authored
69 opt_ssl_certificate = None;
70 opt_ssl_verify_params = None;
fccc685 Initial open-source release
MLstate authored
71 opt_dialog = "default";
72 opt_on_server_close = (fun _ -> ());
73 opt_name = "smtpServerPort";
df15ccf [enhance] smtp server: binding for Opa
Damien Graux authored
74 opt_email_handler = handle_email
fccc685 Initial open-source release
MLstate authored
75 }
76
77 let prefixed_opt name opt = [Printf.sprintf "--%s-%s" name opt; Printf.sprintf "--%s" opt]
78
79 let spec_args name =
80 let p = prefixed_opt name in
81 [
82 (p"port")@["-p"],
83 ServerArg.func ServerArg.int
84 (fun o p -> if p > 0xffff then (Logger.critical "Bad port number: %d" p; exit 1) else { o with opt_port = p }),
85 "<int>", "Sets the port on which the server should run";
86
87 (*p"no-flood-prevention",
88 ServerArg.func ServerArg.unit (fun o () -> { o with opt_dos_prevention = false }),
89 "", "Disable the built-in protection against Denial-of-Service attacks";*)
90
91 p"ssl-cert",
92 ServerArg.func ServerArg.string (fun o s -> { o with opt_ssl_cert = s }),
93 "<file>", "Location of your SSL certificate (requires ssl-key)";
94
95 p"ssl-key",
96 ServerArg.func ServerArg.string (fun o s -> { o with opt_ssl_key = s }),
97 "<file>", "Location of your SSL key (requires ssl-cert)";
98
99 p"ssl-pass",
100 ServerArg.func ServerArg.string (fun o s -> { o with opt_ssl_pass = s }),
101 "<string>", "Password of your SSL certificate (requires ssl-cert and ssl-key options)";
102
103 p"dialog",
104 ServerArg.func ServerArg.string (fun o s -> { o with opt_dialog = s }),
105 "<string>", "Name of the ftp dialog to use"
106 ]
107
108 let make_ssl_cert opt =
df15ccf [enhance] smtp server: binding for Opa
Damien Graux authored
109 match opt.opt_ssl_certificate with
110 | Some x -> Some x
111 | None ->
112 if opt.opt_ssl_cert <> "" then
113 if opt.opt_ssl_key <> "" then
114 Some (SslAS.make_ssl_certificate opt.opt_ssl_cert opt.opt_ssl_key opt.opt_ssl_pass)
115 else begin
116 Logger.critical "Error : ssl-cert option MUST be used with ssl-key option";
117 exit 1
118 end
119 else
120 None
fccc685 Initial open-source release
MLstate authored
121
122 let make_ssl_verify opt =
df15ccf [enhance] smtp server: binding for Opa
Damien Graux authored
123 match opt.opt_ssl_verify_params with
124 | Some x -> Some x
125 | None ->
126 if opt.opt_ssl_ca_file <> "" || opt.opt_ssl_ca_path <> "" || opt.opt_ssl_client_cert_path <> "" then
127 Some (SslAS.make_ssl_verify_params ~client_ca_file:opt.opt_ssl_client_ca_file
128 ~accept_fun:opt.opt_ssl_accept_fun ~always:opt.opt_ssl_always
129 opt.opt_ssl_ca_file opt.opt_ssl_ca_path opt.opt_ssl_client_cert_path)
130 else
131 None
fccc685 Initial open-source release
MLstate authored
132
133
134 let handle_verify = function
135 | _ -> (551,"User not local")
136 (* or... *)
137 (*| _ -> (553,"User ambiguous")*)
138 (*| _ -> (502,"VRFY command is disabled")*)
139
140 let handle_expand = function
141 | _ -> [(551,"User not local")]
142
143 let make (_name:string) (opt:options) (_sched:Scheduler.t) : t =
144 let secure_mode = Network.secure_mode_from_params (make_ssl_cert opt) (make_ssl_verify opt) in
145 let runtime = { SCC.rt_plim = 128;
146 rt_dialog_name = opt.opt_dialog;
147 rt_on_close = opt.opt_on_server_close;
148 rt_proto = { SCC.rt_name = opt.opt_name;
149 rt_addr = opt.opt_addr;
150 rt_port = opt.opt_port;
151 rt_block_size = 4096;
152 rt_secure_mode = secure_mode;
153 rt_backtrace = true; (* FIXME: put this into options. *)
154 rt_server_write_timeout = Time.seconds 36;
155 rt_payload = ();
156 };
157 } in
d6dede8 @nrs135 [fix] libnet: Fixed problem with smtpServer options.
nrs135 authored
158 let state = { SCC.server_domain = opt.opt_addr;
159 server_port = opt.opt_port;
fccc685 Initial open-source release
MLstate authored
160 hello_message = "";
161 client_domain = "";
df15ccf [enhance] smtp server: binding for Opa
Damien Graux authored
162 callback = opt.opt_email_handler;
fccc685 Initial open-source release
MLstate authored
163 verify = handle_verify;
164 expand = handle_expand;
165 extended = false;
166 } in
167 let lc = Unix.localtime (Unix.gettimeofday ()) in
168 let server_msg = Printf.sprintf "MLstate SMTP server at %s:%d.\nStarted on %s, %s."
169 state.SCC.server_domain state.SCC.server_port (Date.date2 lc) (Date.time lc) in
170 Logger.notice "%s" server_msg;
171 {
172 SCC.runtime = runtime;
173 err_cont = None;
174 extra_params = state;
175 }
176
177 let get_ports (server:t) (sched:Scheduler.t) = SCC.get_ports server sched
178
179 let get_description _smtp_server _sched = `SmtpServer
180
181 let run smtp_server _sched = smtp_server
182
183 let close (smtp_server:t) sched = smtp_server.SCC.runtime.SCC.rt_on_close sched
Something went wrong with that request. Please try again.