POP3 to mailbox in caml

From: Christophe Raffalli (raffalli@univ-savoie.fr)
Date: Sat Mar 07 1998 - 12:32:53 MET


Date: Sat, 07 Mar 1998 12:32:53 +0100
From: Christophe Raffalli <raffalli@univ-savoie.fr>
To: caml-list@inria.fr
Subject: POP3 to mailbox in caml

This is a multi-part message in MIME format.

--------------17207467FD095AE479B6DBC
Content-Type: text/plain; charset=iso-8859-1
Content-Transfer-Encoding: quoted-printable

Hello,

Here is an example of a small programme that retrive your mail from a
POP3 server to add then in a standard unix mailbox file. I think it is
an intersting exemple, and it even may be usefull in some situation !

Although it works for me, it may have bugs ... use it at your own risk !

To compile the program, just type

ocamlc -o popget -custom unix.cma popget.ml -cclib -lunix

To use it type

popget server_name [-d] [-p port_number] [-l userid] [-P password] [-m
mailbox] [-b] [-s sec]

where
  server_name : is the name of the pop3 server
  -d : means delete message from serve (default is none)
  -p port: specify the pop3 port (default 110)
  -l userid: specify the pop3 user name (default $USER)
  -P passwd: specify the pop3 passwd (default "")
  -m mailbox: specify the unix mailbox (default /var/spool/mail/$USER)
  -b : run in background and check mail periodicaly (default false)
  -s time : when -b is given: the number of seconds between chack
(default 300)

-- =

Christophe Raffalli
Laboratoire de Mathématique / LAMA
Université de Savoie
UFR SFA, Campus Scientifique
73376, Le Bourget du Lac CEDEX, FRANCE.

URL: http://www.logique.jussieu.fr/www.raffalli
email: Christophe.Raffalli@univ-savoie.fr

--------------17207467FD095AE479B6DBC
Content-Type: text/plain; charset=us-ascii; name="popget.ml"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline; filename="popget.ml"

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 ()

--------------17207467FD095AE479B6DBC--



This archive was generated by hypermail 2b29 : Sun Jan 02 2000 - 11:58:13 MET