Skip to content
This repository
Newer
Older
100644 178 lines (150 sloc) 6.242 kb
fccc6851 »
2011-06-21 Initial open-source release
1 (*
2 Copyright © 2011 MLstate
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_drop_privilege: bool;
35 opt_ssl_cert : string;
36 opt_ssl_key : string;
37 opt_ssl_pass : string;
38 opt_ssl_accept_fun : Ssl.certificate -> bool;
39 opt_ssl_always : bool;
40 opt_ssl_ca_file : string;
41 opt_ssl_ca_path : string;
42 opt_ssl_client_ca_file : string;
43 opt_ssl_client_cert_path : string;
44 opt_dialog: string;
45 opt_on_server_close : Scheduler.t -> unit;
46 opt_name: string;
47 }
48
49 let default_options =
50 { opt_addr = "0.0.0.0";
51 opt_port = 2525;
52 opt_drop_privilege = true;
53 opt_ssl_cert = "";
54 opt_ssl_key = "";
55 opt_ssl_pass = "";
56 opt_ssl_accept_fun = (fun _ -> true);
57 opt_ssl_always = false;
58 opt_ssl_ca_file = "";
59 opt_ssl_ca_path = "";
60 opt_ssl_client_ca_file = "";
61 opt_ssl_client_cert_path = "";
62 opt_dialog = "default";
63 opt_on_server_close = (fun _ -> ());
64 opt_name = "smtpServerPort";
65 }
66
67 let prefixed_opt name opt = [Printf.sprintf "--%s-%s" name opt; Printf.sprintf "--%s" opt]
68
69 let spec_args name =
70 let p = prefixed_opt name in
71 [
72 (p"port")@["-p"],
73 ServerArg.func ServerArg.int
74 (fun o p -> if p > 0xffff then (Logger.critical "Bad port number: %d" p; exit 1) else { o with opt_port = p }),
75 "<int>", "Sets the port on which the server should run";
76
77 (*p"no-flood-prevention",
78 ServerArg.func ServerArg.unit (fun o () -> { o with opt_dos_prevention = false }),
79 "", "Disable the built-in protection against Denial-of-Service attacks";*)
80
81 p"no-drop-privilege",
82 ServerArg.func ServerArg.unit (fun o () -> { o with opt_drop_privilege = false }),
83 "", "Disable the drop of privilege on server start";
84
85 p"ssl-cert",
86 ServerArg.func ServerArg.string (fun o s -> { o with opt_ssl_cert = s }),
87 "<file>", "Location of your SSL certificate (requires ssl-key)";
88
89 p"ssl-key",
90 ServerArg.func ServerArg.string (fun o s -> { o with opt_ssl_key = s }),
91 "<file>", "Location of your SSL key (requires ssl-cert)";
92
93 p"ssl-pass",
94 ServerArg.func ServerArg.string (fun o s -> { o with opt_ssl_pass = s }),
95 "<string>", "Password of your SSL certificate (requires ssl-cert and ssl-key options)";
96
97 p"dialog",
98 ServerArg.func ServerArg.string (fun o s -> { o with opt_dialog = s }),
99 "<string>", "Name of the ftp dialog to use"
100 ]
101
102 let make_ssl_cert opt =
103 if opt.opt_ssl_cert <> "" then
104 if opt.opt_ssl_key <> "" then
105 Some (SslAS.make_ssl_certificate opt.opt_ssl_cert opt.opt_ssl_key opt.opt_ssl_pass)
106 else begin
107 Logger.critical "Error : ssl-cert option MUST be used with ssl-key option";
108 exit 1
109 end
110 else
111 None
112
113 let make_ssl_verify opt =
114 if opt.opt_ssl_ca_file <> "" || opt.opt_ssl_ca_path <> "" || opt.opt_ssl_client_cert_path <> "" then
115 Some (SslAS.make_ssl_verify_params ~client_ca_file:opt.opt_ssl_client_ca_file
116 ~accept_fun:opt.opt_ssl_accept_fun ~always:opt.opt_ssl_always
117 opt.opt_ssl_ca_file opt.opt_ssl_ca_path opt.opt_ssl_client_cert_path)
118 else
119 None
120
121 let handle_email { SCC.from=_from; dests=_dests; body=_body } =
122 #<If$minlevel 10>Logger.debug "handle_email:\n";
123 Logger.debug "FROM: %s TO: [%s]\n" _from (String.concat ", " _dests);
124 Logger.debug "%s\n" (Rcontent.get_content _body)#<End>;
125 250, "Ok"
126
127 let handle_verify = function
128 | _ -> (551,"User not local")
129 (* or... *)
130 (*| _ -> (553,"User ambiguous")*)
131 (*| _ -> (502,"VRFY command is disabled")*)
132
133 let handle_expand = function
134 | _ -> [(551,"User not local")]
135
136 let make (_name:string) (opt:options) (_sched:Scheduler.t) : t =
137 if opt.opt_drop_privilege then Systools.change_user ();
138 let secure_mode = Network.secure_mode_from_params (make_ssl_cert opt) (make_ssl_verify opt) in
139 let runtime = { SCC.rt_plim = 128;
140 rt_dialog_name = opt.opt_dialog;
141 rt_on_close = opt.opt_on_server_close;
142 rt_proto = { SCC.rt_name = opt.opt_name;
143 rt_addr = opt.opt_addr;
144 rt_port = opt.opt_port;
145 rt_block_size = 4096;
146 rt_secure_mode = secure_mode;
147 rt_backtrace = true; (* FIXME: put this into options. *)
148 rt_server_write_timeout = Time.seconds 36;
149 rt_payload = ();
150 };
151 } in
152 let state = { SCC.server_domain = "smtp.localhost.local";
153 server_port = 2525;
154 hello_message = "";
155 client_domain = "";
156 callback = handle_email;
157 verify = handle_verify;
158 expand = handle_expand;
159 extended = false;
160 } in
161 let lc = Unix.localtime (Unix.gettimeofday ()) in
162 let server_msg = Printf.sprintf "MLstate SMTP server at %s:%d.\nStarted on %s, %s."
163 state.SCC.server_domain state.SCC.server_port (Date.date2 lc) (Date.time lc) in
164 Logger.notice "%s" server_msg;
165 {
166 SCC.runtime = runtime;
167 err_cont = None;
168 extra_params = state;
169 }
170
171 let get_ports (server:t) (sched:Scheduler.t) = SCC.get_ports server sched
172
173 let get_description _smtp_server _sched = `SmtpServer
174
175 let run smtp_server _sched = smtp_server
176
177 let close (smtp_server:t) sched = smtp_server.SCC.runtime.SCC.rt_on_close sched
Something went wrong with that request. Please try again.