(* $Id: netsmtp.ml 1614 2011-06-09 15:08:56Z gerd $ * ---------------------------------------------------------------------- * * This is an implementation of the Simple Mail Transfer Protocol (SMTP) * as specifed by RFC-2821. *) open Netchannels open Unix exception Protocol_error exception Transient_error of int * string exception Permanent_error of int * string let tcp_port = 25 (* Helpers *) let trim s l r = String.sub s l (String.length s - r - l) let join = String.concat "\n" let none = function _ -> false let void = function _ -> () let ok2 i j x = x = i || x = j let okl l x = List.mem x l let read_status ic = let rec read acc = let l = ic # input_line () in if l.[3] = '-' then read ((trim l 4 1)::acc) else (int_of_char l.[0] - int_of_char '0') , int_of_string (String.sub l 0 3) , List.rev ((trim l 4 1)::acc) in read [] let handle_answer ic = let flag, code, msg = read_status ic in match flag with | 2 | 3 -> code, msg | 4 -> raise (Transient_error (code, join msg)) | 5 -> raise (Permanent_error (code, join msg)) | _ -> raise Protocol_error let ignore_answer ic = ignore (handle_answer ic) (* class *) class client (ic : in_obj_channel) (oc : out_obj_channel) = object (self) initializer ignore_answer ic method private smtp_cmd cmd = oc # output_string cmd; oc # output_string "\r\n"; oc # flush () method helo ?host () = oc # output_string "EHLO "; self # smtp_cmd ( match host with | None -> (Uq_resolver.get_host_by_name (gethostname ())).h_name | Some s -> s ); snd (handle_answer ic) method mail email = self # smtp_cmd (Printf.sprintf "MAIL FROM: <%s>" email); ignore_answer ic method rcpt email = self # smtp_cmd (Printf.sprintf "RCPT TO: <%s>" email); try ignore_answer ic with Permanent_error (551, msg) -> self # rcpt msg method data (chan:in_obj_channel) = self # smtp_cmd "DATA"; ignore_answer ic; ( try while true do let l = chan # input_line () in if String.length l > 0 && l.[0] = '.' then oc # output_char '.'; oc # output_string l; oc # output_string (if String.length l > 0 && l.[String.length l - 2] = '\r' then "\n" else "\r\n") done; assert false with End_of_file -> () ); self # smtp_cmd "."; ignore_answer ic method rset () = self # smtp_cmd "RSET"; ignore_answer ic method expn ml = oc # output_string "EXPN "; self # smtp_cmd ml; match handle_answer ic with | 250, msg -> Some msg | _ -> None method help () = self # smtp_cmd "HELP"; snd (handle_answer ic) method noop () = self # smtp_cmd "NOOP"; ignore_answer ic method quit () = self # smtp_cmd "QUIT"; ignore_answer ic end