open Unix
module SMTP = struct
let _ = Random.self_init ()
type mail = {
mail_to : string list;
mail_cc : string list ;
mail_from : string;
mail_subject : string;
mail_body : string;
}
let simple_connect hostname port =
let s = socket PF_INET SOCK_STREAM 0 in
let h = Unix.gethostbyname hostname in
let addr = h.h_addr_list.(0) in
try
Unix.connect s (ADDR_INET(addr,port));
s
with e -> close s; raise e
let last_response = ref ""
let bad_response () =
failwith (Printf.sprintf "Bad response [%s]"
(String.escaped !last_response))
let read_response ic =
last_response := input_line ic;
if String.length !last_response > 3 then
int_of_string (String.sub !last_response 0 3)
else
bad_response ()
let escape_single_dot_on_line s =
let len = String.length s in
let b = Buffer.create len in
let state = ref 1 in
let a = Buffer.add_char b in
for i = 0 to len - 1 do
match s.[i] with
'\n' | '\r' when !state = 0 -> state := 1; a s.[i]
| '\n' | '\r' when !state = 1 -> state := 1; a s.[i]
| '\n' | '\r' when !state = 2 -> a ' '; state := 1; a s.[i]
| '.' when !state = 1 -> state := 2; a '.'
| c -> state := 0; a c
done;
Buffer.contents b
let make_mail mail =
let mes_id =
let t = Unix.localtime (Unix.time ()) in
let n = Random.int 100000000 in
Printf.sprintf "<%04d-%02d-%02d-%02d:%02d:%02d.%08d-share-library@ocaml.org>"
(t.Unix.tm_year + 1900)
(t.Unix.tm_mon + 1)
t.Unix.tm_mday
t.Unix.tm_hour
t.Unix.tm_min
t.Unix.tm_sec
n
in
(mes_id,
Printf.sprintf
"Content-Type: text/plain; charset=iso-8859-1\r\nContent-Transfer-Encoding: 8bit\r\nFrom: %s\r\nTo: %s\r\n%sSubject: %s\r\nMIME-Version: 1.0\r\nMessage-ID: %s\r\n\r\n%s"
mail.mail_from
(String.concat "," mail.mail_to)
(match mail.mail_cc with
[] -> ""
| l -> Printf.sprintf "Cc: %s\r\n" (String.concat "," l)
)
mail.mail_subject
mes_id
(escape_single_dot_on_line mail.mail_body)
)
let canon_addr s =
let len = String.length s in
let rec iter_end s pos =
if pos = -1 then s else
if s.[pos] = ' ' then iter_end s (pos-1) else
iter_begin s (pos-1) pos
and iter_begin s pos last =
if pos = -1 || s.[pos] = ' ' then
String.sub s (pos+1) (last - pos)
else iter_begin s (pos-1) last
in
iter_end s (len - 1)
let sendmail smtp_server smtp_port mail =
try
let s = simple_connect smtp_server smtp_port in
let ic = in_channel_of_descr s in
let oc = out_channel_of_descr s in
try
if read_response ic <> 220 then bad_response ();
Printf.fprintf oc "HELO %s\r\n" (gethostname ()); flush oc;
if read_response ic <> 250 then bad_response ();
Printf.fprintf oc "MAIL FROM:%s\r\n" (canon_addr mail.mail_from);
flush oc;
if read_response ic <> 250 then bad_response ();
List.iter
(fun addr ->
Printf.fprintf oc "RCPT TO:%s\r\n" (canon_addr addr); flush oc;
if read_response ic <> 250 then bad_response ()
)
(mail.mail_to @ mail.mail_cc);
Printf.fprintf oc "DATA\r\n"; flush oc;
if read_response ic <> 354 then bad_response ();
let (mes_id, body) = make_mail mail in
Printf.fprintf oc "%s\r\n.\r\n" body; flush oc;
if read_response ic <> 250 then bad_response ();
Printf.fprintf oc "QUIT\r\n"; flush oc;
if read_response ic <> 221 then bad_response ();
close_out oc;
mes_id
with e ->
Printf.fprintf oc "QUIT\r\n"; flush oc;
if read_response ic <> 221 then bad_response ();
close_out oc;
raise e
with e ->
raise (Failure (Printexc.to_string e))
end
module Mhmail = struct
type mail = {
mail_to : string list;
mail_cc : string list ;
mail_from : string;
mail_subject : string;
mail_body : string;
}
let sendmail ?(bin="mhmail") mail =
let b = Buffer.create 128 in
let q = Filename.quote in
Buffer.add_string b bin;
Printf.bprintf b " -from %s" (q mail.mail_from);
Printf.bprintf b " -subject %s" (q mail.mail_subject);
Printf.bprintf b " -body %s" (q mail.mail_body);
let print_addr_list =
List.iter (fun addr -> Printf.bprintf b " %s" (q addr))
in
print_addr_list mail.mail_to;
(
match mail.mail_cc with
[] -> ()
| l ->
Buffer.add_string b " -cc";
print_addr_list l
);
Buffer.add_string b " 2>&1";
let com = Buffer.contents b in
Buffer.reset b;
let buf_size = 2048 in
let buf = String.create buf_size in
try
let ic = Unix.open_process_in com in
let rec iter () =
match Pervasives.input ic buf 0 buf_size with
0 -> ()
| n -> Buffer.add_substring b buf 0 n;
iter ()
in
iter ();
let output =
match Buffer.contents b with "" -> "" | s -> "\n"^s
in
match Unix.close_process_in ic with
Unix.WEXITED 0 -> ()
| Unix.WEXITED n ->
let msg = Printf.sprintf "Command %s exited with code %d%s"
com n output
in
failwith msg
| Unix.WSTOPPED n ->
let msg = Printf.sprintf "Command %s stopped by signal %d%s"
com n output
in
failwith msg
| Unix.WSIGNALED n ->
let msg = Printf.sprintf "Command %s killed by signal %d%s"
com n output
in
failwith msg
with
Unix.Unix_error (e,s1,s2) ->
let msg = Printf.sprintf "%s: %s %s"
(Unix.error_message e) s1 s2
in
failwith msg
| e ->
let s = Printexc.to_string e in
failwith s
end
module Sendmail = struct
let _ = Random.self_init ()
type mail = {
mail_to : string list;
mail_cc : string list ;
mail_from : string;
mail_subject : string;
mail_body : string;
}
let escape_single_dot_on_line s =
let len = String.length s in
let b = Buffer.create len in
let state = ref 1 in
let a = Buffer.add_char b in
for i = 0 to len - 1 do
match s.[i] with
'\n' | '\r' when !state = 0 -> state := 1; a s.[i]
| '\n' | '\r' when !state = 1 -> state := 1; a s.[i]
| '\n' | '\r' when !state = 2 -> a ' '; state := 1; a s.[i]
| '.' when !state = 1 -> state := 2; a '.'
| c -> state := 0; a c
done;
Buffer.contents b
let make_mail mail =
let mes_id =
let t = Unix.localtime (Unix.time ()) in
let n = Random.int 100000000 in
Printf.sprintf "<%04d-%02d-%02d-%02d:%02d:%02d.%08d-share-library@ocaml.org>"
(t.Unix.tm_year + 1900)
(t.Unix.tm_mon + 1)
t.Unix.tm_mday
t.Unix.tm_hour
t.Unix.tm_min
t.Unix.tm_sec
n
in
let mes =
Printf.sprintf
"Content-Type: text/plain; charset=iso-8859-1\r\nContent-Transfer-Encoding: 8bit\r\nFrom: %s\r\nTo: %s\r\n%sSubject: %s\r\nMIME-Version: 1.0\r\nMessage-ID: %s\r\n\r\n%s"
mail.mail_from
(String.concat "," mail.mail_to)
(match mail.mail_cc with
[] -> ""
| l -> Printf.sprintf "Cc: %s\r\n" (String.concat "," l)
)
mail.mail_subject
mes_id
(escape_single_dot_on_line mail.mail_body)
in
(mes_id, mes)
let canon_addr s =
let len = String.length s in
let rec iter_end s pos =
if pos = -1 then s else
if s.[pos] = ' ' then iter_end s (pos-1) else
iter_begin s (pos-1) pos
and iter_begin s pos last =
if pos = -1 || s.[pos] = ' ' then
String.sub s (pos+1) (last - pos)
else iter_begin s (pos-1) last
in
iter_end s (len - 1)
let sendmail ?(bin="sendmail") mail =
try
let com = Printf.sprintf "%s -t %s"
bin (String.concat " " (List.map Filename.quote mail.mail_to))
in
let oc = Unix.open_process_out com in
let (mes_id, mes) = make_mail mail in
output_string oc mes;
match Unix.close_process_out oc with
Unix.WEXITED 0 -> mes_id
| Unix.WEXITED n ->
let msg = Printf.sprintf "Command %s exited with code %d"
com n
in
failwith msg
| Unix.WSTOPPED n ->
let msg = Printf.sprintf "Command %s stopped by signal %d"
com n
in
failwith msg
| Unix.WSIGNALED n ->
let msg = Printf.sprintf "Command %s killed by signal %d"
com n
in
failwith msg
with
Unix.Unix_error (e,s1,s2) ->
let msg = Printf.sprintf "%s: %s %s"
(Unix.error_message e) s1 s2
in
failwith msg
| e ->
let s = Printexc.to_string e in
failwith s
end