src/utils/net/mailer.ml

   1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
   2 (*
   3     This file is part of mldonkey.
   4
   5     mldonkey is free software; you can redistribute it and/or modify
   6     it under the terms of the GNU General Public License as published by
   7     the Free Software Foundation; either version 2 of the License, or
   8     (at your option) any later version.
   9
  10     mldonkey is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13     GNU General Public License for more details.
  14
  15     You should have received a copy of the GNU General Public License
  16     along with mldonkey; if not, write to the Free Software
  17     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18 *)
  19
  20
  21 open Printf2
  22 open Options
  23 open Unix
  24 open Date
  25 open Md4
  26
  27 type mail = {
  28     mail_to : string;
  29     mail_from : string;
  30     mail_subject : string;
  31     mail_body : string;
  32     smtp_login : string;
  33     smtp_password : string;
  34   }
  35
  36 let rfc2047_encode h encoding s =
  37   let beginning = "=?" ^ encoding ^"?q?" in
  38   let ending = "?=" in
  39   let space = " " in
  40   let crlf = "\r\n" in
  41   let maxlen = 75 in (* max lenght of a line *)
  42   let buf = Buffer.create 1500 in
  43   let pos = ref 0 in
  44   let rl = ref 1 in
  45   let hexa_digit x =
  46     if x >= 10 then Char.chr (Char.code 'A' + x - 10)
  47     else Char.chr (Char.code '0' + x) in
  48   let copy tanga = begin
  49         Buffer.add_string buf tanga;
  50         pos := !pos + String.length tanga;
  51     end;
  52   in
  53   copy h;
  54   copy beginning;
  55   let newline () =
  56     incr rl;
  57     copy ending;
  58     copy crlf;
  59     copy space;
  60     copy beginning;
  61   in
  62   for i=0 to (String.length s)-1 do
  63     let l = (!rl * (maxlen-String.length ending)) - 1 in
  64     if l < !pos then newline ();
  65     match s.[i] with
  66       | 'a'..'z' | 'A'..'Z' | '0'..'9' ->
  67           Buffer.add_char buf s.[i]; incr pos
  68       | ' ' -> Buffer.add_char buf '_'; incr pos
  69       | c ->
  70           Buffer.add_char buf '=';
  71           Buffer.add_char buf (hexa_digit (Char.code c / 16));
  72           Buffer.add_char buf (hexa_digit (Char.code c mod 16));
  73           pos := !pos + 3;
  74   done;
  75   copy ending;
  76   Buffer.contents buf
  77
  78 let send oc s = Printf.fprintf oc "%s\r\n" s; flush oc
  79 let send1 oc s p = Printf.fprintf oc "%s %s\r\n" s p; flush oc
  80
  81 let simple_connect hostname port =
  82   let s = socket PF_INET SOCK_STREAM 0 in
  83   let h = Ip.from_name  hostname in
  84   let addr = Ip.to_inet_addr h in
  85   try
  86     Unix.connect s (ADDR_INET(addr,port));
  87     s
  88   with e -> close s; raise e
  89
  90 let last_response = ref ""
  91
  92 let bad_response () =
  93   failwith (Printf.sprintf "Bad response [%s]"
  94       (String.escaped !last_response))
  95
  96 type response = int * bool * string list
  97
  98 let get_response ic =
  99   last_response := input_line ic;
 100   if String.length !last_response <= 3 then bad_response ();
 101   if !last_response.[String.length !last_response - 1] <> '\r' then bad_response ();
 102   let final = match !last_response.[3] with ' ' -> true | '-' -> false | _ -> bad_response () in
 103   let code = int_of_string (String.sub !last_response 0 3) in
 104   let text = String.sub !last_response 4 (String.length !last_response - 5) in
 105   (code,final,text)
 106
 107 let read_response ic =
 108   let rec iter () =
 109     match get_response ic with
 110     | (n,true,_) -> n
 111     | _ -> iter ()
 112   in
 113   iter ()
 114
 115 let mail_address new_style s = if new_style then "<"^s^">" else s
 116
 117 let make_mail mail new_style =
 118   let mail_date = Date.mail_string (Unix.time ()) in
 119         Printf.sprintf
 120         "From: mldonkey %s\r\nTo: %s\r\n%s\r\nMIME-Version: 1.0\r\nContent-Type: text/plain; charset=utf-8\r\nDate: %s\r\n\r\n%s"
 121         (mail_address new_style mail.mail_from)
 122         mail.mail_to
 123         (rfc2047_encode "Subject: " "utf-8" mail.mail_subject)
 124         mail_date
 125         mail.mail_body
 126
 127 let canon_addr s =
 128   let len = String.length s in
 129   let rec iter_end s pos =
 130     if pos = -1 then s else
 131     if s.[pos] = ' ' then iter_end s (pos-1) else
 132       iter_begin s (pos-1) pos
 133   and iter_begin s pos last =
 134     if pos = -1 || s.[pos] = ' ' then
 135       String.sub s (pos+1) (last - pos)
 136     else iter_begin s (pos-1) last
 137   in
 138   iter_end s (len - 1)
 139
 140 let string_xor s1 s2 =
 141   assert (String.length s1 = String.length s2);
 142   let s = String.create (String.length s1) in
 143   for i = 0 to String.length s - 1 do
 144     s.[i] <- Char.chr (Char.code s1.[i] lxor Char.code s2.[i]);
 145   done;
 146   s
 147
 148 (* HMAC-MD5, RFC 2104 *)
 149 let hmac_md5 =
 150   let ipad = String.make 64 '\x36' in
 151   let opad = String.make 64 '\x5C' in
 152   let md5 s = Md5.direct_to_string (Md5.string s) in
 153   fun secret challenge ->
 154     let secret = if String.length secret > 64 then md5 secret else secret in
 155     let k = String.make 64 '\x00' in
 156     String.blit secret 0 k 0 (String.length secret);
 157     md5 (string_xor k opad ^ md5 (string_xor k ipad ^ challenge))
 158
 159 let sendmail smtp_server smtp_port new_style mail =
 160 (* a completely synchronous function (BUG) *)
 161   try
 162     let s = simple_connect smtp_server smtp_port in
 163     (try Unix.setsockopt_float s Unix.SO_RCVTIMEO 30. with _ -> ());
 164     (try Unix.setsockopt_float s Unix.SO_SNDTIMEO 30. with _ -> ());
 165     let ic = in_channel_of_descr s in
 166     let oc = out_channel_of_descr s in
 167     let auth_login_enabled = ref false in
 168     let auth_plain_enabled = ref false in
 169     let auth_cram_enabled = ref false in
 170     let read_response_auth ic =
 171       let rec loop () =
 172         let (n,final,text) = get_response ic in
 173         begin match String2.split_simplify (String.uppercase text) ' ' with
 174         | ("AUTH"::methods) ->
 175           List.iter (function
 176           | "LOGIN" -> auth_login_enabled := true
 177           | "PLAIN" -> auth_plain_enabled := true
 178           | "CRAM-MD5" -> auth_cram_enabled := true
 179           | _ -> ()) methods
 180         | _ -> ()
 181         end;
 182         if final then n else loop ()
 183       in
 184       loop ()
 185     in
 186
 187     try
 188       if read_response ic <> 220 then bad_response ();
 189
 190       send1 oc "EHLO" (gethostname ());
 191       if read_response_auth ic <> 250 then bad_response ();
 192
 193       if mail.smtp_login <> "" then
 194       begin
 195         if !auth_cram_enabled then (* prefer CRAM-MD5 *)
 196         begin
 197           send oc "AUTH CRAM-MD5";
 198           match get_response ic with
 199           | (334,true,s) ->
 200             (* RFC 2195 *)
 201             let digest = hmac_md5 mail.smtp_password (Base64.decode s) in
 202             send oc (Base64.encode (Printf.sprintf "%s %s" mail.smtp_login digest));
 203             if read_response ic <> 235 then bad_response ()
 204           | _ -> bad_response ()
 205         end
 206         else if !auth_login_enabled then
 207         begin
 208           send oc "AUTH LOGIN";
 209           if read_response ic <> 334 then bad_response ();
 210
 211           send oc (Base64.encode mail.smtp_login);
 212           if read_response ic <> 334 then bad_response ();
 213
 214           send oc (Base64.encode mail.smtp_password);
 215           if read_response ic <> 235 then bad_response ()
 216         end
 217         else if !auth_plain_enabled then
 218         begin
 219           let auth = Printf.sprintf "\x00%s\x00%s" mail.smtp_login mail.smtp_password in
 220           send1 oc "AUTH PLAIN" (Base64.encode auth);
 221           if read_response ic <> 235 then bad_response ()
 222         end
 223       end;
 224
 225       send1 oc "MAIL FROM:" (mail_address new_style (canon_addr mail.mail_from));
 226       if read_response ic <> 250 then bad_response ();
 227
 228       send1 oc "RCPT TO:" (mail_address new_style (canon_addr mail.mail_to));
 229       if read_response ic <> 250 then bad_response ();
 230
 231       send oc "DATA";
 232       if read_response ic <> 354 then bad_response ();
 233
 234       let body = make_mail mail new_style in
 235       send oc body;
 236       send oc ".";
 237       if read_response ic <> 250 then bad_response ();
 238
 239       send oc "QUIT";
 240       if read_response ic <> 221 then bad_response ();
 241
 242       close_out oc;
 243     with e ->
 244         send oc "QUIT";
 245         if read_response ic <> 221 then bad_response ();
 246         close_out oc;
 247         raise e
 248
 249   with e ->
 250       lprintf_nl "Exception %s while sending mail" (Printexc2.to_string e)