Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 286 lines (258 sloc) 12.216 kb
fccc685 Initial open-source release
MLstate authored
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 module SCC = SmtpClientCore
19 module List = Base.List
20 module String = Base.String
21 let (<|) f a = f a
22 let (|>) a f = f a
23 let ( @* ) g f x = g(f(x))
24
25 let sprintf = Printf.sprintf
26
27 let _log sep code reason = Logger.warning "%d%s%s" code sep reason
28
29 exception Bad_address of string
30 exception Too_much_try
31 exception Unknown_address of string
32
33 let split_email s =
34 try let _, (_, user_domain) = Email.parse_email_email s in Some user_domain
35 with Trx_runtime.SyntaxError _ -> None
36
37 let valid_email s =
38 try ignore (Email.parse_email_email s); true
39 with Trx_runtime.SyntaxError _ -> false
40
41 let simple_mail s =
42 try
43 let _, (_, (user, domain)) = Email.parse_email_email s in
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
44 Printf.sprintf "%s@%s" user domain
fccc685 Initial open-source release
MLstate authored
45 with Trx_runtime.SyntaxError _ -> raise (Bad_address s)
46
47 let mail_content ?(charset="ISO-8859-1") ?(cte="7bit") body =
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
48 Printf.sprintf "Content-Type: text/plain; charset=%s\r\n\
fccc685 Initial open-source release
MLstate authored
49 Content-Transfer-Encoding: %s\r\n\
50 \r\n%s\r\n" charset cte body
51
52 let mail_content_html ?(charset="ISO-8859-1") ?(cte="7bit") ~ascii_part body =
53 let ascii_part = Printf.sprintf
54 "Content-Type: text/plain; charset=%s\r\n\
55 Content-Transfer-Encoding: %s\r\n\
56 \r\n%s\r\n" charset cte ascii_part in
57 let html_part = Printf.sprintf
58 "Content-Type: text/html; charset=%s\r\n\
59 Content-Transfer-Encoding: %s\r\n\
60 \r\n%s\r\n" charset cte body in
61 let boundary = String.random 30 in
62 Printf.sprintf "Content-Type: multipart/alternative;\
63 boundary=%s\r\n\r\n\
64 --%s\r\n\
65 %s\r\n\
66 --%s\r\n\
67 %s\r\n\
68 --%s--\r\n"
69 boundary boundary ascii_part boundary html_part boundary
70
71 let split_encode str n sep =
72 let len = String.length str in
73 if len <= n
74 then str
75 else
76 let seplen = String.length sep in
77 let newlen = len + seplen * ((len-1) / n) in
78 let newstr = String.create newlen in
79 let rec aux i j =
80 if len - i <= n
81 then (String.blit str i newstr j (len-i); newstr)
82 else (String.blit str i newstr j n;
83 String.blit sep 0 newstr (j+n) seplen;
84 aux (i+n) (j+n+seplen))
85 in
86 aux 0 0
87
88 (* Most of this is just guesswork and it's incomplete, feel free to modify, add more etc. *)
89 let get_cte mime_type content =
90 match mime_type with
91 | "text/plain"
92 | "text/html" -> "8bit", content
93 | "application/octet-stream" | "application/postscript" | "application/pdf"
94 | "image/x-xbitmap" | "image/x-xpixmap" | "image/x-xwindowdump" | "image/x-cmu-raster" | "image/x-portable-anymap"
95 | "image/x-portable-bitmap" | "image/x-portable-graymap" | "image/x-rgb" | "image/gif" | "image/jpeg" | "image/tiff"
96 | "audio/basic" | "audio/x-wav"
97 | "video/mpeg" | "video/quicktime" | "video/x-sgi-movie"
98 | "application/java" | "application/x-csh" | "application/x-sh" | "application/x-tcl" | "application/x-tex"
99 | "application/x-latex" | "application/x-texinfo" | "application/zip" | "application/x-bcpio" | "application/x-cpio"
100 | "application/x-shar" | "application/x-tar" | "application/x-dvi" | "application/x-hdf" | "application/x-x509-ca-cert"
101 | "multipart/x-zip" | "application/xml"
102 | "application/wsdl+xml" -> "base64", (String.base64encode content)
103 | _ -> (Logger.warning "SmtpClient.get_cte: Unknown mime type \"%s\"" mime_type;
104 "base64", (String.base64encode content))
105
106 let attach_one_file boundary content_type filename charset cte content =
107 let xid = String.random 30 in
108 sprintf "--%s\r\n\
109 Content-Type: %s; name=\"%s\"; charset=%s\r\n\
110 Content-Disposition: attachment; filename=\"%s\"\r\n\
111 Content-Transfer-Encoding: %s\r\n\
112 X-Attachment-Id: %s\r\n\r\n%s\r\n" boundary content_type filename
113 charset filename cte xid (
114 if cte = "base64"
115 then split_encode content 76 "\r\n"
116 else content)
117
118 let attach_content boundary mdata fs =
119 let ct = sprintf "Content-Type: multipart/mixed; boundary=%s\r\n\r\n" boundary in
120 let md = sprintf "--%s\r\n%s\r\n" boundary mdata in
121 let eb = sprintf "--%s--" boundary in
122 ct^md^(String.concat "" fs)^eb
123
124 let attach_files files mdata ?(charset="UTF-8") () =
125 let boundary = String.random 30 in
126 let fs =
127 List.map (fun (filename,mime,cte,content) ->
128 attach_one_file boundary mime filename charset cte content) files in
129 attach_content boundary mdata fs
130
131 let full_email ?(subject="") mfrom mto mdata ?return_path ?html ?(files=[]) ?cte ?charset () =
132 let mdata = match html with
133 | Some html -> mail_content_html ?charset ?cte ~ascii_part:mdata html
134 | None -> mail_content ?charset ?cte mdata
135 in
136 let return_path =
137 match return_path with
138 | Some return_path -> return_path
139 | None -> mfrom
140 in
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
141 (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"
fccc685 Initial open-source release
MLstate authored
142 mfrom return_path mto (String.random 10) mfrom (Date.rfc1123 (Time.gmtime (Time.now())))
143 (if subject = "" then "" else sprintf "Subject: %s\r\n" subject))
144 ^(if files = []
145 then mdata
146 else attach_files files mdata ?charset ())
147
148 let analyze_error = Mailerror.parse_mailerror_error
149 let read_code s =
150 let get i = int_of_char (String.unsafe_get s i) - 48 in
151 let l = String.length s in
152 if l > 3 then 100 * get 0 + 10 * get 1 + get 2, String.sub s 4 (4 - 3)
153 else 0, "unknown server answer"
154
155 let resolve_UNIX name =
156 try
157 (Unix.gethostbyname name).Unix.h_addr_list.(0)
158 |> Unix.string_of_inet_addr
461365b [cleanup] Base.String: changed String.split to a much simpler String.sli...
Louis Gesbert authored
159 |> String.slice '.'
fccc685 Initial open-source release
MLstate authored
160 |> List.map int_of_string
161 |> function [a;b;c;d] -> Some (a,b,c,d) | _ -> None
162 with Not_found | Failure _ -> None
163
164 let resolve_additional r n =
165 let rec aux = function
166 | hd :: tl ->
167 if hd.Dig.domain = n then
168 match hd.Dig.dst with
169 | Dig.Ip i -> Some i
170 | _ -> aux tl
171 else aux tl
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
172 | _ -> resolve_UNIX (List.fold_left (fun acc x -> Printf.sprintf "%s.%s" acc x) (List.hd n) (List.tl n))
fccc685 Initial open-source release
MLstate authored
173 in
174 aux (List.assoc "ADDITIONAL" r)
175
176 (*
177 Mathieu Wed Feb 9 11:28:54 CET 2011
178 FIXME:
179
180 2) The following code is duplicated in mailserver.ml
181 *)
182
183 (* FIXME: il faut en sortie une iterateur IntMapSort d'IP, triée par priorité
184 ensuite, on doit tenter les IP une à une... *)
185 let resolve_mx name =
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
186 let output = File.process_output (Printf.sprintf "dig %s MX" name) in
fccc685 Initial open-source release
MLstate authored
187 try
188 let _pos, r = Dig.parse_dig_dig output in
189 List.assoc "ANSWER" r
190 |> List.filter_map (fun x ->
191 match x.Dig.category with
192 | Dig.Mx pri -> Some (pri, x.Dig.dst)
193 | _ -> None)
194 |> List.sort (fun (pri1, _) (pri2, _) -> compare pri1 pri2)
195 |> List.filter_map (function
196 | (_, Dig.Ip i) -> Some i
197 | (_, Dig.Name n) ->
198 Logger.info "resolve_mx: name=%s" (List.to_string Base.identity n);
199 if List.mem_assoc "ADDITIONAL" r then resolve_additional r n
200 else resolve_UNIX (String.concat "." n)
201 )
202 with Not_found | Failure _ ->
203 Logger.error "resolve_mx: parsing failed!" ; []
204
205 let mail_send_aux ?client_certificate ?verify_params ?(secure=false) sched
206 ?subject mfrom mto mdata ?return_path ?html ?files ?cte ?charset nb_attempt ?(port=25) cont () =
207 let wait_and_retry x k = ignore(Scheduler.sleep sched x k) in
208 let mdata = full_email ?subject mfrom mto mdata ?return_path ?html ?files ?cte ?charset () in
209 #<If:PROTOCOL_DEBUG$minlevel 10>Logger.debug "mdata='%s'" mdata#<End>;
210 let from = split_email mfrom
211 and dst = split_email mto in
212 match from, dst with
213 | None,_ -> cont SCC.Bad_Sender
214 | _,None -> cont SCC.Bad_Recipient
215 | (Some (_,domain_from)),(Some (_,dst)) ->
216 let ip_list = resolve_mx dst in
217 let mail = { SCC.from = simple_mail mfrom ; dests = [mto] ; body = mdata } in
218 let rec try_mx mail attempt cont = function
219 | [] ->
220 Logger.warning "No working MX server found - can't send mail to %s" mto;
221 cont SCC.Error_MX
222 | _ when attempt < 0 -> Logger.error "Too many failures" ; cont SCC.Error_MX
223 | dst_ip :: mx_servers as ips ->
224 let tools = {
225 SCC.log = _log " " ;
226 elog = _log "-" ;
227 k = (function
228 | SCC.Error_MX -> try_mx mail (pred attempt) cont mx_servers
229 | SCC.Error msg ->
230 ( prerr_endline ("ERROR: " ^ msg) ;
231 try
232 let _pos, res = analyze_error msg in
233 match res with
234 | Mailerror.GreylistedSec x ->
235 let x = if x < 90 then 90 else x in
236 Logger.debug "::: greylisted (%d secs)" x;
237 wait_and_retry (Time.seconds x) (fun () -> try_mx mail (pred attempt) cont ips)
238 | Mailerror.GreylistedMin x ->
239 Logger.debug "::: greylisted (%d mins)" x;
240 let x = x * 60 in
241 wait_and_retry (Time.seconds x) (fun () -> try_mx mail (pred attempt) cont ips)
242 | Mailerror.Add_cc s ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
243 let new_mail = { mail with SCC.body = Printf.sprintf "Cc: %s\r\n%s" s mail.SCC.body } in
fccc685 Initial open-source release
MLstate authored
244 wait_and_retry (Time.seconds 1) (fun () -> try_mx new_mail (pred attempt) cont ips)
245 | _ when fst (read_code msg) = 451 ->
246 let x = 60 * attempt * attempt in
247 Logger.debug "::: waiting (%d sec)" x;
248 wait_and_retry (Time.seconds x) (fun () -> try_mx mail (pred attempt) cont ips)
249 | _ -> cont (SCC.Error msg)
250 with Not_found | Failure _ | Trx_runtime.SyntaxError _ -> cont (SCC.Error msg))
251 | res -> cont res) ;
252 } in
253 let client = { SCC.runtime = { SCC.rt_plim = 128; rt_proto = { SCC.rt_name = "";
254 rt_addr = "";
255 rt_port = 0;
256 rt_secure_mode = Network.Unsecured;
257 rt_block_size = 4096;
258 rt_backtrace = true;
259 rt_server_write_timeout = Time.hours 2;
260 rt_payload = ();
261 }; };
262 err_cont = None;
263 extra_params = (mail,domain_from,tools) } in
264 let dst_string = Network.string_of_ipv4 dst_ip in
265 let secure_mode =
266 if secure
267 then Network.Secured (client_certificate, verify_params)
268 else Network.Unsecured
269 in
270 SCC.connect client ~secure_mode sched dst_string port
271 in try_mx mail nb_attempt cont ip_list
272
273 let mail_send ?client_certificate ?verify_params ?secure sched
274 ?subject mfrom mto mdata ?return_path ?html ?files ?cte ?charset nb_attempt
275 ?port cont () =
276 let files = match files with
277 | Some l -> Some(List.map (fun (file,filename) ->
278 let content_type = HttpServer.mime_type file in
279 let base, content = get_cte content_type (File.content file) in
280 (filename,content_type,base,content)) l)
281 | None -> None in
282 mail_send_aux ?client_certificate ?verify_params ?secure sched
283 ?subject mfrom mto mdata ?return_path ?html ?files ?cte ?charset nb_attempt
284 ?port cont ()
285
Something went wrong with that request. Please try again.