diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,4 +1,22 @@ +0.4 -> 0.4.1 +------------ + + - login function for IMAP must escape the password + Due to the possibility of the password contain special characters + (See https://github.com/jtdaugherty/HaskellNet/issues/31) + - Improved documentation for SMTP + - Merge pull request #29 from lemol/master: + Update on SMTP example + - Merge pull request #26 from lemol/master: + * Fix a bug when parsing the response of fetch in IMAP + (See https://github.com/jtdaugherty/HaskellNet/issues/27) + * Add a function for sending plain text email + - Merge pull request #25 from lemol/master: + Add a function for authentication in SMTP + - Merge pull request #24 from lemol/master: + Bug fix on PLAIN authentication encode + 0.3 -> 0.4 ---------- diff --git a/HaskellNet.cabal b/HaskellNet.cabal --- a/HaskellNet.cabal +++ b/HaskellNet.cabal @@ -4,7 +4,7 @@ SMTP, and IMAP protocols. NOTE: this package will be split into smaller, protocol-specific packages in the future. -Version: 0.4 +Version: 0.4.1 Copyright: (c) 2006 Jun Mukai Author: Jun Mukai Maintainer: Jonathan Daugherty diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,8 @@ HaskellNet ========== +[![Build Status](https://travis-ci.org/lemol/HaskellNet.svg)](https://travis-ci.org/lemol/HaskellNet) + This package provides client support for the E-mail protocols POP3, SMTP, and IMAP. @@ -11,8 +13,8 @@ ghci -hide-package monads-fd example/smtpMimeMail.hs main - -If you encounter problems and want to debug the ghci + +If you encounter problems and want to debug the ghci debugger works well: :set -fbreak-on-exception diff --git a/example/smtp.hs b/example/smtp.hs --- a/example/smtp.hs +++ b/example/smtp.hs @@ -1,32 +1,67 @@ -import System.IO -import Network.HaskellNet.SMTP -import Text.Mime -import qualified Data.ByteString.Char8 as BS -import Codec.Binary.Base64.String +{-# OPTIONS -fno-warn-missing-signatures #-} +{-# LANGUAGE OverloadedStrings #-} +import Network.HaskellNet.SMTP +import Network.HaskellNet.Auth +import Network.Mail.Mime +import qualified Data.Text as T +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as B -smtpServer = "outmail.f2s.com" -sendFrom = "test@test.org" -sendTo = ["wrwills@gmail.com"] +-- | Your settings +server = "smtp.test.com" +port = toEnum 25 +username = "username" +password = "password" +authType = PLAIN +from = "test@test.com" +to = "to@test.com" +subject = "Network.HaskellNet.SMTP Test :)" +plainBody = "Hello world!" +htmlBody = "

Hello world!

" +attachments = [] -- example [("application/octet-stream", "/path/to/file1.tar.gz), ("application/pdf", "/path/to/file2.pdf")] +-- | Send plain text mail +example1 = doSMTP server $ \conn -> + sendPlainTextMail to from subject plainBody conn -main = do - con <- connectSMTP smtpServer - message <- BS.readFile "example/message.txt" - messageHtml <- BS.readFile "example/message.html" - let textP = SinglePart [("Content-Type", "text/plain; charset=utf-8")] message - let htmlP = SinglePart [("Content-Type", "text/html; charset=utf-8")] messageHtml - let msg = MultiPart [("From", "Network.HaskellNet <" ++ sendFrom ++ ">"),("Subject","Test")] [htmlP, textP] - sendMail sendFrom sendTo (BS.pack $ show $ showMime "utf-8" msg) con - closeSMTP con - +-- | With custom port number +example2 = doSMTPPort server port $ \conn -> + sendPlainTextMail to from subject plainBody conn +-- | Manually open and close the connection +example3 = do + conn <- connectSMTP server + sendPlainTextMail to from subject plainBody conn + closeSMTP conn - --let msg = ([("From", "Network.HaskellNet <" ++ sendFrom ++ ">"),("Subject","Test")], MultiPart [] [textP, htmlP]) - --sendMail sendFrom sendTo (BS.pack $ show $ showMessage "utf-8" msg) con --- let msg = ([("From", "Network.HaskellNet <" ++ sendFrom ++ ">"),("Subject","Test")], BS.pack "\r\nhello 算法是指完成一个任from haskellnet") +-- | Send mime mail +example4 = doSMTP server $ \conn -> + sendMimeMail to from subject plainBody htmlBody [] conn ---htmlP = SinglePart [("Content-Type", "text/html; charset=utf-8", "Content-Transfer-Encoding", ""] BS.pack $ encode $ +-- | With attachments (modify the `attachments` binding) +example5 = doSMTP server $ \conn -> + sendMimeMail to from subject plainBody htmlBody attachments conn +-- | With authentication +example6 = doSMTP server $ \conn -> do + authSuccess <- authenticate authType username password conn + if authSuccess + then sendMimeMail to from subject plainBody htmlBody [] conn + else putStrLn "Authentication failed." +-- | Custom +example7 = do + conn <- connectSMTPPort server port + let newMail = Mail (Address (Just "My Name") "from@test.org") + [(Address Nothing "to@test.org")] + [(Address Nothing "cc1@test.org"), (Address Nothing "cc2@test.org")] + [] + [("Subject", T.pack subject)] + [[htmlPart htmlBody, plainPart plainBody]] + newMail' <- addAttachments attachments newMail + renderedMail <- renderMail' newMail' + sendMail from [to] (S.concat . B.toChunks $ renderedMail) conn + closeSMTP conn +main = example1 diff --git a/src/Network/HaskellNet/Auth.hs b/src/Network/HaskellNet/Auth.hs --- a/src/Network/HaskellNet/Auth.hs +++ b/src/Network/HaskellNet/Auth.hs @@ -32,7 +32,7 @@ b64Decode = map (toEnum.fromEnum) . B64.decode . map (toEnum.fromEnum) showOctet :: [Word8] -> String -showOctet = concat . map hexChars +showOctet = concatMap hexChars where hexChars c = [arr ! (c `div` 16), arr ! (c `mod` 16)] arr = listArray (0, 15) "0123456789abcdef" @@ -51,7 +51,7 @@ okey = zipWith xor key' opad plain :: UserName -> Password -> String -plain user pass = b64Encode $ concat $ intersperse "\0" [user, user, pass] +plain user pass = b64Encode $ intercalate "\0" ["", user, pass] login :: UserName -> Password -> (String, String) login user pass = (b64Encode user, b64Encode pass) diff --git a/src/Network/HaskellNet/IMAP.hs b/src/Network/HaskellNet/IMAP.hs --- a/src/Network/HaskellNet/IMAP.hs +++ b/src/Network/HaskellNet/IMAP.hs @@ -204,7 +204,7 @@ bsClose (stream c) login :: IMAPConnection -> A.UserName -> A.Password -> IO () -login conn username password = sendCommand conn ("LOGIN " ++ username ++ " " ++ password) +login conn username password = sendCommand conn ("LOGIN " ++ (escapeLogin username) ++ " " ++ (escapeLogin password)) pNone authenticate :: IMAPConnection -> A.AuthType @@ -338,36 +338,36 @@ fetch :: IMAPConnection -> UID -> IO ByteString fetch conn uid = do lst <- fetchByString conn uid "BODY[]" - return $ maybe BS.empty BS.pack $ lookup "BODY[]" lst + return $ maybe BS.empty BS.pack $ lookup' "BODY[]" lst fetchHeader :: IMAPConnection -> UID -> IO ByteString fetchHeader conn uid = do lst <- fetchByString conn uid "BODY[HEADER]" - return $ maybe BS.empty BS.pack $ lookup "BODY[HEADER]" lst + return $ maybe BS.empty BS.pack $ lookup' "BODY[HEADER]" lst fetchSize :: IMAPConnection -> UID -> IO Int fetchSize conn uid = do lst <- fetchByString conn uid "RFC822.SIZE" - return $ maybe 0 read $ lookup "RFC822.SIZE" lst + return $ maybe 0 read $ lookup' "RFC822.SIZE" lst fetchHeaderFields :: IMAPConnection -> UID -> [String] -> IO ByteString fetchHeaderFields conn uid hs = do lst <- fetchByString conn uid ("BODY[HEADER.FIELDS "++unwords hs++"]") return $ maybe BS.empty BS.pack $ - lookup ("BODY[HEADER.FIELDS "++unwords hs++"]") lst + lookup' ("BODY[HEADER.FIELDS "++unwords hs++"]") lst fetchHeaderFieldsNot :: IMAPConnection -> UID -> [String] -> IO ByteString fetchHeaderFieldsNot conn uid hs = do let fetchCmd = "BODY[HEADER.FIELDS.NOT "++unwords hs++"]" lst <- fetchByString conn uid fetchCmd - return $ maybe BS.empty BS.pack $ lookup fetchCmd lst + return $ maybe BS.empty BS.pack $ lookup' fetchCmd lst fetchFlags :: IMAPConnection -> UID -> IO [Flag] fetchFlags conn uid = do lst <- fetchByString conn uid "FLAGS" - return $ getFlags $ lookup "FLAGS" lst + return $ getFlags $ lookup' "FLAGS" lst where getFlags Nothing = [] getFlags (Just s) = eval' dvFlags "" s @@ -376,7 +376,7 @@ fetchR conn r = do lst <- fetchByStringR conn r "BODY[]" return $ map (\(uid, vs) -> (uid, maybe BS.empty BS.pack $ - lookup "BODY[]" vs)) lst + lookup' "BODY[]" vs)) lst fetchByString :: IMAPConnection -> UID -> String -> IO [(String, String)] fetchByString conn uid command = @@ -388,7 +388,7 @@ fetchByStringR conn (s, e) command = fetchCommand conn ("UID FETCH "++show s++":"++show e++" "++command) proc where proc (n, ps) = - (maybe (toEnum (fromIntegral n)) read (lookup "UID" ps), ps) + (maybe (toEnum (fromIntegral n)) read (lookup' "UID" ps), ps) fetchCommand :: IMAPConnection -> String -> ((Integer, [(String, String)]) -> b) -> IO [b] @@ -406,8 +406,8 @@ flgs (PlusFlags fs) = toFStr "+FLAGS" $ fstrs fs flgs (MinusFlags fs) = toFStr "-FLAGS" $ fstrs fs procStore (n, ps) = (maybe (toEnum (fromIntegral n)) read - (lookup "UID" ps) - ,maybe [] (eval' dvFlags "") (lookup "FLAG" ps)) + (lookup' "UID" ps) + ,maybe [] (eval' dvFlags "") (lookup' "FLAG" ps)) store :: IMAPConnection -> UID -> FlagsQuery -> IO () @@ -450,3 +450,25 @@ bsPutCrLf :: BSStream -> ByteString -> IO () bsPutCrLf h s = bsPut h s >> bsPut h crlf >> bsFlush h + +lookup' :: String -> [(String, b)] -> Maybe b +lookup' _ [] = Nothing +lookup' q ((k,v):xs) | q == lastWord k = return v + | otherwise = lookup' q xs + where + lastWord = last . words + +-- TODO: This is just a first trial solution for this stack overflow question: +-- http://stackoverflow.com/questions/26183675/error-when-fetching-subject-from-email-using-haskellnets-imap +-- It must be reviewed. References: rfc3501#6.2.3, rfc2683#3.4.2. +-- This function was tested against the password: `~1!2@3#4$5%6^7&8*9(0)-_=+[{]}\|;:'",<.>/? (with spaces in the laterals). +escapeLogin :: String -> String +escapeLogin x = "\"" ++ replaceSpecialChars x ++ "\"" + where + replaceSpecialChars "" = "" + replaceSpecialChars (c:cs) = escapeChar c ++ replaceSpecialChars cs + escapeChar '"' = "\\\"" + escapeChar '\\' = "\\\\" + escapeChar '{' = "\\{" + escapeChar '}' = "\\}" + escapeChar s = [s] diff --git a/src/Network/HaskellNet/SMTP.hs b/src/Network/HaskellNet/SMTP.hs --- a/src/Network/HaskellNet/SMTP.hs +++ b/src/Network/HaskellNet/SMTP.hs @@ -1,4 +1,49 @@ {-# LANGUAGE ScopedTypeVariables #-} +{- | + +This module provides functions for working with the SMTP protocol in the client side, +including /opening/ and /closing/ connections, /sending commands/ to the server, +/authenticate/ and /sending mails/. + +Here's a basic usage example: + +> +> import Network.HaskellNet.SMTP +> import Network.HaskellNet.Auth +> import qualified Data.Text.Lazy as T +> +> main = doSMTP "your.smtp.server.com" $ \conn -> +> authSucceed <- authenticate PLAIN "username" "password" conn +> if authSucceed +> then sendPlainTextMail "receiver@server.com" "sender@server.com" "subject" (T.pack "Hello! This is the mail body!") conn +> else print "Authentication failed." + +Notes for the above example: + + * First the 'SMTPConnection' is opened with the 'doSMTP' function. + The connection should also be established with functions such as 'connectSMTP', + 'connectSMTPPort' and 'doSMTPPort'. + With the @doSMTP*@ functions the connection is opened, then executed an action + with it and then closed automatically. + If the connection is opened with the @connectSMTP*@ functions you may want to + close it with the 'closeSMTP' function after using it. + It is also possible to create a 'SMTPConnection' from an already opened connection + stream ('BSStream') using the 'connectStream' or 'doSMTPStream' functions. + + /NOTE:/ For /SSL\/TLS/ support you may establish the connection using + the functions (such as @connectSMTPSSL@) provided in the + @Network.HaskellNet.SMTP.SSL@ module of the + + package. + + * The 'authenticate' function authenticates to the server with the specified 'AuthType'. + 'PLAIN', 'LOGIN' and 'CRAM_MD5' 'AuthType's are available. It returns a 'Bool' + indicating either the authentication succeed or not. + + + * To send a mail you can use 'sendPlainTextMail' for plain text mail, or 'sendMimeMail' + for mime mail. +-} module Network.HaskellNet.SMTP ( -- * Types Command(..) @@ -12,10 +57,12 @@ , sendCommand , closeSMTP -- * Other Useful Operations + , authenticate , sendMail , doSMTPPort , doSMTP , doSMTPStream + , sendPlainTextMail , sendMimeMail ) where @@ -34,8 +81,6 @@ import Network.HaskellNet.Auth -import System.IO - import Network.Mail.Mime import qualified Data.ByteString.Lazy as B import qualified Data.ByteString as S @@ -43,8 +88,6 @@ import qualified Data.Text.Lazy as LT import qualified Data.Text as T -import Prelude hiding (catch) - -- The response field seems to be unused. It's saved at one place, but never -- retrieved. data SMTPConnection = SMTPC { bsstream :: !BSStream, _response :: ![ByteString] } @@ -110,7 +153,7 @@ _ | code == expectedReply -> return msg _ | tries > 1 -> tryCommand conn cmd (tries - 1) expectedReply - _ | otherwise -> do + | otherwise -> do bsClose (bsstream conn) fail $ "cannot execute command " ++ show cmd ++ ", expected reply code " ++ show expectedReply ++ @@ -136,7 +179,7 @@ let (c, bdy) = BS.span isDigit l if not (BS.null bdy) && BS.head bdy == '-' then do (c2, ls) <- readLines - return (c2, (BS.tail bdy:ls)) + return (c2, BS.tail bdy:ls) else return (c, [BS.tail bdy]) @@ -148,7 +191,7 @@ unless (code == 354) $ fail "this server cannot accept any data." mapM_ sendLine $ BS.lines dat ++ [BS.pack "."] parseResponse conn - where sendLine l = bsPutCrLf conn l + where sendLine = bsPutCrLf conn sendCommand (SMTPC conn _) (AUTH LOGIN username password) = do bsPutCrLf conn command (_, _) <- parseResponse conn @@ -156,7 +199,7 @@ (_, _) <- parseResponse conn bsPutCrLf conn $ BS.pack passB64 parseResponse conn - where command = BS.pack $ "AUTH LOGIN" + where command = BS.pack "AUTH LOGIN" (userB64, passB64) = login username password sendCommand (SMTPC conn _) (AUTH at username password) = do bsPutCrLf conn command @@ -183,7 +226,7 @@ QUIT -> "QUIT" (DATA _) -> error "BUG: DATA pattern should be matched by sendCommand patterns" - (AUTH _ _ _) -> + (AUTH {}) -> error "BUG: AUTH pattern should be matched by sendCommand patterns" -- | close the connection. This function send the QUIT method, so you @@ -204,6 +247,21 @@ bsClose conn `catch` \(_ :: IOException) -> return () -} +{- | +This function will return 'True' if the authentication succeeds. +Here's an example of sending a mail with a server that requires +authentication: + +> authSucceed <- authenticate PLAIN "username" "password" conn +> if authSucceed +> then sendPlainTextMail "receiver@server.com" "sender@server.com" "subject" (T.pack "Hello!") conn +> else print "Authentication failed." +-} +authenticate :: AuthType -> UserName -> Password -> SMTPConnection -> IO Bool +authenticate at username password conn = do + (code, _) <- sendCommand conn $ AUTH at username password + return (code == 235) + -- | sending a mail to a server. This is achieved by sendMessage. If -- something is wrong, it raises an IOexception. sendMail :: String -- ^ sender mail @@ -223,21 +281,42 @@ -- | doSMTPPort open a connection, and do an IO action with the -- connection, and then close it. doSMTPPort :: String -> PortNumber -> (SMTPConnection -> IO a) -> IO a -doSMTPPort host port execution = - bracket (connectSMTPPort host port) closeSMTP execution +doSMTPPort host port = + bracket (connectSMTPPort host port) closeSMTP -- | doSMTP is similar to doSMTPPort, except that it does not require -- port number but connects to the server with port 25. doSMTP :: String -> (SMTPConnection -> IO a) -> IO a -doSMTP host execution = doSMTPPort host 25 execution +doSMTP host = doSMTPPort host 25 -- | doSMTPStream is similar to doSMTPPort, except that its argument -- is a Stream data instead of hostname and port number. doSMTPStream :: BSStream -> (SMTPConnection -> IO a) -> IO a -doSMTPStream s execution = bracket (connectStream s) closeSMTP execution +doSMTPStream s = bracket (connectStream s) closeSMTP -sendMimeMail :: String -> String -> String -> LT.Text - -> LT.Text -> [(T.Text, FilePath)] -> SMTPConnection -> IO () +-- | Send a plain text mail. +sendPlainTextMail :: String -- ^ receiver + -> String -- ^ sender + -> String -- ^ subject + -> LT.Text -- ^ body + -> SMTPConnection -- ^ the connection + -> IO () +sendPlainTextMail to from subject body con = do + renderedMail <- renderMail' myMail + sendMail from [to] (lazyToStrict renderedMail) con + where + myMail = simpleMail' (address to) (address from) (T.pack subject) body + address = Address Nothing . T.pack + +-- | Send a mime mail. +sendMimeMail :: String -- ^ receiver + -> String -- ^ sender + -> String -- ^ subject + -> LT.Text -- ^ plain text body + -> LT.Text -- ^ html body + -> [(T.Text, FilePath)] -- ^ attachments: [(content_type, path)] + -> SMTPConnection + -> IO () sendMimeMail to from subject plainBody htmlBody attachments con = do myMail <- simpleMail (address to) (address from) (T.pack subject) plainBody htmlBody attachments