open Unix

(*
ocamlc -o popget-custom unix.cma popget.ml -cclib -lunix
*)

let usage () =
  prerr_string Sys.argv.(0);
  prerr_string " server_name [-d] [-p port_number] [-l userid] [-P password] [-m mailbox]";
  prerr_newline();  
  exit 1

let bug str = 
  prerr_string Sys.argv.(0);
  prerr_string ": bug: ";
  prerr_endline str;
  exit 1

let error str = 
  prerr_string Sys.argv.(0);
  prerr_string ": error: ";
  prerr_endline str;
  usage ()

let establish_connection name port =
  try 
    let address =
      let host = gethostbyname name in
      ADDR_INET (host.h_addr_list.(0), port)
    in
    let a_socket = socket PF_INET SOCK_STREAM 0 in
    connect a_socket address; 
    a_socket
  with 
    Unix_error(errno,fun_name,par) ->
      error (fun_name^": "^(error_message errno))
  | Not_found ->
      error ("can not connect to POP3 server \""^name^"\"")

let server_name, mailbox_name, user_name, passwd, port, delete, verbose,
    background, sleep_time =
  let i = ref 1 in
  let port = ref 110 in
  let delete = ref false in
  let mailbox_name = ref 
      (try Filename.concat (Sys.getenv "HOME") "Inbox" 
      with Not_found -> "Inbox")
  in
  let user_name  = ref 
      (try Sys.getenv "USER" 
      with Not_found -> "anonymous")
  in
  let passwd = ref "" in
  let server_name = ref "mail" in
  let verbose = ref false in
  let background = ref false in
  let sleep_time = ref 300 in
  let l = Array.length Sys.argv in
  while (!i < l) do
    match Sys.argv.(!i) with
      "-p" ->
	incr i;
	if (!i >= l) then usage ();
	(try port := int_of_string Sys.argv.(!i)
	with Failure _ -> usage ());
	incr i
    |  "-l" ->
	incr i;
	if (!i >= l) then usage ();
	user_name := Sys.argv.(!i);
	incr i
    |  "-m" ->
	incr i;
	if (!i >= l) then usage ();
	mailbox_name := Sys.argv.(!i);
	incr i
    |  "-P" ->
	incr i;
	if (!i >= l) then usage ();
	passwd := Sys.argv.(!i);
	incr i
    | "-d" ->
	incr i;
	delete := true
    | "-v" ->
	incr i;
	verbose := true
    | "-b" ->
	incr i;
	background := true
    | "-s" ->
	incr i;
	if (!i >= l) then usage ();
	(try sleep_time := int_of_string Sys.argv.(!i)
	with Failure _ -> usage ());
	incr i
    |  name ->
	incr i; 
	server_name := name
  done;
  !server_name, !mailbox_name, !user_name, !passwd, !port, !delete, !verbose,
  !background, !sleep_time

open Genlex 

let lexer = make_lexer [] 

let tokens str = lexer (Stream.of_string str)

let days = [|"Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"|]

let months = [|"Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; 
	       "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec"|]

let go () =
  let channel = establish_connection server_name port  in
  let out_ch = out_channel_of_descr channel in
  let in_ch = in_channel_of_descr channel in
  let get_line () = 
    let line = input_line in_ch in
    let len = String.length line in
    if line.[len-1] <> '\r' then bug "badly terminated line";
    let line = String.sub line 0 (len-1) in
    if verbose then (print_string line; print_newline ());
    line
  in
  let compare_line str =
    let line = get_line () in
    if String.length line < String.length str
      	or String.sub line 0 (String.length str) <> str then
      error ("expected \""^str^"\", got \""^line)
    else line
  in
  let send str =
    output_string out_ch str; 
    output_char out_ch '\n'; 
    flush out_ch
  in
  compare_line "+OK POP3";
  send ("USER "^user_name);
  compare_line "+OK";
  send ("PASS "^passwd);
  compare_line "+OK";
  send "STAT";
  let num = match tokens (compare_line "+OK") with parser
    [<'Ident "+"; 'Ident "OK"; 'Int num; 'Int size >] -> 
      Printf.printf "%d new messages (%d octets)\n" num size;
      num
  | [< >] ->
      bug "bad answer to STAT"
  in
  send "LIST";
  compare_line "+OK";
  let msgs = Array.create num 0 in
  for i = 0 to num - 1 do
    match tokens (get_line ()) with parser
    [<'Int id; 'Int size >] -> 
      msgs.(i) <- id
  | [< >] ->
      bug "illegal line in LIST command."
  done;
  compare_line ".";
  let mailbox = 
    try
      open_out_gen [Open_binary; Open_wronly; Open_append; Open_creat] 
	0o600 mailbox_name 
    with
      Sys_error errmsg ->
        error (mailbox_name^" could not be opened: "^errmsg)
  in
  for i = 0 to num - 1 do
    Printf.printf "getting message %d\n" msgs.(i);
    send ("RETR "^string_of_int msgs.(i)); 
    compare_line "+OK"; 
    let tm = localtime (time ()) in
    sleep 1;
    Printf.fprintf mailbox "From - %s %s %d %2d:%2d:%2d %d\n"
      days.(tm.tm_wday) months.(tm.tm_mon) 
      tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec tm.tm_year;
    let cont = ref true in
    while !cont do
      let line = get_line () in
      if line = "." then 
	cont := false
      else begin
	output_string mailbox line; 
	output_string mailbox "\n"
      end
    done;
    output_string mailbox "\n\n"    
  done;
  close_out mailbox;
  if delete then begin
    for i = 0 to num - 1 do
      Printf.printf "deleting message %d\n" msgs.(i);
      send ("DELE "^string_of_int msgs.(i));
      compare_line "+OK"
    done
  end;
  send "QUIT";
  try 
    compare_line "+OK"; ()
  with End_of_file ->
    send "QUIT";
    try 
      compare_line "+OK"; ()
    with End_of_file -> ()

let _ = 
  if background then
    while true do
      go ();
      sleep sleep_time
    done
  else go ()