diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013, Enzo Haussecker. All rights reserved. +Copyright (c) 2014, Enzo Haussecker. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/Network/Mail/Client/Gmail.hs b/Network/Mail/Client/Gmail.hs new file mode 100644 --- /dev/null +++ b/Network/Mail/Client/Gmail.hs @@ -0,0 +1,651 @@ +--------------------------------------------------------------- +-- Copyright (c) 2014, Enzo Haussecker. All rights reserved. -- +--------------------------------------------------------------- + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS -Wall #-} + +-- | A simple SMTP Client for sending Gmail. +module Network.Mail.Client.Gmail (sendGmail) where + +import Control.Monad (foldM_, forM, liftM, void) +import Crypto.Random.AESCtr (makeSystem) +import Data.ByteString.Char8 (lines, unpack) +import Data.ByteString.Base64.Lazy (encode) +import Data.ByteString.Lazy.Char8 (ByteString, readFile) +import Data.ByteString.Lazy.Search (replace) +import Data.Char (isDigit, isSpace) +import Data.Default (def) +import Data.Monoid ((<>)) +import Data.Text as Strict (Text, pack) +import Data.Text.Lazy as Lazy (Text, fromChunks) +import Data.Text.Lazy.Encoding (encodeUtf8) +import Network (PortID(PortNumber), connectTo) +import Network.Mail.Mime hiding (renderMail) +import Network.TLS +import Network.TLS.Extra +import Prelude hiding (any, lines, readFile) +import System.FilePath (takeExtension, takeFileName) +import System.IO hiding (readFile) +import System.Timeout (timeout) + +-- | Send an email from your Gmail account using the simple +-- message transfer protocol with transport layer security. +-- Below is an example using ghci, where Alice sends an +-- Excel spreadsheet to Bob. +-- +-- > >>> :set -XOverloadedStrings +-- > >>> :module Network.Mail.Mime Network.Mail.Client.Gmail +-- > >>> sendGmail "alice" "password" (Address (Just "Alice") "alice@gmail.com") [Address (Just "Bob") "bob@example.com"] [] [] "Excel Spreadsheet" "Hi Bob,\n\nThe Excel spreadsheet is attached.\n\nRegards,\n\nAlice" ["spreadsheet.xls"] Nothing +-- +sendGmail + :: Lazy.Text -- ^ username + -> Lazy.Text -- ^ password + -> Address -- ^ from + -> [Address] -- ^ to + -> [Address] -- ^ cc + -> [Address] -- ^ bcc + -> Strict.Text -- ^ subject + -> Lazy.Text -- ^ body + -> [FilePath] -- ^ attachments + -> Maybe Int -- ^ timeout in microseconds + -> IO () +sendGmail user pass from to cc bcc subject body attach lim = do + hdl <- connectTo "smtp.gmail.com" $ PortNumber 587 + sys <- makeSystem + ctx <- contextNew hdl params sys + _MAIL <- renderMail from to cc bcc subject body attach + hSetBuffering hdl LineBuffering + ---------------------------- + -- BEGIN MESSAGE EXCHANGE -- + ---------------------------- + sendSMTP hdl "EHLO" >> recvSMTP hdl lim "220" + >> recvSMTP hdl lim "250" + sendSMTP hdl "STARTTLS" >> recvSMTP hdl lim "220" + handshake ctx + sendSMTPS ctx "EHLO" >> recvSMTPS ctx lim "250" + sendSMTPS ctx "AUTH LOGIN" >> recvSMTPS ctx lim "334" + sendSMTPS ctx _USERNAME >> recvSMTPS ctx lim "334" + sendSMTPS ctx _PASSWORD >> recvSMTPS ctx lim "235" + sendSMTPS ctx _FROM >> recvSMTPS ctx lim "250" + sendSMTPS ctx _TO >> recvSMTPS ctx lim "250" + sendSMTPS ctx "DATA" >> recvSMTPS ctx lim "354" + sendSMTPS ctx _MAIL >> recvSMTPS ctx lim "250" + sendSMTPS ctx "QUIT" >> recvSMTPS ctx lim "221" + ---------------------------- + --- END MESSAGE EXCHANGE --- + ---------------------------- + bye ctx + contextClose ctx + hClose hdl + where _USERNAME = encode $ encodeUtf8 user + _PASSWORD = encode $ encodeUtf8 pass + _FROM = "MAIL FROM: " <> angleBracket [from] + _TO = "RCPT TO: " <> angleBracket (to ++ cc ++ bcc) + +-- | Display the first email address in the given list using angle bracket formatting. +angleBracket :: [Address] -> ByteString +angleBracket = \ case [] -> ""; (Address _ email:_) -> "<" <> encodeUtf8 (fromChunks [email]) <> ">" + +-- | Render an email using the RFC 2822 message format. +renderMail + :: Address -- ^ from + -> [Address] -- ^ to + -> [Address] -- ^ cc + -> [Address] -- ^ bcc + -> Strict.Text -- ^ subject + -> Lazy.Text -- ^ body + -> [FilePath] -- ^ attachments + -> IO ByteString +renderMail from to cc bcc subject body attach = do + parts <- forM attach $ \ path -> do + content <- readFile path + let mime = getMime $ takeExtension path + file = Just . pack $ takeFileName path + return $! [Part mime Base64 file [] content] + let plain = [Part "text/plain; charset=utf-8" QuotedPrintableText Nothing [] $ encodeUtf8 body] + mail <- renderMail' . Mail from to cc bcc headers $ plain : parts + return $! replace "\n." ("\n.."::ByteString) mail <> "\r\n.\r\n" + where headers = [("Subject",subject)] + +-- | Send an unencrypted message using the simple message transfer protocol. +sendSMTP + :: Handle -- ^ connection + -> String -- ^ message + -> IO () +sendSMTP = hPutStrLn + +-- | Receive an unencrypted message using the simple message transfer protocol. +recvSMTP + :: Handle -- ^ connection + -> Maybe Int -- ^ timeout in microseconds + -> String -- ^ expected reply code + -> IO () +recvSMTP hdl lim code = void $ + step [] where + step accum = do + mval <- maybe (liftM Just) timeout lim $ hGetLine hdl + case mval of + Nothing -> fail "recvSMTP: connection timeout" + Just reply -> match code reply step accum + +-- | Send an encrypted message using the simple message transfer protocol. +sendSMTPS + :: Context -- ^ connection + -> ByteString -- ^ message + -> IO () +sendSMTPS ctx msg = sendData ctx $ msg <> "\r\n" + +-- | Receive an encrypted message using the simple message transfer protocol. +recvSMTPS + :: Context -- ^ connection + -> Maybe Int -- ^ timeout in microseconds + -> String -- ^ expected reply code + -> IO () +recvSMTPS ctx lim code = do + mval <- maybe (liftM Just) timeout lim $ recvData ctx + case mval of + Nothing -> fail "recvSMTPS: connection timeout" + Just replies -> foldM_ step [] $ lines replies + -- NOTE: Here we assume that the whole response arrives in + -- one TLS packet. That assumption is not necessarily true. + where step accum reply = match code (unpack reply) return accum + +-- | A convenient type synonym. +type Continuation = [String] -> IO [String] + +-- | Match reply codes and perform continuation, termination, and failure case analysis. +match + :: String -- ^ expected reply code + -> String -- ^ reply + -> Continuation -- ^ continuation + -> [String] -- ^ accumulator + -> IO [String] +match code reply continuation accum = + if not (null suffix) && head suffix == '-' + then continuation $ drop 1 suffix:accum + else if prefix == code && "" /= code + then return [] + else mismatch code prefix $ suffix:accum + where (prefix, suffix) = break (not . isDigit) reply + +-- | Raise an exception for mismatched reply codes. +mismatch + :: String -- ^ expected reply code + -> String -- ^ received reply code + -> [String] -- ^ messages + -> IO [String] +mismatch code other replies = fail $ + if null code + then "mismatch: missing expected reply code." + else "mismatch: expected reply code " ++ code ++ + (if null other + then ", but no reply code was received" + else ", but received reply code " ++ other) ++ + case filter (not . null) $ map strip replies of + [] -> "." + (r:rs) -> ": " ++ foldl step (strip r) rs ++ "." + where strip = dropWhile isSpace . filter (/='\r') + step accum = flip (++) $ "; " ++ accum + +-- | TLS client parameters. +params :: ClientParams +params = (defaultParamsClient "smtp.gmail.com" "587") + { clientSupported = def { supportedCiphers = ciphersuite_all } + , clientShared = def { sharedValidationCache = noValidate } + } where noValidate = ValidationCache (\_ _ _ -> return ValidationCachePass) + (\_ _ _ -> return ()) + +-- | Get the mime type for the given file extension. +getMime :: String -> Strict.Text +getMime = \ case + ".3dm" -> "x-world/x-3dmf" + ".3dmf" -> "x-world/x-3dmf" + ".a" -> "application/octet-stream" + ".aab" -> "application/x-authorware-bin" + ".aam" -> "application/x-authorware-map" + ".aas" -> "application/x-authorware-seg" + ".abc" -> "text/vnd.abc" + ".acgi" -> "text/html" + ".afl" -> "video/animaflex" + ".ai" -> "application/postscript" + ".aif" -> "audio/aiff" + ".aifc" -> "audio/aiff" + ".aiff" -> "audio/aiff" + ".aim" -> "application/x-aim" + ".aip" -> "text/x-audiosoft-intra" + ".ani" -> "application/x-navi-animation" + ".aos" -> "application/x-nokia-9000-communicator-add-on-software" + ".aps" -> "application/mime" + ".arc" -> "application/octet-stream" + ".arj" -> "application/arj" + ".art" -> "image/x-jg" + ".asf" -> "video/x-ms-asf" + ".asm" -> "text/x-asm" + ".asp" -> "text/asp" + ".asx" -> "application/x-mplayer2" + ".au" -> "audio/basic" + ".avi" -> "application/x-troff-msvideo" + ".avs" -> "video/avs-video" + ".bcpio" -> "application/x-bcpio" + ".bin" -> "application/mac-binary" + ".bm" -> "image/bmp" + ".bmp" -> "image/bmp" + ".boo" -> "application/book" + ".book" -> "application/book" + ".boz" -> "application/x-bzip2" + ".bsh" -> "application/x-bsh" + ".bz" -> "application/x-bzip" + ".bz2" -> "application/x-bzip2" + ".c" -> "text/plain" + ".c++" -> "text/plain" + ".cat" -> "application/vnd.ms-pki.seccat" + ".cc" -> "text/plain" + ".ccad" -> "application/clariscad" + ".cco" -> "application/x-cocoa" + ".cdf" -> "application/cdf" + ".cer" -> "application/pkix-cert" + ".cha" -> "application/x-chat" + ".chat" -> "application/x-chat" + ".class" -> "application/java" + ".com" -> "application/octet-stream" + ".conf" -> "text/plain" + ".cpio" -> "application/x-cpio" + ".cpp" -> "text/x-c" + ".cpt" -> "application/mac-compactpro" + ".crl" -> "application/pkcs-crl" + ".crt" -> "application/pkix-cert" + ".csh" -> "application/x-csh" + ".css" -> "application/x-pointplus" + ".cxx" -> "text/plain" + ".dcr" -> "application/x-director" + ".deepv" -> "application/x-deepv" + ".def" -> "text/plain" + ".der" -> "application/x-x509-ca-cert" + ".dif" -> "video/x-dv" + ".dir" -> "application/x-director" + ".dl" -> "video/dl" + ".doc" -> "application/msword" + ".dot" -> "application/msword" + ".dp" -> "application/commonground" + ".drw" -> "application/drafting" + ".dump" -> "application/octet-stream" + ".dv" -> "video/x-dv" + ".dvi" -> "application/x-dvi" + ".dwf" -> "drawing/x-dwf (old)" + ".dwg" -> "application/acad" + ".dxf" -> "application/dxf" + ".dxr" -> "application/x-director" + ".el" -> "text/x-script.elisp" + ".elc" -> "application/x-bytecode.elisp (compiled elisp)" + ".env" -> "application/x-envoy" + ".eps" -> "application/postscript" + ".es" -> "application/x-esrehber" + ".etx" -> "text/x-setext" + ".evy" -> "application/envoy" + ".exe" -> "application/octet-stream" + ".f" -> "text/plain" + ".f77" -> "text/x-fortran" + ".f90" -> "text/plain" + ".fdf" -> "application/vnd.fdf" + ".fif" -> "application/fractals" + ".fli" -> "video/fli" + ".flo" -> "image/florian" + ".flx" -> "text/vnd.fmi.flexstor" + ".fmf" -> "video/x-atomic3d-feature" + ".for" -> "text/plain" + ".fpx" -> "image/vnd.fpx" + ".frl" -> "application/freeloader" + ".funk" -> "audio/make" + ".g" -> "text/plain" + ".g3" -> "image/g3fax" + ".gif" -> "image/gif" + ".gl" -> "video/gl" + ".gsd" -> "audio/x-gsm" + ".gsm" -> "audio/x-gsm" + ".gsp" -> "application/x-gsp" + ".gss" -> "application/x-gss" + ".gtar" -> "application/x-gtar" + ".gz" -> "application/x-compressed" + ".gzip" -> "application/x-gzip" + ".h" -> "text/plain" + ".hdf" -> "application/x-hdf" + ".help" -> "application/x-helpfile" + ".hgl" -> "application/vnd.hp-hpgl" + ".hh" -> "text/plain" + ".hlb" -> "text/x-script" + ".hlp" -> "application/hlp" + ".hpg" -> "application/vnd.hp-hpgl" + ".hpgl" -> "application/vnd.hp-hpgl" + ".hqx" -> "application/binhex" + ".hs" -> "text/x-haskell" + ".hta" -> "application/hta" + ".htc" -> "text/x-component" + ".htm" -> "text/html" + ".html" -> "text/html" + ".htmls" -> "text/html" + ".htt" -> "text/webviewhtml" + ".htx" -> "text/html" + ".ice" -> "x-conference/x-cooltalk" + ".ico" -> "image/x-icon" + ".idc" -> "text/plain" + ".ief" -> "image/ief" + ".iefs" -> "image/ief" + ".iges" -> "application/iges" + ".igs" -> "application/iges" + ".ima" -> "application/x-ima" + ".imap" -> "application/x-httpd-imap" + ".inf" -> "application/inf" + ".ins" -> "application/x-internett-signup" + ".ip" -> "application/x-ip2" + ".isu" -> "video/x-isvideo" + ".it" -> "audio/it" + ".iv" -> "application/x-inventor" + ".ivr" -> "i-world/i-vrml" + ".ivy" -> "application/x-livescreen" + ".jam" -> "audio/x-jam" + ".jav" -> "text/plain" + ".java" -> "text/plain" + ".jcm" -> "application/x-java-commerce" + ".jfif" -> "image/jpeg" + ".jfif-tbnl" -> "image/jpeg" + ".jpe" -> "image/jpeg" + ".jpeg" -> "image/jpeg" + ".jpg" -> "image/jpeg" + ".jps" -> "image/x-jps" + ".js" -> "application/x-javascript" + ".jut" -> "image/jutvision" + ".kar" -> "audio/midi" + ".ksh" -> "application/x-ksh" + ".la" -> "audio/nspaudio" + ".lam" -> "audio/x-liveaudio" + ".latex" -> "application/x-latex" + ".lha" -> "application/lha" + ".lhx" -> "application/octet-stream" + ".list" -> "text/plain" + ".lma" -> "audio/nspaudio" + ".log" -> "text/plain" + ".lsp" -> "application/x-lisp" + ".lst" -> "text/plain" + ".lsx" -> "text/x-la-asf" + ".ltx" -> "application/x-latex" + ".lzh" -> "application/octet-stream" + ".lzx" -> "application/lzx" + ".m" -> "text/plain" + ".m1v" -> "video/mpeg" + ".m2a" -> "audio/mpeg" + ".m2v" -> "video/mpeg" + ".m3u" -> "audio/x-mpequrl" + ".man" -> "application/x-troff-man" + ".map" -> "application/x-navimap" + ".mar" -> "text/plain" + ".mbd" -> "application/mbedlet" + ".mc$" -> "application/x-magic-cap-package-1.0" + ".mcd" -> "application/mcad" + ".mcf" -> "image/vasa" + ".mcp" -> "application/netmc" + ".me" -> "application/x-troff-me" + ".mht" -> "message/rfc822" + ".mhtml" -> "message/rfc822" + ".mid" -> "application/x-midi" + ".midi" -> "application/x-midi" + ".mif" -> "application/x-frame" + ".mime" -> "message/rfc822" + ".mjf" -> "audio/x-vnd.audioexplosion.mjuicemediafile" + ".mjpg" -> "video/x-motion-jpeg" + ".mm" -> "application/base64" + ".mme" -> "application/base64" + ".mod" -> "audio/mod" + ".moov" -> "video/quicktime" + ".mov" -> "video/quicktime" + ".movie" -> "video/x-sgi-movie" + ".mp2" -> "audio/mpeg" + ".mp3" -> "audio/mpeg3" + ".mpa" -> "audio/mpeg" + ".mpc" -> "application/x-project" + ".mpe" -> "video/mpeg" + ".mpeg" -> "video/mpeg" + ".mpg" -> "audio/mpeg" + ".mpga" -> "audio/mpeg" + ".mpp" -> "application/vnd.ms-project" + ".mpt" -> "application/x-project" + ".mpv" -> "application/x-project" + ".mpx" -> "application/x-project" + ".mrc" -> "application/marc" + ".ms" -> "application/x-troff-ms" + ".mv" -> "video/x-sgi-movie" + ".my" -> "audio/make" + ".mzz" -> "application/x-vnd.audioexplosion.mzz" + ".nap" -> "image/naplps" + ".naplps" -> "image/naplps" + ".nc" -> "application/x-netcdf" + ".ncm" -> "application/vnd.nokia.configuration-message" + ".nif" -> "image/x-niff" + ".niff" -> "image/x-niff" + ".nix" -> "application/x-mix-transfer" + ".nsc" -> "application/x-conference" + ".nvd" -> "application/x-navidoc" + ".o" -> "application/octet-stream" + ".oda" -> "application/oda" + ".omc" -> "application/x-omc" + ".omcd" -> "application/x-omcdatamaker" + ".omcr" -> "application/x-omcregerator" + ".p" -> "text/x-pascal" + ".p10" -> "application/pkcs10" + ".p12" -> "application/pkcs-12" + ".p7a" -> "application/x-pkcs7-signature" + ".p7c" -> "application/pkcs7-mime" + ".p7m" -> "application/pkcs7-mime" + ".p7r" -> "application/x-pkcs7-certreqresp" + ".p7s" -> "application/pkcs7-signature" + ".part" -> "application/pro_eng" + ".pas" -> "text/pascal" + ".pbm" -> "image/x-portable-bitmap" + ".pcl" -> "application/vnd.hp-pcl" + ".pct" -> "image/x-pict" + ".pcx" -> "image/x-pcx" + ".pdb" -> "chemical/x-pdb" + ".pdf" -> "application/pdf" + ".pfunk" -> "audio/make" + ".pgm" -> "image/x-portable-graymap" + ".pic" -> "image/pict" + ".pict" -> "image/pict" + ".pkg" -> "application/x-newton-compatible-pkg" + ".pko" -> "application/vnd.ms-pki.pko" + ".pl" -> "text/plain" + ".plx" -> "application/x-pixclscript" + ".pm" -> "image/x-xpixmap" + ".pm4" -> "application/x-pagemaker" + ".pm5" -> "application/x-pagemaker" + ".png" -> "image/png" + ".pnm" -> "application/x-portable-anymap" + ".pot" -> "application/mspowerpoint" + ".pov" -> "model/x-pov" + ".ppa" -> "application/vnd.ms-powerpoint" + ".ppm" -> "image/x-portable-pixmap" + ".pps" -> "application/mspowerpoint" + ".ppt" -> "application/mspowerpoint" + ".ppz" -> "application/mspowerpoint" + ".pre" -> "application/x-freelance" + ".prt" -> "application/pro_eng" + ".ps" -> "application/postscript" + ".psd" -> "application/octet-stream" + ".pvu" -> "paleovu/x-pv" + ".pwz" -> "application/vnd.ms-powerpoint" + ".py" -> "text/x-script.phyton" + ".pyc" -> "applicaiton/x-bytecode.python" + ".qcp" -> "audio/vnd.qcelp" + ".qd3" -> "x-world/x-3dmf" + ".qd3d" -> "x-world/x-3dmf" + ".qif" -> "image/x-quicktime" + ".qt" -> "video/quicktime" + ".qtc" -> "video/x-qtc" + ".qti" -> "image/x-quicktime" + ".qtif" -> "image/x-quicktime" + ".ra" -> "audio/x-pn-realaudio" + ".ram" -> "audio/x-pn-realaudio" + ".ras" -> "application/x-cmu-raster" + ".rast" -> "image/cmu-raster" + ".rexx" -> "text/x-script.rexx" + ".rf" -> "image/vnd.rn-realflash" + ".rgb" -> "image/x-rgb" + ".rm" -> "application/vnd.rn-realmedia" + ".rmi" -> "audio/mid" + ".rmm" -> "audio/x-pn-realaudio" + ".rmp" -> "audio/x-pn-realaudio" + ".rng" -> "application/ringing-tones" + ".rnx" -> "application/vnd.rn-realplayer" + ".roff" -> "application/x-troff" + ".rp" -> "image/vnd.rn-realpix" + ".rpm" -> "audio/x-pn-realaudio-plugin" + ".rt" -> "text/richtext" + ".rtf" -> "application/rtf" + ".rtx" -> "application/rtf" + ".rv" -> "video/vnd.rn-realvideo" + ".s" -> "text/x-asm" + ".s3m" -> "audio/s3m" + ".saveme" -> "application/octet-stream" + ".sbk" -> "application/x-tbook" + ".scm" -> "application/x-lotusscreencam" + ".sdml" -> "text/plain" + ".sdp" -> "application/sdp" + ".sdr" -> "application/sounder" + ".sea" -> "application/sea" + ".set" -> "application/set" + ".sgm" -> "text/sgml" + ".sgml" -> "text/sgml" + ".sh" -> "application/x-bsh" + ".shar" -> "application/x-bsh" + ".shtml" -> "text/html" + ".sid" -> "audio/x-psid" + ".sit" -> "application/x-sit" + ".skd" -> "application/x-koan" + ".skm" -> "application/x-koan" + ".skp" -> "application/x-koan" + ".skt" -> "application/x-koan" + ".sl" -> "application/x-seelogo" + ".smi" -> "application/smil" + ".smil" -> "application/smil" + ".snd" -> "audio/basic" + ".sol" -> "application/solids" + ".spc" -> "application/x-pkcs7-certificates" + ".spl" -> "application/futuresplash" + ".spr" -> "application/x-sprite" + ".sprite" -> "application/x-sprite" + ".src" -> "application/x-wais-source" + ".ssi" -> "text/x-server-parsed-html" + ".ssm" -> "application/streamingmedia" + ".sst" -> "application/vnd.ms-pki.certstore" + ".step" -> "application/step" + ".stl" -> "application/sla" + ".stp" -> "application/step" + ".sv4cpio" -> "application/x-sv4cpio" + ".sv4crc" -> "application/x-sv4crc" + ".svf" -> "image/vnd.dwg" + ".svr" -> "application/x-world" + ".swf" -> "application/x-shockwave-flash" + ".t" -> "application/x-troff" + ".talk" -> "text/x-speech" + ".tar" -> "application/x-tar" + ".tbk" -> "application/toolbook" + ".tcl" -> "application/x-tcl" + ".tcsh" -> "text/x-script.tcsh" + ".tex" -> "application/x-tex" + ".texi" -> "application/x-texinfo" + ".texinfo" -> "application/x-texinfo" + ".text" -> "application/plain" + ".tgz" -> "application/gnutar" + ".tif" -> "image/tiff" + ".tiff" -> "image/tiff" + ".tr" -> "application/x-troff" + ".tsi" -> "audio/tsp-audio" + ".tsp" -> "application/dsptype" + ".tsv" -> "text/tab-separated-values" + ".turbot" -> "image/florian" + ".txt" -> "text/plain" + ".uil" -> "text/x-uil" + ".uni" -> "text/uri-list" + ".unis" -> "text/uri-list" + ".unv" -> "application/i-deas" + ".uri" -> "text/uri-list" + ".uris" -> "text/uri-list" + ".ustar" -> "application/x-ustar" + ".uu" -> "application/octet-stream" + ".uue" -> "text/x-uuencode" + ".vcd" -> "application/x-cdlink" + ".vcs" -> "text/x-vcalendar" + ".vda" -> "application/vda" + ".vdo" -> "video/vdo" + ".vew" -> "application/groupwise" + ".viv" -> "video/vivo" + ".vivo" -> "video/vivo" + ".vmd" -> "application/vocaltec-media-desc" + ".vmf" -> "application/vocaltec-media-file" + ".voc" -> "audio/voc" + ".vos" -> "video/vosaic" + ".vox" -> "audio/voxware" + ".vqe" -> "audio/x-twinvq-plugin" + ".vqf" -> "audio/x-twinvq" + ".vql" -> "audio/x-twinvq-plugin" + ".vrml" -> "application/x-vrml" + ".vrt" -> "x-world/x-vrt" + ".vsd" -> "application/x-visio" + ".vst" -> "application/x-visio" + ".vsw" -> "application/x-visio" + ".w60" -> "application/wordperfect6.0" + ".w61" -> "application/wordperfect6.1" + ".w6w" -> "application/msword" + ".wav" -> "audio/wav" + ".wb1" -> "application/x-qpro" + ".wbmp" -> "image/vnd.wap.wbmp" + ".web" -> "application/vnd.xara" + ".wiz" -> "application/msword" + ".wk1" -> "application/x-123" + ".wmf" -> "windows/metafile" + ".wml" -> "text/vnd.wap.wml" + ".wmlc" -> "application/vnd.wap.wmlc" + ".wmls" -> "text/vnd.wap.wmlscript" + ".wmlsc" -> "application/vnd.wap.wmlscriptc" + ".word" -> "application/msword" + ".wp" -> "application/wordperfect" + ".wp5" -> "application/wordperfect" + ".wp6" -> "application/wordperfect" + ".wpd" -> "application/wordperfect" + ".wq1" -> "application/x-lotus" + ".wri" -> "application/mswrite" + ".wrl" -> "application/x-world" + ".wrz" -> "model/vrml" + ".wsc" -> "text/scriplet" + ".wsrc" -> "application/x-wais-source" + ".wtk" -> "application/x-wintalk" + ".xbm" -> "image/x-xbitmap" + ".xdr" -> "video/x-amt-demorun" + ".xgz" -> "xgl/drawing" + ".xif" -> "image/vnd.xiff" + ".xl" -> "application/excel" + ".xla" -> "application/excel" + ".xlb" -> "application/excel" + ".xlc" -> "application/excel" + ".xld" -> "application/excel" + ".xlk" -> "application/excel" + ".xll" -> "application/excel" + ".xlm" -> "application/excel" + ".xls" -> "application/excel" + ".xlt" -> "application/excel" + ".xlv" -> "application/excel" + ".xlw" -> "application/excel" + ".xm" -> "audio/xm" + ".xml" -> "application/xml" + ".xmz" -> "xgl/movie" + ".xpix" -> "application/x-vnd.ls-xpix" + ".xpm" -> "image/x-xpixmap" + ".x-png" -> "image/png" + ".xsr" -> "video/x-amt-showrun" + ".xwd" -> "image/x-xwd" + ".xyz" -> "chemical/x-pdb" + ".z" -> "application/x-compress" + ".zip" -> "application/x-compressed" + ".zoo" -> "application/octet-stream" + ".zsh" -> "text/x-script.zsh" + _ -> "application/octet-stream" diff --git a/Network/SMTPS/Gmail.hs b/Network/SMTPS/Gmail.hs deleted file mode 100644 --- a/Network/SMTPS/Gmail.hs +++ /dev/null @@ -1,102 +0,0 @@ ---------------------------------------------------------------- --- Copyright (c) 2013, Enzo Haussecker. All rights reserved. -- ---------------------------------------------------------------- - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS -Wall #-} -{-# OPTIONS -fno-warn-name-shadowing #-} - -module Network.SMTPS.Gmail (sendGmail) where - -import Codec.Binary.Base64.String (encode) -import Control.Exception -import Control.Monad -import Crypto.Random.AESCtr (makeSystem) -import Data.ByteString.Char8 as Strict -import Data.ByteString.Lazy.Char8 as Lazy -import Data.ByteString.Lazy.UTF8 (fromString) -import Data.List as List -import Data.Monoid ((<>)) -import Network -import Network.TLS -import Network.TLS.Extra -import System.IO as IO -import Text.Printf - --- | Send an email from your Gmail account using the simple --- message transfer protocol with transport layer security. -sendGmail - :: Handle -- ^ log - -> String -- ^ username - -> String -- ^ password - -> [String] -- ^ to - -> [String] -- ^ cc - -> [String] -- ^ bcc - -> String -- ^ subject - -> String -- ^ body - -> IO () -sendGmail log user pass to cc bcc sub body = ( do - let params = defaultParamsClient { pCiphers = ciphers } - recips = nub $ bcc <> cc <> to - from = user <> "@gmail.com" - gen <- makeSystem - hdl <- connectTo "smtp.gmail.com" $ PortNumber 587 - ctx <- contextNewOnHandle hdl params gen - hSetBuffering hdl LineBuffering - let f str = send hdl log str >> recv hdl log - mapM_ f ["EHLO","STARTTLS"] - handshake ctx - let g lbs = sendTLS ctx log lbs >> recvTLS ctx log - mapM_ g [ - "EHLO", - "AUTH LOGIN", - fromString $ encode user, - fromString $ encode pass, - fromString $ "MAIL FROM:<" <> from <> ">", - fromString $ "RCPT TO:<" <> List.intercalate ">,<" recips <> ">", - "DATA", - fromString $ "To:<" <> List.intercalate ">,<" to <> ">" - <> "\r\nCC:<" <> List.intercalate ">,<" cc <> ">" - <> "\r\nBCC:<" <> List.intercalate ">,<" bcc <> ">" - <> "\r\nFrom:<" <> from <> ">" - <> "\r\nSubject:" <> sub - <> "\r\n" <> body - <> "\r\n.", - "QUIT"] - bye ctx - contextClose ctx - hClose hdl ) - `catch` \ (err :: SomeException) -> - IO.hPutStrLn log $ show err - -send :: Handle -> Handle -> String -> IO () -send socket log message = do - void $ hPrintf socket "%s\r\n" message - IO.hPutStrLn log $ "> " <> message - -recv :: Handle -> Handle -> IO () -recv socket log = do - imput <- hWaitForInput socket 300 - when imput $ do - line <- IO.hGetLine socket - IO.hPutStrLn log line - recv socket log - -sendTLS :: Context -> Handle -> Lazy.ByteString -> IO () -sendTLS ctx log message = do - sendData ctx $ message <> "\r\n" - Lazy.hPutStrLn log $ "> " <> message - -recvTLS :: Context -> Handle -> IO () -recvTLS ctx log = do - messages <- recvData ctx - mapM_ (Strict.hPutStrLn log) $ Strict.lines messages - -ciphers :: [Cipher] -ciphers = - [ cipher_AES128_SHA1 - , cipher_AES256_SHA1 - , cipher_RC4_128_MD5 - , cipher_RC4_128_SHA1 - ] diff --git a/README.org b/README.org new file mode 100644 --- /dev/null +++ b/README.org @@ -0,0 +1,37 @@ +#+TITLE: Gmail SMTP Client + +*** Introduction + +The ~smtps-gmail~ package provides an SMTP client +for sending Gmail. Communications between the client +and server are secured with transport layer security. + +*** Installation + +You should first get a clone of the ~smtps-gmail~ +repository, and then install it from inside the +source directory: + +#+BEGIN_SRC bash +$ git clone https://github.com/enzoh/smtps-gmail +$ cd smtps-gmail +$ cabal install +#+END_SRC + +*** Usage + +Below is an example using ghci, where Alice sends +an Excel spreadsheet to Bob using the SMTP client. + +#+BEGIN_SRC haskell +>>> :set -XOverloadedStrings +>>> :module Network.Mail.Mime Network.Mail.Client.Gmail +>>> sendGmail "alice" "password" (Address (Just "Alice") "alice@gmail.com") [Address (Just "Bob") "bob@example.com"] [] [] "Excel Spreadsheet" "Hi Bob,\n\nThe Excel spreadsheet is attached.\n\nRegards,\n\nAlice" ["spreadsheet.xls"] Nothing +#+END_SRC + +** Resources + +Feel free to contact me if you have any questions +or comments regarding this package. + +Enzo Haussecker diff --git a/smtps-gmail.cabal b/smtps-gmail.cabal --- a/smtps-gmail.cabal +++ b/smtps-gmail.cabal @@ -1,39 +1,30 @@ Name: smtps-gmail -Version: 1.0.0 +Version: 1.1.0 License: BSD3 License-File: LICENSE -Copyright: Copyright (c) 2013, Enzo Haussecker. All rights reserved. +Copyright: Copyright (c) 2014, Enzo Haussecker. All rights reserved. Author: Enzo Haussecker Maintainer: Enzo Haussecker -Stability: Stable +Stability: Experimental Category: Network -Synopsis: Gmail API +Synopsis: Gmail SMTP Client Homepage: https://github.com/enzoh/smtps-gmail Bug-Reports: https://github.com/enzoh/smtps-gmail/issues Build-Type: Simple Cabal-Version: >= 1.16.0 -Description: Send email from your Gmail account using the simple message transfer protocol with transport layer security. +Description: Send email from your Gmail account. Library Default-Language: Haskell2010 - Exposed-Modules: Network.SMTPS.Gmail - Build-Depends: base >= 4 && < 5, - base64-string, - bytestring, - cprng-aes, - network, - tls, - tls-extra, - utf8-string - -Executable gmail - Default-Language: Haskell2010 - Main-Is: src/Main.hs + Exposed-Modules: Network.Mail.Client.Gmail Build-Depends: base >= 4 && < 5, - base64-string, + base64-bytestring, bytestring, cprng-aes, + data-default, + filepath, + mime-mail, network, - tls, - tls-extra, - utf8-string + stringsearch, + text, + tls >= 1.2 && < 1.3 diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,47 +0,0 @@ ---------------------------------------------------------------- --- Copyright (c) 2013, Enzo Haussecker. All rights reserved. -- ---------------------------------------------------------------- - -{-# OPTIONS -Wall #-} - -module Main where - -import Control.Exception -import Network.SMTPS.Gmail -import System.IO - -main :: IO () -main = do - putStr "Username: " - hFlush stdout - user <- withEcho True getLine - putStr "Password: " - hFlush stdout - pass <- withEcho False getLine - putChar '\n' - putStr "To: " - hFlush stdout - to <- withEcho True getLine >>= return . split - putStr "CC: " - hFlush stdout - cc <- withEcho True getLine >>= return . split - putStr "BCC: " - hFlush stdout - bcc <- withEcho True getLine >>= return . split - putStr "Subject: " - hFlush stdout - sub <- withEcho True getLine - putStr "Body: " - hFlush stdout - body <- withEcho True getLine - sendGmail stdout user pass to cc bcc sub body - -withEcho :: Bool -> IO a -> IO a -withEcho echo action = do - old <- hGetEcho stdin - bracket_ (hSetEcho stdin echo) (hSetEcho stdin old) action - -split :: String -> [String] -split "" = [] -split xs = a : split (drop 1 b) - where (,) a b = break (==',') xs