Skip to content
This repository
Browse code

[cleanup] MailServe: removed mailServe.ml file, and imported some fun…

…ctions to smtpClient.ml
  • Loading branch information...
commit c8e6d303fcb87c77038a38963d37f699b5d08e8b 1 parent 9302e5d
Frederic Ye Aqua-Ye authored

Showing 3 changed files with 17 additions and 426 deletions. Show diff stats Hide diff stats

  1. +0 1  libnet.mllib
  2. +0 412 libnet/mailserve.ml
  3. +17 13 libnet/smtpClient.ml
1  libnet.mllib
@@ -3,7 +3,6 @@ libnet/Network
3 3 libnet/Http_dialog
4 4 libnet/HttpType
5 5 libnet/Http_client
6   -libnet/Mailserve
7 6 libnet/SmtpClient
8 7 libnet/SmtpClientCore
9 8 libnet/SmtpClientCore_parse
412 libnet/mailserve.ml
... ... @@ -1,412 +0,0 @@
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   -(** implements http://www.rfcsearch.org/rfcview/RFC/821.html
19   - @author Henri Binsztok *)
20   -
21   -module String = Base.String
22   -module List = Base.List
23   -let (|>) = InfixOperator.(|>)
24   -let sprintf = Printf.sprintf
25   -
26   - (** communication type for statistics *)
27   -let smtp = NetAddr.mk_protocol "SMTP"
28   -
29   -type email = string
30   -
31   -(** SMTP envelope *)
32   -type envel = { mfrom : email
33   - ; mto : email list
34   - ; mdata : string
35   - ; mquit : bool
36   - ; datamode : bool
37   - }
38   -
39   -
40   -let resolve_UNIX name =
41   - try
42   - (Unix.gethostbyname name).Unix.h_addr_list.(0)
43   - |> Unix.string_of_inet_addr
44   - |> String.slice '.'
45   - |> List.map int_of_string
46   - |> function [a;b;c;d] -> Some (a,b,c,d) | _ -> None
47   - with Unix.Unix_error _ -> None
48   -
49   -let resolve_additional r n =
50   - let rec aux = function
51   - | hd :: tl ->
52   - if hd.Dig.domain = n then
53   - match hd.Dig.dst with
54   - | Dig.Ip i -> Some i
55   - | _ -> aux tl
56   - else aux tl
57   - | _ -> resolve_UNIX (List.fold_left (fun acc x -> sprintf "%s.%s" acc x) (List.hd n) (List.tl n))
58   - in
59   - aux (List.assoc "ADDITIONAL" r)
60   -
61   -
62   -external get_mx_dns : string -> (string * int) array = "get_mx_dns"
63   -
64   -let get_mx name : string list =
65   - let arr = get_mx_dns name in
66   - Array.sort (fun x y -> compare (snd x) (snd y)) arr;
67   - arr
68   - |> Array.to_list
69   - |> List.map fst
70   -
71   -let resolve_mx name =
72   - let output = File.process_output (sprintf "dig %s MX" name) in
73   - try
74   - let _pos, r = Dig.parse_dig_dig output in
75   - List.assoc "ANSWER" r
76   - |> List.filter_map (fun x ->
77   - match x.Dig.category with
78   - | Dig.Mx pri -> Some (pri, x.Dig.dst)
79   - | _ -> None)
80   - |> List.sort (fun (pri1, _) (pri2, _) -> compare pri1 pri2)
81   - |> List.filter_map (function
82   - | (_, Dig.Ip i) -> Some i
83   - | (_, Dig.Name n) ->
84   - if List.mem_assoc "ADDITIONAL" r then resolve_additional r n
85   - else resolve_UNIX (String.concat "." n)
86   - )
87   - with _ ->
88   - []
89   -
90   -
91   -let empty = { mfrom = "" ; mto = [] ; mdata = "" ; mquit = false ; datamode = false}
92   -
93   -let make_email mfrom mto mdata =
94   - { mfrom = mfrom
95   - ; mto = mto
96   - ; mdata = mdata
97   - ; mquit = true
98   - ; datamode = true }
99   -
100   -let errors = [
101   - (** Temporary *)
102   - (* This may be a reply to any command if the service knows it must shut down *)
103   - (421, "Service not available, closing transmission channel");
104   - (* E.g., mailbox busy *)
105   - (450, "Requested mail action not taken: mailbox unavailable");
106   - (451, "Requested action aborted: local error in processing");
107   - (452, "Requested action not taken: insufficient system storage");
108   -
109   - (** Permanent *)
110   - (* This may include errors such as command line too long *)
111   - (500, "Syntax error, command unrecognized") ;
112   - (501, "Syntax error in parameters or arguments") ;
113   - (502, "Command not implemented") ;
114   - (503, "Bad sequence of commands") ;
115   - (504, "Command parameter not implemented") ;
116   - (* E.g., mailbox not found, no access *)
117   - (550, "Requested action not taken: mailbox unavailable") ;
118   - (551, "User not local; please try") ;
119   - (552, "Requested mail action aborted: exceeded storage allocation") ;
120   - (* E.g., mailbox syntax incorrect *)
121   - (553, "Requested action not taken: mailbox name not allowed") ;
122   - (554, "Transaction fail") ]
123   -
124   -let others = [
125   - (211, "System status, or system help reply") ;
126   - (* Information on how to use the receiver or the meaning of a particular non-standard command; this reply is useful only to the human user *)
127   - (214, "Help message") ;
128   - (220, "Service ready SMTP HMS (MLstate Mail Server)") ;
129   - (221, "Service closing transmission channel") ;
130   - (250, "Ok") ;
131   - (251, "User not local; will forward to") ;
132   - (354, "Start mail input; end with . (a dot)") ]
133   -
134   -let error n = sprintf "%d Error: %s" n (List.assoc n errors)
135   -let msg n = sprintf "%d %s" n (List.assoc n others)
136   -let crlf = "\r\n"
137   -
138   -(* Commands required by RFC 821 *)
139   -
140   -(** Identify the SMTP sender to the SMTP receiver *)
141   -let helo e hostname =
142   - e, "250 Hello " ^ hostname
143   -
144   -(** Set the envelope return path (sender) and clear the list of envelope recipient addresses *)
145   -let mail e address =
146   - { e with mfrom=address ; mto = [] }, msg 250
147   -
148   -(** Add one address to the list of envelope recipient addresses *)
149   -let default_valid_emails = ["contact" ; "henri" ; "henri.binsztok" ; "hb"]
150   -let default_validate a = List.mem a default_valid_emails
151   -
152   -let id address =
153   - let re = Str.regexp ".*<\\([^@]+\\).+" in
154   - if Str.string_match re address 0 then Str.replace_matched "\\1" address
155   - else address
156   -
157   -let rcpt ?(validate=default_validate) e address =
158   - if e.mfrom = "" then e, error 503
159   - else
160   - if validate (id address) then
161   - { e with mto = address::e.mto }, msg 250
162   - else (* Attention, anti-spam, non valide / RFC *)
163   - { e with mquit=true }, error 553
164   -
165   -(** Consider the lines following the command to be e-mail from the sender *)
166   -let data e =
167   - if e.mto = [] then e, error 503
168   - else { e with datamode=true }, msg 354
169   -
170   -(** Reset the envelope *)
171   -let rset _e = empty, msg 250
172   -
173   -(** Ask the receiver to send a valid reply (but specify no other action) *)
174   -let noop e = e, msg 250
175   -
176   -(** Ask the receiver to send a valid reply, and then close the transmission channel *)
177   -let quit e = {e with mquit=true}, msg 221
178   -
179   -(* Evaluation *)
180   -let zero_arg e f arg = if arg=[] then f e else e, error 501
181   -let one_arg e f = function [arg] -> f e arg | _ -> e, error 501
182   -let two_arg e f test = function
183   - | [t2; arg] when (String.uppercase t2=test) -> f e arg
184   - | _ -> e, error 501
185   -
186   -let eval e s =
187   - let re = Str.regexp "[ :\n\r]+" in
188   - match Str.split re s with
189   - | command::arg ->
190   - begin match String.uppercase command with
191   - | "HELO" -> one_arg e helo arg
192   - | "MAIL" -> two_arg e mail "FROM" arg
193   - | "RCPT" -> two_arg e rcpt "TO" arg
194   - | "DATA" -> zero_arg e data arg
195   - | "RSET" -> zero_arg e rset arg
196   - | "NOOP" -> zero_arg e noop arg
197   - | "QUIT" -> zero_arg e quit arg
198   - | _ -> e, error 502 end
199   - | _ -> e, error 500
200   -
201   -(* Dialog *)
202   -
203   -let read_line (sched: Scheduler.t) conn cont =
204   - let rec retry buf =
205   - Scheduler.read_more sched conn buf ~timeout:(Time.seconds 300) (fun (_, buf) ->
206   - let str = FBuffer.contents buf in
207   - if not (String.is_contained "\r\n" str) then
208   - retry buf
209   - else (
210   - Logger.debug "<<< %s" str;
211   - cont str
212   - )
213   - )
214   - in retry (FBuffer.make 0)
215   -
216   -let write_line (sched: Scheduler.t) str conn cont =
217   - Logger.debug ">>> %s" str;
218   - Scheduler.write sched conn (str ^ crlf) cont
219   -
220   -let mail_recv save_mail conn (sched: Scheduler.t) cont =
221   - let send s cont =
222   - Logger.debug "OUT: %s" s;
223   - write_line sched s conn cont in
224   - let rec f e cont =
225   - if e.mquit then ()
226   - else
227   - read_line sched conn (fun inp ->
228   - Logger.debug "IN: %s" inp;
229   - if e.datamode then
230   - if Str.string_match (Str.regexp "^\\.[\r\n]+") inp 0 then
231   - begin save_mail e ;
232   - send (msg 250 ^ ": queued as " ^ string_of_int (Random.int max_int)) (fun _ ->
233   - f empty cont) end
234   - else f { e with mdata=e.mdata ^ inp ^ "\n" } cont
235   - else
236   - let ne, out = eval e inp in
237   - send out (fun _ -> f ne cont)
238   - ) in
239   - try
240   - send (msg 220) (fun _ ->
241   - f empty cont )
242   - with
243   - _ -> cont()
244   -
245   -let read_code s =
246   - let get i = int_of_char (String.unsafe_get s i) - 48 in
247   - let l = String.length s in
248   - if l > 3 then 100 * get 0 + 10 * get 1 + get 2, String.sub s 4 (4 - 3)
249   - else 0, "unknown server answer"
250   -
251   -exception Bad_address of string
252   -exception Unknown_address of string
253   -
254   -let simple_mail s =
255   - try
256   - let _, (_, (user, domain)) = Email.parse_email_email s in
257   - sprintf "%s@%s" user domain
258   - with _ -> raise (Bad_address s)
259   -
260   -let valid_email s =
261   - try
262   - ignore (Email.parse_email_email s);
263   - true
264   - with _ -> false
265   -
266   -module MailSend =
267   -struct
268   -
269   - (* Error_MX = can't connect to the MX server, let's try another one *)
270   - type mail_res = Ok | Error | Error_MX | Delayed of int
271   -
272   - let analyze_error = Mailerror.parse_mailerror_error
273   -
274   - let mail_send_fun_aux (sched: Scheduler.t) domain mfrom mto mdata back_fun attempt conn cont =
275   - let wait_and_retry x mdata attempt cont =
276   - Scheduler.remove_connection sched conn;
277   - ignore(Scheduler.sleep sched x (fun () ->
278   - back_fun mdata (succ attempt) cont))
279   - in
280   - let send expect s cont =
281   - write_line sched s (conn: Scheduler.connection_info) (fun _ ->
282   - let rec aux res code cont =
283   - if code = 220 then
284   - read_line sched conn (fun res ->
285   - let code, _ = read_code res in
286   - aux res code cont)
287   - else
288   - cont (res, code)
289   - in
290   - aux "" 220 (fun (res, code) ->
291   - if List.mem code expect then cont None
292   - else cont (Some res)))
293   - in
294   - let dialog_list =
295   - [ (sprintf "HELO %s" domain, [250])
296   - ; (sprintf "MAIL FROM:<%s>" (simple_mail mfrom), [250])
297   - ; (sprintf "RCPT TO:<%s>" (simple_mail mto), [250])
298   - ; ("DATA", [354])
299   - ; (mdata, [250])
300   - ; ("QUIT", [221])
301   - ] in
302   - let rec aux x cont = match x with
303   - | (message, expected) :: tl ->
304   - begin
305   -
306   - send expected message (function
307   - | None -> aux tl cont
308   - | Some err ->
309   - begin
310   - Logger.debug "mail_send_fun_new error : %s" err;
311   - try
312   - let _pos, res = analyze_error err in
313   - match res with
314   - | Mailerror.GreylistedSec x ->
315   - let x = if x < 90 then 90 else x in
316   - Logger.debug "::: greylisted (%d secs)" x;
317   - wait_and_retry (Time.seconds x) mdata (succ attempt) cont
318   - | Mailerror.GreylistedMin x ->
319   - Logger.debug "::: greylisted (%d mins)" x;
320   - let x = x * 60 in
321   - wait_and_retry (Time.seconds x) mdata (succ attempt) cont
322   - | Mailerror.Add_cc s ->
323   - wait_and_retry (Time.seconds 1) (sprintf "Cc: %s\r\n%s" s mdata) (succ attempt) cont
324   - | _ when fst (read_code err) = 451 ->
325   - let x = 60 * attempt * attempt in
326   - Logger.debug "::: waiting (%d sec)" x;
327   - wait_and_retry (Time.seconds x) mdata (succ attempt) cont
328   - | _ -> cont Error
329   - with _ -> cont Error
330   - end)
331   - end
332   - | _ -> cont Ok
333   - in
334   - read_line sched conn (fun sr ->
335   - if fst (read_code sr) = 220 then
336   - aux dialog_list cont
337   - else
338   - let error () =
339   - Logger.debug "couldn't initiate server dialog";
340   - cont Error_MX
341   - in
342   - try
343   - let _pos, res = analyze_error sr in
344   - match res with
345   - | Mailerror.GreylistedSec x ->
346   - let x = max x 60 in
347   - Logger.debug "::: greylisted (%d secs)" x;
348   - Logger.debug "waiting %d secs" x;
349   - wait_and_retry (Time.seconds x) mdata (succ attempt) cont
350   - | Mailerror.GreylistedMin x ->
351   - Logger.debug "::: greylisted (%d mins)" x;
352   - let x = x * 60 in
353   - Logger.debug "waiting %d secs" x;
354   - wait_and_retry (Time.seconds x) mdata (succ attempt) cont
355   - | Mailerror.Add_cc s ->
356   - wait_and_retry Time.zero (sprintf "Cc: %s\r\n%s" s mdata) (succ attempt) cont
357   - | _ -> error ()
358   - with _ -> error ()
359   - )
360   -
361   - let mail_send_fun_new (sched: Scheduler.t) domain mfrom mto mdata back_fun attempt conn cont =
362   - let rec aux acc =
363   - try
364   - mail_send_fun_aux (sched: Scheduler.t) domain mfrom mto mdata back_fun attempt conn cont
365   - with | Unix.Unix_error(_,"recv","") as err ->
366   - if acc >= 10 then raise err
367   - else aux (acc + 1)
368   - in aux 0
369   -
370   -end
371   -
372   -let split_email s =
373   - try
374   - let _, (_, user_domain) = Email.parse_email_email s in
375   - user_domain
376   - with _ -> raise (Bad_address s)
377   -
378   -exception Too_much_try
379   -
380   -let full_email mfrom mto mdata =
381   - sprintf "From: %s\r\nTo: %s\r\nMessage-ID: <%s.%s>\r\nX-Mailer: MLstate mailserve\r\n%s\r\n."
382   - mfrom mto (String.random 10) mfrom mdata
383   -
384   -let mail_send (sched: Scheduler.t) mfrom mto mdata attempt cont =
385   - let mdata = full_email mfrom mto mdata in
386   - let _user_from, domain_from = split_email mfrom
387   - and _user_to, dst = split_email mto in
388   - let ip_list = resolve_mx dst in
389   - let rec try_mx ip_list mdata attempt cont =
390   - match ip_list with
391   - | [] ->
392   - Logger.warning "No working MX server found - can't send mail to %s" mto;
393   - cont MailSend.Error
394   - | _ when attempt >= 10 -> cont MailSend.Error
395   - | dst_ip :: mx_servers ->
396   - let addr = Network.addr_of_ipv4 dst_ip in
397   - let port_spec = Network.make_port_spec ~protocol:smtp addr 25 in
398   - let connect_cont conn =
399   - let rec retry_fun mdata attempt cont =
400   - MailSend.mail_send_fun_new sched domain_from mfrom mto mdata (try_mx ip_list) attempt conn
401   - (function
402   - | MailSend.Error_MX -> Scheduler.remove_connection sched conn; try_mx mx_servers mdata attempt cont
403   - | res -> Scheduler.remove_connection sched conn; cont res)
404   - in
405   - retry_fun mdata attempt cont
406   - in
407   - Network.connect sched port_spec Network.Unsecured connect_cont
408   - in
409   - try_mx ip_list mdata attempt cont
410   -
411   -let mail_content ?(charset="ISO-8859-1") subject body =
412   - sprintf "Content-Type: text/plain; charset=%s\r\nSubject: %s\r\n\r\n%s\r\n" charset subject body
30 libnet/smtpClient.ml
@@ -15,6 +15,7 @@
15 15 You should have received a copy of the GNU Affero General Public License
16 16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 17 *)
  18 +
18 19 module SCC = SmtpClientCore
19 20 module List = Base.List
20 21 module String = Base.String
@@ -149,13 +150,6 @@ let full_email ?(subject="") mfrom mto mdata ?return_path ?html ?(files=[]) ?(cu
149 150 then mdata
150 151 else attach_files files mdata ?charset ())
151 152
152   -let analyze_error = Mailerror.parse_mailerror_error
153   -let read_code s =
154   - let get i = int_of_char (String.unsafe_get s i) - 48 in
155   - let l = String.length s in
156   - if l > 3 then 100 * get 0 + 10 * get 1 + get 2, String.sub s 4 (4 - 3)
157   - else 0, "unknown server answer"
158   -
159 153 let resolve_UNIX name =
160 154 try
161 155 (Unix.gethostbyname name).Unix.h_addr_list.(0)
@@ -163,7 +157,7 @@ let resolve_UNIX name =
163 157 |> String.slice '.'
164 158 |> List.map int_of_string
165 159 |> function [a;b;c;d] -> Some (a,b,c,d) | _ -> None
166   - with Not_found | Failure _ -> None
  160 + with Not_found | Failure _ | Unix.Unix_error _ -> None
167 161
168 162 let resolve_additional r n =
169 163 let rec aux = function
@@ -177,12 +171,14 @@ let resolve_additional r n =
177 171 in
178 172 aux (List.assoc "ADDITIONAL" r)
179 173
180   -(*
181   - Mathieu Wed Feb 9 11:28:54 CET 2011
182   - FIXME:
  174 +external get_mx_dns : string -> (string * int) array = "get_mx_dns"
183 175
184   - 2) The following code is duplicated in mailserver.ml
185   -*)
  176 +let get_mx name : string list =
  177 + let arr = get_mx_dns name in
  178 + Array.sort (fun x y -> compare (snd x) (snd y)) arr;
  179 + arr
  180 + |> Array.to_list
  181 + |> List.map fst
186 182
187 183 (* FIXME: il faut en sortie une iterateur IntMapSort d'IP, triée par priorité
188 184 ensuite, on doit tenter les IP une à une... *)
@@ -206,6 +202,14 @@ let resolve_mx name =
206 202 with Not_found | Failure _ ->
207 203 Logger.error "resolve_mx: parsing failed!" ; []
208 204
  205 +let read_code s =
  206 + let get i = int_of_char (String.unsafe_get s i) - 48 in
  207 + let l = String.length s in
  208 + if l > 3 then 100 * get 0 + 10 * get 1 + get 2, String.sub s 4 (4 - 3)
  209 + else 0, "unknown server answer"
  210 +
  211 +let analyze_error = Mailerror.parse_mailerror_error
  212 +
209 213 let mail_send_aux ?client_certificate ?verify_params ?(secure=false) sched
210 214 ?subject mfrom mdst ?mto mdata ?return_path ?html ?files ?custom_headers ?cte ?charset nb_attempt ?(port=25) cont () =
211 215 let mto = match mto with

0 comments on commit c8e6d30

Please sign in to comment.
Something went wrong with that request. Please try again.