├── .gitignore ├── CHANGES ├── Makefile ├── README ├── TODO ├── _tags ├── opam ├── pkg ├── META ├── build.ml └── topkg.ml ├── src ├── smtp.ml ├── smtp.mli ├── smtp_lwt.ml ├── smtp_lwt.mli ├── smtp_unix.ml └── smtp_unix.mli └── test ├── test_lwt.ml └── test_unix.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.native 4 | *.byte 5 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | 0.2 (2014-04-24): 2 | * Functor output signature is now explicit 3 | * Build system switched to topkg+ocamlbuild 4 | 5 | 0.1 (2013-06-10): 6 | * first alpha release 7 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PKG=smtp 2 | PREFIX=`opam config var prefix` 3 | BUILDOPTS=native=true native-dynlink=true unix=true lwt=true 4 | 5 | all: build 6 | 7 | build: 8 | ocaml pkg/build.ml $(BUILDOPTS) 9 | 10 | install: build 11 | opam-installer --prefix=$(PREFIX) $(PKG).install 12 | 13 | uninstall: $(PKG).install 14 | opam-installer -u --prefix=$(PREFIX) $(PKG).install 15 | 16 | PHONY: clean 17 | 18 | clean: 19 | ocamlbuild -clean 20 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | SMTP lib for OCaml 2 | ================== 3 | 4 | * Rewritten from scratch. 5 | * Functorized, Unix and Lwt backends. 6 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | * Async backend ? 2 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | <**/*.{ml,mli}> : bin_annot 2 | : include 3 | : include 4 | : package(lwt) 5 | : use_unix 6 | : package(lwt.unix) 7 | : use_unix 8 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1" 2 | maintainer: "Vincent Bernardoff " 3 | authors: ["Vincent Bernardoff "] 4 | license: "ISC" 5 | tags: [ "smtp" ] 6 | depends: ["ocamlfind"] 7 | depopts: ["lwt"] 8 | build: 9 | [ 10 | [ "ocaml" "pkg/build.ml" "native=%{ocaml-native}%" 11 | "native-dynlink=%{ocaml-native}%" 12 | "unix=%{base-unix:installed}%" 13 | "lwt=%{lwt:installed}%" 14 | ] 15 | ] 16 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | version = "0.2" 2 | description = "SMTP client library" 3 | archive(byte) = "smtp.cma" 4 | archive(byte, plugin) = "smtp.cma" 5 | archive(native) = "smtp.cmxa" 6 | archive(native, plugin) = "smtp.cmxs" 7 | exists_if = "smtp.cma" 8 | 9 | package "unix" ( 10 | version = "0.2" 11 | description = "SMTP client library for Unix" 12 | requires = "smtp unix" 13 | archive(byte) = "smtp_unix.cma" 14 | archive(byte, plugin) = "smtp_unix.cma" 15 | archive(native) = "smtp_unix.cmxa" 16 | archive(native, plugin) = "smtp_unix.cmxs" 17 | exists_if = "smtp_unix.cma" 18 | ) 19 | 20 | package "lwt" ( 21 | version = "0.2" 22 | description = "SMTP client library for Lwt" 23 | requires = "smtp lwt.unix" 24 | archive(byte) = "smtp_lwt.cma" 25 | archive(byte, plugin) = "smtp_lwt.cma" 26 | archive(native) = "smtp_lwt.cmxa" 27 | archive(native, plugin) = "smtp_lwt.cmxs" 28 | exists_if = "smtp_lwt.cma" 29 | ) 30 | -------------------------------------------------------------------------------- /pkg/build.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #directory "pkg" 3 | #use "topkg.ml" 4 | 5 | let unix = Env.bool "unix" 6 | let lwt = Env.bool "lwt" 7 | let () = 8 | Pkg.describe "smtp" ~builder:`OCamlbuild [ 9 | Pkg.lib "pkg/META"; 10 | Pkg.lib ~exts:Exts.module_library "src/smtp"; 11 | Pkg.lib ~cond:lwt ~exts:Exts.module_library "src/smtp_lwt"; 12 | Pkg.lib ~cond:unix ~exts:Exts.module_library "src/smtp_unix"; 13 | Pkg.bin ~cond:lwt ~auto:true ~dst:"smtp_test_lwt" "test/test_lwt"; 14 | Pkg.bin ~cond:unix ~auto:true ~dst:"smtp_test_unix" "test/test_unix"; 15 | ] 16 | -------------------------------------------------------------------------------- /pkg/topkg.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2014 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the BSD3 license, see license at the end of the file. 4 | %%NAME%% release %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (* Public api *) 8 | 9 | (** Build environment access *) 10 | module type Env = sig 11 | val bool : string -> bool 12 | (** [bool key] declares [key] as being a boolean key in the environment. 13 | Specifing key=(true|false) on the command line becomes mandatory. *) 14 | 15 | val native : bool 16 | (** [native] is [bool "native"]. *) 17 | 18 | val native_dynlink : bool 19 | (** [native_dylink] is [bool "native-dynlink"] *) 20 | end 21 | 22 | (** Exts defines sets of file extensions. *) 23 | module type Exts = sig 24 | val interface : string list 25 | (** [interface] is [[".mli"; ".cmi"; ".cmti"]] *) 26 | 27 | val interface_opt : string list 28 | (** [interface_opt] is [".cmx" :: interface] *) 29 | 30 | val library : string list 31 | (** [library] is [[".cma"; ".cmxa"; ".cmxs"; ".a"]] *) 32 | 33 | val module_library : string list 34 | (** [module_library] is [(interface_opt @ library)]. *) 35 | end 36 | 37 | (** Package description. *) 38 | module type Pkg = sig 39 | type builder = [ `OCamlbuild | `Other of string * string ] 40 | (** The type for build tools. Either [`OCamlbuild] or an 41 | [`Other (tool, bdir)] tool [tool] that generates its build artefacts 42 | in [bdir]. *) 43 | 44 | type moves 45 | (** The type for install moves. *) 46 | 47 | type field = ?cond:bool -> ?exts:string list -> ?dst:string -> string -> moves 48 | (** The type for field install functions. A call 49 | [field cond exts dst path] generates install moves as follows: 50 | {ul 51 | {- If [cond] is [false] (defaults to [true]), no move is generated.} 52 | {- If [exts] is present, generates a move for each path in 53 | the list [List.map (fun e -> path ^ e) exts].} 54 | {- If [dst] is present this path is used as the move destination 55 | (allows to install in subdirectories). If absent [dst] is 56 | [Filename.basename path].} *) 57 | 58 | val lib : field 59 | val bin : ?auto:bool -> field 60 | (** If [auto] is true (defaults to false) generates 61 | [path ^ ".native"] if {!Env.native} is [true] and 62 | [path ^ ".byte"] if {!Env.native} is [false]. *) 63 | val sbin : ?auto:bool -> field (** See {!bin}. *) 64 | val toplevel : field 65 | val share : field 66 | val share_root : field 67 | val etc : field 68 | val doc : field 69 | val misc : field 70 | val stublibs : field 71 | val man : field 72 | val describe : string -> builder:builder -> moves list -> unit 73 | (** [describe name builder moves] describes a package named [name] with 74 | builder [builder] and install moves [moves]. *) 75 | end 76 | 77 | (* Implementation *) 78 | 79 | module Topkg : sig 80 | val cmd : [`Build | `Explain | `Help ] 81 | val env : (string * bool) list 82 | val err_parse : string -> 'a 83 | val err_mdef : string -> 'a 84 | val err_miss : string -> 'a 85 | val err_file : string -> string -> 'a 86 | val warn_unused : string -> unit 87 | end = struct 88 | 89 | (* Parses the command line. The actual cmd execution occurs in the call 90 | to Pkg.describe. *) 91 | 92 | let err fmt = 93 | let k _ = exit 1 in 94 | Format.kfprintf k Format.err_formatter ("%s: " ^^ fmt ^^ "@.") Sys.argv.(0) 95 | 96 | let err_parse a = err "argument `%s' is not of the form key=(true|false)" a 97 | let err_mdef a = err "bool `%s' is defined more than once" a 98 | let err_miss a = err "argument `%s=(true|false)' is missing" a 99 | let err_file f e = err "%s: %s" f e 100 | let warn_unused k = 101 | Format.eprintf "%s: warning: environment key `%s` unused.@." Sys.argv.(0) k 102 | 103 | let cmd, env = 104 | let rec parse_env acc = function (* not t.r. *) 105 | | arg :: args -> 106 | begin try 107 | (* String.cut ... *) 108 | let len = String.length arg in 109 | let eq = String.index arg '=' in 110 | let bool = bool_of_string (String.sub arg (eq + 1) (len - eq - 1)) in 111 | let key = String.sub arg 0 eq in 112 | if key = "" then raise Exit else 113 | try ignore (List.assoc key acc); err_mdef key with 114 | | Not_found -> parse_env ((key, bool) :: acc) args 115 | with 116 | | Invalid_argument _ | Not_found | Exit -> err_parse arg 117 | end 118 | | [] -> acc 119 | in 120 | match List.tl (Array.to_list Sys.argv) with 121 | | "explain" :: args -> `Explain, parse_env [] args 122 | | ("help" | "-h" | "--help" | "-help") :: args -> `Help, parse_env [] args 123 | | args -> `Build, parse_env [] args 124 | end 125 | 126 | module Env : sig 127 | include Env 128 | val get : unit -> (string * bool) list 129 | end = struct 130 | let env = ref [] 131 | let get () = !env 132 | let add_bool key b = env := (key, b) :: !env 133 | let bool key = 134 | let b = try List.assoc key Topkg.env with 135 | | Not_found -> if Topkg.cmd = `Build then Topkg.err_miss key else true 136 | in 137 | add_bool key b; b 138 | 139 | let native = bool "native" 140 | let native_dynlink = bool "native-dynlink" 141 | end 142 | 143 | module Exts : Exts = struct 144 | let interface = [".mli"; ".cmi"; ".cmti"] 145 | let interface_opt = ".cmx" :: interface 146 | let library = [".cma"; ".cmxa"; ".cmxs"; ".a"] 147 | let module_library = (interface_opt @ library) 148 | end 149 | 150 | module Pkg : Pkg = struct 151 | type builder = [ `OCamlbuild | `Other of string * string ] 152 | type moves = (string * (string * string)) list 153 | type field = ?cond:bool -> ?exts:string list -> ?dst:string -> string -> moves 154 | 155 | let str = Printf.sprintf 156 | let warn_unused () = 157 | let keys = List.map fst Topkg.env in 158 | let keys_used = List.map fst (Env.get ()) in 159 | let unused = List.find_all (fun k -> not (List.mem k keys_used)) keys in 160 | List.iter Topkg.warn_unused unused 161 | 162 | let has_suffix = Filename.check_suffix 163 | let build_strings ?(exec_sep = " ") btool bdir mvs = 164 | let no_build = [ ".cmti"; ".cmt" ] in 165 | let install = Buffer.create 1871 in 166 | let exec = Buffer.create 1871 in 167 | let rec add_mvs current = function 168 | | (field, (src, dst)) :: mvs when field = current -> 169 | if List.exists (has_suffix src) no_build then 170 | Buffer.add_string install (str "\n \"?%s/%s\" {\"%s\"}" bdir src dst) 171 | else begin 172 | Buffer.add_string exec (str "%s%s" exec_sep src); 173 | Buffer.add_string install (str "\n \"%s/%s\" {\"%s\"}" bdir src dst); 174 | end; 175 | add_mvs current mvs 176 | | (((field, _) :: _) as mvs) -> 177 | if current <> "" (* first *) then Buffer.add_string install " ]\n"; 178 | Buffer.add_string install (str "%s: [" field); 179 | add_mvs field mvs 180 | | [] -> () 181 | in 182 | Buffer.add_string exec btool; 183 | add_mvs "" mvs; 184 | Buffer.add_string install " ]\n"; 185 | Buffer.contents install, Buffer.contents exec 186 | 187 | let pr = Format.printf 188 | let pr_explanation btool bdir pkg mvs = 189 | let env = Env.get () in 190 | let install, exec = build_strings ~exec_sep:" \\\n " btool bdir mvs in 191 | pr "@["; 192 | pr "Package name: %s@," pkg; 193 | pr "Build tool: %s@," btool; 194 | pr "Build directory: %s@," bdir; 195 | pr "Environment:@, "; 196 | List.iter (fun (k,v) -> pr "%s=%b@, " k v) (List.sort compare env); 197 | pr "@,Build invocation:@,"; 198 | pr " %s@,@," exec; 199 | pr "Install file:@,"; 200 | pr "%s@," install; 201 | pr "@]"; 202 | () 203 | 204 | let pr_help () = 205 | pr "Usage example:@\n %s" Sys.argv.(0); 206 | List.iter (fun (k,v) -> pr " %s=%b" k v) (List.sort compare (Env.get ())); 207 | pr "@." 208 | 209 | let build btool bdir pkg mvs = 210 | let install, exec = build_strings btool bdir mvs in 211 | let e = Sys.command exec in 212 | if e <> 0 then exit e else 213 | let install_file = pkg ^ ".install" in 214 | try 215 | let oc = open_out install_file in 216 | output_string oc install; flush oc; close_out oc 217 | with Sys_error e -> Topkg.err_file install_file e 218 | 219 | let mvs ?(drop_exts = []) field ?(cond = true) ?(exts = []) ?dst src = 220 | if not cond then [] else 221 | let mv src dst = (field, (src, dst)) in 222 | let expand exts s d = List.map (fun e -> mv (s ^ e) (d ^ e)) exts in 223 | let dst = match dst with None -> Filename.basename src | Some dst -> dst in 224 | let files = if exts = [] then [mv src dst] else expand exts src dst in 225 | let keep (_, (src, _)) = not (List.exists (has_suffix src) drop_exts) in 226 | List.find_all keep files 227 | 228 | let lib = 229 | let drop_exts = 230 | if Env.native && not Env.native_dynlink then [ ".cmxs" ] else 231 | if not Env.native then [ ".a"; ".cmx"; ".cmxa"; ".cmxs" ] else [] 232 | in 233 | mvs ~drop_exts "lib" 234 | 235 | let share = mvs "share" 236 | let share_root = mvs "share_root" 237 | let etc = mvs "etc" 238 | let toplevel = mvs "toplevel" 239 | let doc = mvs "doc" 240 | let misc = mvs "misc" 241 | let stublibs = mvs "stublib" 242 | let man = mvs "man" 243 | 244 | let bin_drops = if not Env.native then [ ".native" ] else [] 245 | let bin_mvs field ?(auto = false) ?cond ?exts ?dst src = 246 | let src, dst = 247 | if not auto then src, dst else 248 | let dst = match dst with 249 | | None -> Some (Filename.basename src) 250 | | Some _ as dst -> dst 251 | in 252 | let src = if Env.native then src ^ ".native" else src ^ ".byte" in 253 | src, dst 254 | in 255 | mvs ~drop_exts:bin_drops field ?cond ?dst src 256 | 257 | let bin = bin_mvs "bin" 258 | let sbin = bin_mvs "sbin" 259 | 260 | let describe pkg ~builder mvs = 261 | let mvs = List.sort compare (List.flatten mvs) in 262 | let btool, bdir = match builder with 263 | | `OCamlbuild -> "ocamlbuild -use-ocamlfind -classic-display", "_build" 264 | | `Other (btool, bdir) -> btool, bdir 265 | in 266 | match Topkg.cmd with 267 | | `Explain -> pr_explanation btool bdir pkg mvs 268 | | `Help -> pr_help () 269 | | `Build -> warn_unused (); build btool bdir pkg mvs 270 | end 271 | 272 | (*--------------------------------------------------------------------------- 273 | Copyright (c) 2014 Daniel C. Bünzli. 274 | All rights reserved. 275 | 276 | Redistribution and use in source and binary forms, with or without 277 | modification, are permitted provided that the following conditions 278 | are met: 279 | 280 | 1. Redistributions of source code must retain the above copyright 281 | notice, this list of conditions and the following disclaimer. 282 | 283 | 2. Redistributions in binary form must reproduce the above 284 | copyright notice, this list of conditions and the following 285 | disclaimer in the documentation and/or other materials provided 286 | with the distribution. 287 | 288 | 3. Neither the name of Daniel C. Bünzli nor the names of 289 | contributors may be used to endorse or promote products derived 290 | from this software without specific prior written permission. 291 | 292 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 293 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 294 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 295 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 296 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 297 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 298 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 299 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 300 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 301 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 302 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 303 | ---------------------------------------------------------------------------*) 304 | -------------------------------------------------------------------------------- /src/smtp.ml: -------------------------------------------------------------------------------- 1 | module type IO = sig 2 | 3 | (** Monadic interface *) 4 | 5 | type 'a t 6 | val return : 'a -> 'a t 7 | val bind : 'a t -> ('a -> 'b t) -> 'b t 8 | val fail : exn -> 'a t 9 | (** Channel like communication *) 10 | 11 | type ic 12 | type oc 13 | 14 | val open_connection : host:string -> service:string -> (ic * oc) t 15 | val shutdown_connection : ic -> unit t 16 | 17 | val read_line : ic -> string t 18 | val print_line : oc -> string -> unit t 19 | end 20 | 21 | module type S = sig 22 | type 'a monad 23 | 24 | type handle 25 | (** Type of a handle to a SMTP connection. *) 26 | 27 | type request = 28 | [ 29 | | `Helo of string 30 | | `From of string 31 | | `To of string 32 | | `Data 33 | | `Msg_body of string 34 | | `Quit 35 | ] 36 | (** Type of a request. *) 37 | 38 | type response = 39 | [ 40 | | `Ok of int * string 41 | | `Failure of int * string 42 | ] 43 | (** Type of a response. *) 44 | 45 | module Addr : sig 46 | type t 47 | val of_string : string -> t 48 | val to_string : t -> string 49 | end 50 | (** Module for handling email addresses. *) 51 | 52 | exception Negative_reply of int * string 53 | (** Exception raised when the remote SMTP server returns a negative 54 | reply. *) 55 | 56 | val connect : ?host:string -> ?port:string -> name:string -> unit -> handle monad 57 | (** [open ~host ~port] is a promise of a handle to an open 58 | connection to the SMTP server located at [host:port]. *) 59 | 60 | val close : handle -> unit monad 61 | (** [close h] closes [h], cleanly exiting the connection to the SMTP 62 | server if needed. *) 63 | 64 | val request : handle -> request -> response monad 65 | (** [request h req] sends [req] to the SMTP server handled by 66 | [h]. *) 67 | 68 | val send : handle -> from:Addr.t -> to_:Addr.t list -> body:string 69 | -> response monad 70 | (** [send h ~from ~to_ ~body] use the SMTP handled by [h] to send a 71 | mail of body [~body] from address [~from] to addresses 72 | [~to_]. *) 73 | 74 | val sendmail : ?host:string -> ?port:string -> name:string -> from:Addr.t 75 | -> to_:Addr.t list -> body:string -> unit -> response monad 76 | (** [sendmail ~host ~port ~from ~to_ ~body] sends the mail of body 77 | [~body] from address [~from] to addresses [~to] using the SMTP 78 | server at address [host:port]. *) 79 | end 80 | 81 | module Make (IO : IO) = struct 82 | 83 | type 'a monad = 'a IO.t 84 | 85 | type handle = { ic:IO.ic; oc:IO.oc; name:string } 86 | 87 | type request = 88 | [ 89 | | `Helo of string 90 | | `From of string 91 | | `To of string 92 | | `Data 93 | | `Msg_body of string 94 | | `Quit 95 | ] 96 | (** Type of a request. *) 97 | 98 | type response = 99 | [ 100 | | `Ok of int * string 101 | | `Failure of int * string 102 | ] 103 | (** Type of a response. *) 104 | 105 | module Addr = struct 106 | type t = string 107 | let of_string addr = addr (* TODO: Check validity! *) 108 | let to_string addr = addr 109 | end 110 | 111 | exception Negative_reply of int * string 112 | 113 | let ( >>= ) = IO.bind 114 | 115 | let response_of_string str = 116 | let len = String.length str in 117 | let code = int_of_string (String.sub str 0 3) in 118 | let msg = String.sub str 4 (len - 4) in 119 | if str.[0] <> '5' && str.[0] <> '4' then `Ok (code, msg) 120 | else `Failure (code, msg) 121 | 122 | let connect ?(host="") ?(port="smtp") ~name () = 123 | IO.open_connection ~host ~service:port 124 | >>= fun (ic, oc) -> IO.read_line ic 125 | >>= fun str -> match (response_of_string str) with 126 | | `Ok (_,_) -> IO.return { ic; oc; name } 127 | | `Failure (code, msg) -> IO.fail (Negative_reply (code, msg)) 128 | 129 | let close h = IO.shutdown_connection h.ic 130 | 131 | let string_of_req = function 132 | | `Helo str -> "HELO " ^ str 133 | | `From addr -> "MAIL FROM:" ^ addr 134 | | `To addr -> "RCPT TO:" ^ addr 135 | | `Data -> "DATA" 136 | | `Msg_body str -> str ^ "\r\n." 137 | | `Quit -> "QUIT" 138 | 139 | let request h req = 140 | IO.print_line h.oc (string_of_req req) 141 | >>= fun () -> IO.read_line h.ic 142 | >>= fun resp -> IO.return (response_of_string resp) 143 | 144 | (* Stop executing commands after the first has failed *) 145 | let rec transaction hdl = function 146 | | [] -> raise (Invalid_argument "empty list") 147 | | [c] -> request hdl c 148 | | h::t -> (request hdl h >>= function 149 | | `Ok (_,_) -> transaction hdl t 150 | | `Failure (code, msg) -> IO.fail (Negative_reply (code, msg))) 151 | 152 | let send h ~from ~to_ ~body = 153 | let cmds = [`Helo h.name; `From from] @ 154 | (List.map (fun str -> `To str) to_) @ 155 | [`Data; `Msg_body body] in 156 | transaction h cmds 157 | 158 | let finally f g = 159 | try 160 | f () >>= fun ret -> g () >>= fun () -> IO.return ret 161 | with exn -> g () >>= fun () -> IO.fail exn 162 | 163 | let sendmail ?(host="") ?(port="smtp") ~name ~from ~to_ ~body () = 164 | connect ~host ~port ~name () >>= fun h -> 165 | finally 166 | (fun () -> send h ~from ~to_ ~body) 167 | (fun () -> IO.shutdown_connection h.ic) 168 | end 169 | -------------------------------------------------------------------------------- /src/smtp.mli: -------------------------------------------------------------------------------- 1 | module type IO = sig 2 | 3 | (** Monadic interface *) 4 | type 'a t 5 | val return : 'a -> 'a t 6 | val bind : 'a t -> ('a -> 'b t) -> 'b t 7 | val fail : exn -> 'a t 8 | 9 | (** Channel like communication *) 10 | type ic 11 | type oc 12 | 13 | val open_connection : host:string -> service:string -> (ic * oc) t 14 | val shutdown_connection : ic -> unit t 15 | 16 | val read_line : ic -> string t 17 | val print_line : oc -> string -> unit t 18 | end 19 | 20 | module type S = sig 21 | type 'a monad 22 | 23 | type handle 24 | (** Type of a handle to a SMTP connection. *) 25 | 26 | type request = 27 | [ 28 | | `Helo of string 29 | | `From of string 30 | | `To of string 31 | | `Data 32 | | `Msg_body of string 33 | | `Quit 34 | ] 35 | (** Type of a request. *) 36 | 37 | type response = 38 | [ 39 | | `Ok of int * string 40 | | `Failure of int * string 41 | ] 42 | (** Type of a response. *) 43 | 44 | module Addr : sig 45 | type t 46 | val of_string : string -> t 47 | val to_string : t -> string 48 | end 49 | (** Module for handling email addresses. *) 50 | 51 | exception Negative_reply of int * string 52 | (** Exception raised when the remote SMTP server returns a negative 53 | reply. *) 54 | 55 | val connect : ?host:string -> ?port:string -> name:string -> unit -> handle monad 56 | (** [open ~host ~port] is a promise of a handle to an open 57 | connection to the SMTP server located at [host:port]. *) 58 | 59 | val close : handle -> unit monad 60 | (** [close h] closes [h], cleanly exiting the connection to the SMTP 61 | server if needed. *) 62 | 63 | val request : handle -> request -> response monad 64 | (** [request h req] sends [req] to the SMTP server handled by 65 | [h]. *) 66 | 67 | val send : handle -> from:Addr.t -> to_:Addr.t list -> body:string 68 | -> response monad 69 | (** [send h ~from ~to_ ~body] use the SMTP handled by [h] to send a 70 | mail of body [~body] from address [~from] to addresses 71 | [~to_]. *) 72 | 73 | val sendmail : ?host:string -> ?port:string -> name:string -> from:Addr.t 74 | -> to_:Addr.t list -> body:string -> unit -> response monad 75 | (** [sendmail ~host ~port ~from ~to_ ~body] sends the mail of body 76 | [~body] from address [~from] to addresses [~to] using the SMTP 77 | server at address [host:port]. *) 78 | end 79 | 80 | module Make (IO : IO) : S with type 'a monad = 'a IO.t 81 | -------------------------------------------------------------------------------- /src/smtp_lwt.ml: -------------------------------------------------------------------------------- 1 | module IO = struct 2 | type 'a t = 'a Lwt.t 3 | let return = Lwt.return 4 | let bind = Lwt.bind 5 | let ( >>= ) = Lwt.bind 6 | let fail = Lwt.fail 7 | 8 | type ic = Lwt_io.input_channel 9 | type oc = Lwt_io.output_channel 10 | 11 | let open_connection ~host ~service = 12 | Lwt_unix.getaddrinfo host service [] >>= function 13 | | [] -> fail (Failure ("IP resolution failed for " ^ host)) 14 | | h::t -> Lwt_io.open_connection h.Lwt_unix.ai_addr 15 | 16 | let shutdown_connection = Lwt_io.close 17 | 18 | let read_line = Lwt_io.read_line 19 | let print_line oc str = Lwt_io.write oc (str ^ "\r\n") 20 | end 21 | 22 | module Smtp = Smtp.Make (IO) 23 | include Smtp 24 | -------------------------------------------------------------------------------- /src/smtp_lwt.mli: -------------------------------------------------------------------------------- 1 | include Smtp.S with type 'a monad = 'a Lwt.t 2 | -------------------------------------------------------------------------------- /src/smtp_unix.ml: -------------------------------------------------------------------------------- 1 | module IO = struct 2 | type 'a t = 'a 3 | let return v = v 4 | let bind v f = f v 5 | let fail exn = raise exn 6 | 7 | type ic = in_channel 8 | type oc = out_channel 9 | 10 | let open_connection ~host ~service = 11 | match Unix.getaddrinfo host service [] with 12 | | [] -> fail (Failure ("IP resolution failed for " ^ host)) 13 | | h::t -> Unix.open_connection h.Unix.ai_addr 14 | 15 | let shutdown_connection = Unix.shutdown_connection 16 | 17 | let read_line = input_line 18 | let print_line oc str = output_string oc (str ^ "\r\n"); flush oc 19 | end 20 | 21 | module Smtp = Smtp.Make (IO) 22 | include Smtp 23 | -------------------------------------------------------------------------------- /src/smtp_unix.mli: -------------------------------------------------------------------------------- 1 | include Smtp.S with type 'a monad = 'a 2 | -------------------------------------------------------------------------------- /test/test_lwt.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Smtp_lwt 3 | 4 | let main host port = 5 | Lwt_unix.handle_unix_error 6 | (fun () -> sendmail 7 | ~host 8 | ~port 9 | ~name:Unix.(gethostname ()) 10 | ~from:Addr.(of_string "test@example.org") 11 | ~to_:[Addr.(of_string "test@example.org")] 12 | ~body:"Bleh" ()) () 13 | >|= function 14 | | `Ok (code, msg) -> Printf.printf "OK %d %s\n" code msg 15 | | `Failure (code, msg) -> Printf.eprintf "Failure %d %s\n" code msg 16 | 17 | 18 | let () = 19 | let args = ref [] in 20 | let speclist = Arg.(align []) in 21 | let anon_fun s = args := s::!args in 22 | let usage_msg = "Usage: " ^ Sys.argv.(0) ^ " [hostname (default \"localhost\")] [port (default \"smtp\")]\nOptions are:" in 23 | Arg.parse speclist anon_fun usage_msg; 24 | Lwt_main.run 25 | ((fun () -> match !args with 26 | | port::host::_ -> main host port 27 | | [host] -> main host "smtp" 28 | | [] -> main "localhost" "smtp") ()) 29 | -------------------------------------------------------------------------------- /test/test_unix.ml: -------------------------------------------------------------------------------- 1 | open Smtp_unix 2 | 3 | let main host port = 4 | match 5 | Unix.handle_unix_error 6 | (fun () -> sendmail 7 | ~host 8 | ~port 9 | ~name:Unix.(gethostname ()) 10 | ~from:Addr.(of_string "test@example.org") 11 | ~to_:[Addr.(of_string "test@example.org")] 12 | ~body:"Bleh" ()) () 13 | with 14 | | `Ok (code, msg) -> Printf.printf "OK %d %s\n" code msg 15 | | `Failure (code, msg) -> Printf.eprintf "Failure %d %s\n" code msg 16 | 17 | 18 | let () = 19 | let args = ref [] in 20 | let speclist = Arg.(align []) in 21 | let anon_fun s = args := s::!args in 22 | let usage_msg = "Usage: " ^ Sys.argv.(0) ^ " [hostname (default \"localhost\")] [port (default \"smtp\")]\nOptions are:" in 23 | Arg.parse speclist anon_fun usage_msg; 24 | match !args with 25 | | port::host::_ -> main host port 26 | | [host] -> main host "smtp" 27 | | [] -> main "localhost" "smtp" 28 | --------------------------------------------------------------------------------