HaskellNet 0.5.3 → 0.6.2
raw patch · 14 files changed
Files
- CHANGELOG +34/−0
- HaskellNet.cabal +27/−24
- README.md +1/−1
- Updating.md +31/−0
- example/smtp.hs +21/−15
- example/smtp2.hs +34/−0
- src/Network/HaskellNet/Auth.hs +23/−7
- src/Network/HaskellNet/IMAP.hs +93/−38
- src/Network/HaskellNet/IMAP/Parsers.hs +1/−1
- src/Network/HaskellNet/IMAP/Types.hs +2/−0
- src/Network/HaskellNet/POP3.hs +5/−5
- src/Network/HaskellNet/SMTP.hs +256/−279
- src/Network/HaskellNet/SMTP/Internal.hs +354/−0
- src/Text/Packrat/Parse.hs +4/−6
CHANGELOG view
@@ -1,3 +1,37 @@+0.7 (2025-06-08)+ - updated to the lastest GHC, tested with 8.10.7 — 9.12.2 (PR #103)+ Thanks to @thomasjm+ - various improvements in IMAP protocol (#94, #97, #99)+ Thanks to @mpscholten++0.6.1.0 (2023-06-27)+ - fixed bug with wrong IMAP header decoding ([Issue 89](https://github.com/qnikst/HaskellNet/issues/89))+ Thanks to William Arteroi (@wwmoraes) and Nathan Collins (@ntc2)+ - added support for OAuth2 authorization+ Thanks to @paumr.++0.6.0.1 (2022-05-17)+ - GHC 9.0+ support++0.6 (2020-12-27)+----------------+ - sendMail API was simplified (see Updating.md for details)+ - Functions for graceful close were introduced.+ - Use Text type instead of String internally.+ - Use mime-mail.Address type instead of String for representing+ addresses. (Issues #78, #59)+ - Introduce SMTP exceptions family and move to using that+ from fail method.+ - Fixes possible double handle close in case of exceptions (Issue #76)+ - SMTP: Fix issue with extra flushes. Now there are twice+ as few messages during communication and that largely improves+ communication speed.+ - Module HaskellNet.SMTP.Internal was introduced. It contains+ internal functions that may be useful when implementing primitives.+ There is no API stability guarantees on the module.+ - SMTP documentation largely improved+ - Package moved from base64-string to base64 package (Issue #61)+ 0.5.3 (2020-12-22) ------------------
HaskellNet.cabal view
@@ -1,10 +1,12 @@ Name: HaskellNet Synopsis: Client support for POP3, SMTP, and IMAP Description: This package provides client support for the POP3,- SMTP, and IMAP protocols. NOTE: this package will be- split into smaller, protocol-specific packages in the- future.-Version: 0.5.3+ SMTP, and IMAP protocols.+ .+ Full examples can be found in the <https://github.com/qnikst/HaskellNet/tree/master/example repository>.+ Additional documentation on the major updates can be found in the+ <https://github.com/qnikst/HaskellNet/blob/master/Updating.md Updating.md> file+Version: 0.6.2 Copyright: (c) 2006 Jun Mukai Author: Jun Mukai Maintainer: Alexander Vershilov <alexander.vershilov@sirius.online>,@@ -14,21 +16,19 @@ License-file: LICENSE Category: Network Homepage: https://github.com/qnikst/HaskellNet-Cabal-version: >=1.10+Cabal-version: 1.22 Build-type: Simple Tested-with:- GHC ==7.8.4- || ==7.10.3- || ==8.0.2- || ==8.2.2- || ==8.4.4- || ==8.6.5- || ==8.8.4- || ==8.10.2+ GHC ==9.4.8+ || ==9.6.7+ || ==9.8.4+ || ==9.10.2+ || ==9.12.2 Extra-Source-Files: CHANGELOG README.md+ Updating.md example/*.hs Source-Repository head@@ -51,6 +51,7 @@ Network.HaskellNet.IMAP.Types Network.HaskellNet.IMAP.Parsers Network.HaskellNet.SMTP+ Network.HaskellNet.SMTP.Internal Network.HaskellNet.POP3 Network.HaskellNet.POP3.Connection Network.HaskellNet.POP3.Types@@ -62,19 +63,21 @@ Network.Compat Text.Packrat.Pos Text.Packrat.Parse+ Reexported-modules:+ Network.Mail.Mime Build-Depends:- base >= 4.3 && < 4.15,- network >= 2.6.3.1 && < 3.2,- mtl,- bytestring >=0.10.2,- pretty,- array,- cryptohash-md5,- base64-string,- old-time,- mime-mail >= 0.4.7 && < 0.6,- text+ base >= 4.3 && < 4.22,+ network >= 2.6.3.1 && < 3.3,+ mtl >= 2.2.2 && < 2.4,+ bytestring >=0.10.2 && < 0.13,+ pretty >= 1.1.3 && < 1.2,+ array >= 0.5 && < 0.6,+ cryptohash-md5 >= 0.11 && < 0.12,+ base64 < 1.1,+ old-time >= 1.0 && < 1.2,+ mime-mail >= 0.4 && < 0.6,+ text >= 1.0 && < 3 if !impl(ghc >= 8.0) Build-depends: fail >= 4.9.0.0 && <4.10
README.md view
@@ -1,7 +1,7 @@ HaskellNet ========== -+[](https://github.com/qnikst/HaskellNet/actions/workflows/ci.yml) This package provides client support for the E-mail protocols POP3, SMTP, and IMAP.
+ Updating.md view
@@ -0,0 +1,31 @@+# Updating++This document explains how to update package between major versions+of the package.++0.5.x -> 0.6+============++1. Sender, Recipient types were changed from 'Data.Text.Text' to+[Network.Mail.Mime.Address](http://hackage.haskell.org/package/mime-mail-0.5.0/docs/Network-Mail-Mime.html#t:Address).+ This change allows better interoperability with 'mime-mail' package, in addition+ it solved a problem with specifying sender address in the API.+ As Address type implements 'IsString' type class then just having '-XOverloadedStrings'+ extension will be enough. However you should note, that "FirstName LastName <email>"+ will be parsed as `Address Nothing "FirstName LastName <email>"` and not as+ `Address (Just "FirstName LastName") "email"`, it may be surprising but that functionality+ didn't work with older HaskellNet, so it was not changed.+2. Exception. Previously the package exposed only `IOException` custom exceptions were send+ using `failure` (`UserException` constructor). Now there is `SMTPException` family, so+ if you used to capture SMTP exceptions by processing `IOExceptions` you should capture+ `SMTPException` now. The package may still expose `IOException` in case of a network+ failure.+3. `Subject` type is now using Text. Enabling `-XOverladedStrings` extension should help+ in this case.+4. All mail sending functions were deprecated instead of them there is the 'sendMail'+ function. Documentation and deprecation warning for each function explains how to change+ the code to make it work.+5. Now all `doSmtp*` functions implements graceful close, and there is a new `gracefullyCloseSMTP`+ function to run graceful close, you may consider switching to that function from `closeSTMP`.+ However it should be done with care as `gracefullyCloseSTMP` can be run only on the+ connection that is in a awaiting command from the user state.
example/smtp.hs view
@@ -22,37 +22,44 @@ 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+example1 = doSMTP server $ \conn -> do+ let mail = simpleMail' to from subject plainBody+ sendMail mail conn -- | With custom port number-example2 = doSMTPPort server port $ \conn ->- sendPlainTextMail to from subject plainBody conn+example2 = doSMTPPort server port $ \conn -> do+ let mail = simpleMail' to from subject plainBody+ sendMail mail conn -- | Manually open and close the connection example3 = do conn <- connectSMTP server- sendPlainTextMail to from subject plainBody conn+ let mail = simpleMail' to from subject plainBody+ sendMail mail conn closeSMTP conn -- | Send mime mail-example4 = doSMTP server $ \conn ->- sendMimeMail to from subject plainBody htmlBody [] conn+example4 = doSMTP server $ \conn -> do+ mail <- simpleMail to from subject plainBody htmlBody []+ sendMail mail conn -- | With file attachments (modify the `attachments` binding)-example5 = doSMTP server $ \conn ->- sendMimeMail to from subject plainBody htmlBody attachments conn+example5 = doSMTP server $ \conn -> do+ mail <- simpleMail to from subject plainBody htmlBody attachments+ sendMail mail conn -- | With ByteString attachments bsContent = B.pack [43,43,43,43]-example5_2 = doSMTP server $ \conn ->- sendMimeMail' to from subject plainBody htmlBody [("application/zip", "filename.zip", bsContent)] conn+example5_2 = doSMTP server $ \conn -> do+ let mail = simpleMailInMemory to from subject plainBody htmlBody [("application/zip", "filename.zip", bsContent)]+ sendMail mail conn -- | With authentication example6 = doSMTP server $ \conn -> do authSuccess <- authenticate authType username password conn if authSuccess- then sendMimeMail to from subject plainBody htmlBody [] conn+ then do mail <- simpleMail to from subject plainBody htmlBody []+ sendMail mail conn else putStrLn "Authentication failed." -- | Custom@@ -62,11 +69,10 @@ [(Address Nothing "to@test.org")] [(Address Nothing "cc1@test.org"), (Address Nothing "cc2@test.org")] []- [("Subject", T.pack subject)]+ [("Subject", subject)] [[htmlPart htmlBody, plainPart plainBody]] newMail' <- addAttachments attachments newMail- renderedMail <- renderMail' newMail'- sendMail from [to] (S.concat . B.toChunks $ renderedMail) conn+ sendMail newMail' conn closeSMTP conn main = example1
+ example/smtp2.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS -fno-warn-missing-signatures #-}+{-# LANGUAGE OverloadedStrings #-}++import Network.HaskellNet.Auth+import Network.HaskellNet.SMTP+import Network.HaskellNet.SMTP.SSL+import Network.Mail.Mime+import Network.HaskellNet.Debug+import Control.Monad+import qualified Data.Text as T+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as B++-- | Your settings+server = "smtp.yandex.ru"+username = "no-reply@cheops.olimpiada.ru"+password = "Voo3gahm"+authType = PLAIN+from = Address (Just "A V") "no-reply@cheops.olimpiada.ru"+to = Address (Just "V A") "alexander.vershilov@gmail.com"+subject = "Network.HaskellNet.SMTP Test :)"+plainBody = "Hello world!\r\n.\r\nsomething else"+htmlBody = "<html><head></head><body><h1>Hello <i>world!</i></h1></body></html>"+attachments = [] -- example [("application/octet-stream", "/path/to/file1.tar.gz), ("application/pdf", "/path/to/file2.pdf")]++main = do+ conn <- connectSMTPSSLWithSettings server defaultSettingsSMTPSSL{sslLogToConsole=True}+ authSucceed <- authenticate PLAIN (T.unpack username) (T.unpack password) conn+ when authSucceed $ do+ let newMail = Mail from [to] [] [] [("Subject", T.pack subject)] [[htmlPart htmlBody, plainPart plainBody]]+ newMail' <- addAttachments attachments newMail+ sendMail newMail' conn+ Network.HaskellNet.SMTP.SSL.closeSMTP conn+
src/Network/HaskellNet/Auth.hs view
@@ -1,21 +1,30 @@+{-# language CPP #-}+ module Network.HaskellNet.Auth where import Crypto.Hash.MD5-import qualified Codec.Binary.Base64.String as B64 (encode, decode)+import Data.Text.Encoding.Base64 as B64 +#if MIN_VERSION_base64(0,5,0)+import Data.Base64.Types as B64+#endif+ import Data.Word import Data.List import Data.Bits import Data.Array import qualified Data.ByteString as B+import qualified Data.Text as T type UserName = String type Password = String +-- | Authorization types supported by the <https://www.ietf.org/rfc/rfc4954.txt RFC5954> data AuthType = PLAIN | LOGIN | CRAM_MD5+ | XOAUTH2 deriving Eq instance Show AuthType where@@ -24,16 +33,22 @@ showMain PLAIN = "PLAIN" showMain LOGIN = "LOGIN" showMain CRAM_MD5 = "CRAM-MD5"+ showMain XOAUTH2 = "XOAUTH2" b64Encode :: String -> String-b64Encode = map (toEnum.fromEnum)- -- Hotfix for https://github.com/jtdaugherty/HaskellNet/issues/61- . delete '\n'- . B64.encode- . map (toEnum.fromEnum)+b64Encode = T.unpack . encode . T.pack+ where encode =+#if MIN_VERSION_base64(0,5,0)+ B64.extractBase64 . B64.encodeBase64+#else+ B64.encodeBase64+#endif ++ b64Decode :: String -> String-b64Decode = map (toEnum.fromEnum) . B64.decode . map (toEnum.fromEnum)+b64Decode = T.unpack . decode . T.pack+ where decode = B64.decodeBase64Lenient showOctet :: [Word8] -> String showOctet = concatMap hexChars@@ -68,3 +83,4 @@ auth PLAIN _ u p = plain u p auth LOGIN _ u p = let (u', p') = login u p in unwords [u', p'] auth CRAM_MD5 c u p = cramMD5 c u p+auth XOAUTH2 _ u p = b64Encode $ "user=" ++ u ++ "\001auth=" ++ p ++ "\001\001"
src/Network/HaskellNet/IMAP.hs view
@@ -8,14 +8,15 @@ -- ** autenticated state commands , select, examine, create, delete, rename , subscribe, unsubscribe- , list, lsub, status, append+ , list, lsub, status, append, appendFull -- ** selected state commands , check, close, expunge- , search, store, copy+ , search, store, copy, move , idle -- * fetch commands , fetch, fetchHeader, fetchSize, fetchHeaderFields, fetchHeaderFieldsNot , fetchFlags, fetchR, fetchByString, fetchByStringR+ , fetchPeek, fetchRPeek -- * other types , Flag(..), Attribute(..), MailboxStatus(..) , SearchQuery(..), FlagsQuery(..)@@ -23,13 +24,13 @@ ) where -import Network.Socket (PortNumber) import Network.Compat+import qualified Network.HaskellNet.Auth as A import Network.HaskellNet.BSStream import Network.HaskellNet.IMAP.Connection-import Network.HaskellNet.IMAP.Types import Network.HaskellNet.IMAP.Parsers-import qualified Network.HaskellNet.Auth as A+import Network.HaskellNet.IMAP.Types+import Network.Socket (PortNumber) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS@@ -70,6 +71,7 @@ | SUBJECTs String | TEXTs String | TOs String+ | XGMRAW String | UIDs [UID] @@ -99,6 +101,7 @@ showQuery (SUBJECTs s) = "SUBJECT " ++ s showQuery (TEXTs s) = "TEXT " ++ s showQuery (TOs addr) = "TO " ++ addr+ showQuery (XGMRAW s) = "X-GM-RAW " ++ s showQuery (UIDs uids) = concat $ intersperse "," $ map show uids showFlag Seen = "SEEN"@@ -112,6 +115,9 @@ data FlagsQuery = ReplaceFlags [Flag] | PlusFlags [Flag] | MinusFlags [Flag]+ | ReplaceGmailLabels [GmailLabel]+ | PlusGmailLabels [GmailLabel]+ | MinusGmailLabels [GmailLabel] ---------------------------------------------------------------------- -- establish connection@@ -213,10 +219,10 @@ return buf' let (resp, mboxUp, value) = eval pNone (show6 num) buf case resp of- OK _ _ -> do mboxUpdate conn mboxUp- return value- NO _ msg -> fail ("NO: " ++ msg)- BAD _ msg -> fail ("BAD: " ++ msg)+ OK _ _ -> do mboxUpdate conn mboxUp+ return value+ NO _ msg -> fail ("NO: " ++ msg)+ BAD _ msg -> fail ("BAD: " ++ msg) PREAUTH _ msg -> fail ("preauth: " ++ msg) noop :: IMAPConnection -> IO ()@@ -332,13 +338,13 @@ buf2 <- getResponse $ stream conn let (resp, mboxUp, ()) = eval pNone (show6 num) buf2 case resp of- OK _ _ -> mboxUpdate conn mboxUp- NO _ msg -> fail ("NO: "++msg)- BAD _ msg -> fail ("BAD: "++msg)+ OK _ _ -> mboxUpdate conn mboxUp+ NO _ msg -> fail ("NO: "++msg)+ BAD _ msg -> fail ("BAD: "++msg) PREAUTH _ msg -> fail ("PREAUTH: "++msg) where mailLines = BS.lines mailData len = sum $ map ((2+) . BS.length) mailLines- tstr = maybe "" ((" "++) . show) time+ tstr = maybe "" ((" "++) . datetimeToStringIMAP) time fstr = maybe "" ((" ("++) . (++")") . unwords . map show) flags' check :: IMAPConnection -> IO ()@@ -369,6 +375,12 @@ do lst <- fetchByString conn uid "BODY[]" return $ maybe BS.empty BS.pack $ lookup' "BODY[]" lst +-- | Like 'fetch' but without marking the email as seen/read+fetchPeek :: IMAPConnection -> UID -> IO ByteString+fetchPeek conn uid =+ do lst <- fetchByString conn uid "BODY.PEEK[]"+ return $ maybe BS.empty BS.pack $ lookup' "BODY[]" lst+ fetchHeader :: IMAPConnection -> UID -> IO ByteString fetchHeader conn uid = do lst <- fetchByString conn uid "BODY[HEADER]"@@ -377,26 +389,26 @@ 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+ do let fetchCmd = "BODY[HEADER.FIELDS ("++unwords hs++")]"+ lst <- fetchByString conn uid fetchCmd+ return $ maybe BS.empty BS.pack $ lookup' fetchCmd lst fetchHeaderFieldsNot :: IMAPConnection -> UID -> [String] -> IO ByteString fetchHeaderFieldsNot conn uid hs =- do let fetchCmd = "BODY[HEADER.FIELDS.NOT "++unwords hs++"]"+ do let fetchCmd = "BODY[HEADER.FIELDS.NOT ("++unwords hs++")]" lst <- fetchByString conn uid fetchCmd 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 @@ -406,6 +418,13 @@ do lst <- fetchByStringR conn r "BODY[]" return $ map (\(uid, vs) -> (uid, maybe BS.empty BS.pack $ lookup' "BODY[]" vs)) lst++-- | Like 'fetchR' but without marking the email as seen/read+fetchRPeek :: IMAPConnection -> (UID, UID) -> IO [(UID, ByteString)]+fetchRPeek conn range =+ do ls <- fetchByStringR conn range "BODY.PEEK[]"+ return $ map (\(uid, vs) -> (uid, maybe BS.empty BS.pack $ lookup' "BODY[]" vs)) ls+ fetchByString :: IMAPConnection -> UID -> String -> IO [(String, String)] fetchByString conn uid command =@@ -431,9 +450,12 @@ where fstrs fs = "(" ++ (concat $ intersperse " " $ map show fs) ++ ")" toFStr s fstrs' = s ++ (if isSilent then ".SILENT" else "") ++ " " ++ fstrs'- flgs (ReplaceFlags fs) = toFStr "FLAGS" $ fstrs fs- flgs (PlusFlags fs) = toFStr "+FLAGS" $ fstrs fs- flgs (MinusFlags fs) = toFStr "-FLAGS" $ fstrs fs+ flgs (ReplaceGmailLabels ls) = toFStr "X-GM-LABELS" $ fstrs ls+ flgs (PlusGmailLabels ls) = toFStr "+X-GM-LABELS" $ fstrs ls+ flgs (MinusGmailLabels ls) = toFStr "-X-GM-LABELS" $ fstrs ls+ flgs (ReplaceFlags fs) = toFStr "FLAGS" $ fstrs fs+ 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))@@ -449,28 +471,61 @@ copy :: IMAPConnection -> UID -> MailboxName -> IO () copy conn uid mbox = copyFull conn (show uid) mbox +move :: IMAPConnection -> UID -> MailboxName -> IO ()+move conn uid mboxname = sendCommand conn ("UID MOVE " ++ show uid ++ " " ++ mboxname) pNone+ ---------------------------------------------------------------------- -- auxialiary functions +showMonth :: Month -> String+showMonth January = "Jan"+showMonth February = "Feb"+showMonth March = "Mar"+showMonth April = "Apr"+showMonth May = "May"+showMonth June = "Jun"+showMonth July = "Jul"+showMonth August = "Aug"+showMonth September = "Sep"+showMonth October = "Oct"+showMonth November = "Nov"+showMonth December = "Dec"++show2 :: Int -> String+show2 n | n < 10 = '0' : show n+ | otherwise = show n+++show4 :: (Ord a, Num a, Show a) => a -> String+show4 n | n > 1000 = show n+ | n > 100 = '0' : show n+ | n > 10 = "00" ++ show n+ | otherwise = "000" ++ show n+ dateToStringIMAP :: CalendarTime -> String dateToStringIMAP date = concat $ intersperse "-" [show2 $ ctDay date , showMonth $ ctMonth date , show $ ctYear date]- where show2 n | n < 10 = '0' : show n- | otherwise = show n- showMonth January = "Jan"- showMonth February = "Feb"- showMonth March = "Mar"- showMonth April = "Apr"- showMonth May = "May"- showMonth June = "Jun"- showMonth July = "Jul"- showMonth August = "Aug"- showMonth September = "Sep"- showMonth October = "Oct"- showMonth November = "Nov"- showMonth December = "Dec"+timeToStringIMAP :: CalendarTime -> String+timeToStringIMAP c = concat+ $ intersperse ":"+ $ fmap show2 [ctHour c, ctMin c, ctSec c] +-- Convert CalenarTime to "date-time" string per RFC3501+datetimeToStringIMAP :: CalendarTime -> String+datetimeToStringIMAP c =+ "\""+ ++ dateToStringIMAP c+ ++ " "+ ++ timeToStringIMAP c+ ++ " "+ ++ zone (ctTZ c)+ ++ "\""+ where+ zone s =+ (if s>=0 then "+" else "-") +++ show4 (s `div` 3600)+ strip :: ByteString -> ByteString strip = fst . BS.spanEnd isSpace . BS.dropWhile isSpace @@ -482,10 +537,10 @@ lookup' :: String -> [(String, b)] -> Maybe b lookup' _ [] = Nothing-lookup' q ((k,v):xs) | q == lastWord k = return v+lookup' q ((k,v):xs) | q == query k = return v | otherwise = lookup' q xs where- lastWord = last . words+ query = unwords . drop 2 . 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
src/Network/HaskellNet/IMAP/Parsers.hs view
@@ -237,7 +237,7 @@ return $ Right (attrs, sep, mbox) where parseAttr = do char '\\'- choice [ string "Noinferior" >> return Noinferiors+ choice [ string "Noinferiors" >> return Noinferiors , string "Noselect" >> return Noselect , string "Marked" >> return Marked , string "Unmarked" >> return Unmarked
src/Network/HaskellNet/IMAP/Types.hs view
@@ -1,5 +1,6 @@ module Network.HaskellNet.IMAP.Types ( MailboxName+ , GmailLabel , UID , Charset , MailboxInfo(..)@@ -28,6 +29,7 @@ type MailboxName = String type UID = Word64 type Charset = String+type GmailLabel = String data MailboxInfo = MboxInfo { _mailbox :: MailboxName , _exists :: Integer
src/Network/HaskellNet/POP3.hs view
@@ -31,10 +31,10 @@ ) where -import Network.HaskellNet.BSStream-import Network.Socket import Network.Compat import qualified Network.HaskellNet.Auth as A+import Network.HaskellNet.BSStream+import Network.Socket import Data.ByteString (ByteString) import qualified Data.ByteString as B@@ -159,9 +159,9 @@ (UIDL msg) -> "UIDL " ++ maybe "" show msg (APOP usern passw) -> "APOP " ++ usern ++ " " ++ hexDigest (apopKey conn ++ passw)- (AUTH _ _ _) -> error "BUG: AUTH should not get matched here"- (RETR _) -> error "BUG: RETR should not get matched here"- (TOP _ _) -> error "BUG: TOP should not get matched here"+ AUTH _ _ _ -> error "sendCommand: impossible happened AUTH expected to be processed in the preceeding clause"+ RETR _ -> error "sendCommand: impossible happened AUTH expected to be processed in the preceeding clause"+ TOP _ _ -> error "sendCommand: impossible happened AUTH expected to be processed in the preceeding clause" user :: POP3Connection -> String -> IO () user conn name = do (resp, _) <- sendCommand conn (USER name)
src/Network/HaskellNet/SMTP.hs view
@@ -1,141 +1,167 @@ {-# 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."+This module provides functions client side of the SMTP protocol. -Notes for the above example:+A basic usage 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.+@+\{\-\# LANGUAGE OverloadedStrings \#\-\}+import "Network.HaskellNet.SMTP"+import "Network.HaskellNet.Auth"+import "Network.Mail.Mime"+import "System.Exit" (die) - /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- <http://hackage.haskell.org/package/HaskellNet-SSL HaskellNet-SSL>- package.+main :: IO ()+main = 'doSMTP' "your.smtp.server.com" $ \\conn -> do -- (1)+ authSucceed <- 'authenticate' 'PLAIN' "username" "password" conn -- (2)+ if authSucceed+ then do+ let mail = 'Network.Mail.Mime.simpleMail''+ "receiver\@server.com"+ "sender\@server.com"+ "subject"+ "Hello! This is the mail body!"+ sendMail mail conn -- (3)+ else die "Authentication failed."+@ - * 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.+Notes for the above example: + * @(1)@ The connection (@conn::@'SMTPConnection') is opened using the 'doSMTP' function.+ We can use this connection to communicate with @SMTP@ server.+ * @(2)@ The 'authenticate' function authenticates to the server with the specified 'AuthType'.+ It returns a 'Bool' indicating either the authentication succeed or not.+ * @(3)@ The 'sendMail' is used to send a email a plain text email. - * To send a mail you can use 'sendPlainTextMail' for plain text mail, or 'sendMimeMail'- for mime mail.+__N.B.__ For /SSL\/TLS/ support you may establish the connection using+ the functions (such as @connectSMTPSSL@) provided by the @Network.HaskellNet.SMTP.SSL@ module+ of the <http://hackage.haskell.org/package/HaskellNet-SSL HaskellNet-SSL> package. -} module Network.HaskellNet.SMTP- ( -- * Types- Command(..)- , Response(..)- , AuthType(..)- , SMTPConnection- -- * Establishing Connection- , connectSMTPPort- , connectSMTP- , connectStream- -- * Operation to a Connection- , sendCommand- , closeSMTP- -- * Other Useful Operations- , authenticate- , sendMail+ ( -- * Workflow+ -- $workflow++ -- ** Controlling connections+ -- $controlling-connections+ SMTPConnection+ -- $controlling-connections-1 , doSMTPPort , doSMTP , doSMTPStream+ -- $controlling-connections-2++ -- ** Authentication+ , authenticate+ -- $authentication+ , AuthType(..)++ -- ** Sending emails+ -- $sending-mail+ , sendMail+ -- *** Deprecated functions , sendPlainTextMail , sendMimeMail , sendMimeMail' , sendMimeMail2- )- where+ -- * Low level commands+ -- ** Establishing Connection+ -- $low-level-connection+ , connectSMTPPort+ , connectSMTP+ , connectStream+ , closeSMTP+ , gracefullyCloseSMTP+ , SMTPException(..)+ ) where import Network.HaskellNet.BSStream-import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Network.BSD (getHostName) import Network.Socket import Network.Compat -import Control.Applicative ((<$>))+import Control.Applicative import Control.Exception import Control.Monad (unless, when) -import Data.Char (isDigit)- import Network.HaskellNet.Auth import Network.Mail.Mime import qualified Data.ByteString.Lazy as B-import qualified Data.ByteString as S import qualified Data.Text.Lazy as LT import qualified Data.Text as T --- The response field seems to be unused. It's saved at one place, but never--- retrieved.-data SMTPConnection = SMTPC { bsstream :: !BSStream, _response :: ![ByteString] }+import GHC.Stack+import Prelude+import Network.HaskellNet.SMTP.Internal -data Command = HELO String- | EHLO String- | MAIL String- | RCPT String- | DATA ByteString- | EXPN String- | VRFY String- | HELP String- | AUTH AuthType UserName Password- | NOOP- | RSET- | QUIT- deriving (Show, Eq) -type ReplyCode = Int+-- $workflow+-- The common workflow while working with the library is:+--+-- 1. Establish a new connection+-- 2. Authenticate to the server+-- 3. Perform message sending+-- 4. Close connections+--+-- Steps 1 and 4 are combined together using @bracket@-like API. Other than that+-- the documentation sections are structured according to this workflow. -data Response = Ok- | SystemStatus- | HelpMessage- | ServiceReady- | ServiceClosing- | UserNotLocal- | CannotVerify- | StartMailInput- | ServiceNotAvailable- | MailboxUnavailable- | ErrorInProcessing- | InsufficientSystemStorage- | SyntaxError- | ParameterError- | CommandNotImplemented- | BadSequence- | ParameterNotImplemented- | MailboxUnavailableError- | UserNotLocalError- | ExceededStorage- | MailboxNotAllowed- | TransactionFailed- deriving (Show, Eq)+-- $controlling-connections +-- $controlling-connections-1+-- The library encourages creation of 'SMTPConnection' using the @doSMTP@-family functions.+-- These functions provide @bracket@-like pattern that manages connection state:+-- creates a connection, passes it to the user defined @IO@ action and frees connection+-- when the action exits. This approach is simple and exception safe.+--+-- __N.B.__ It should be noted that none of these functions implements keep alive of any kind,+-- so the server is free to close the connection by timeout even the end of before the users+-- action exits.+--++-- $controlling-connections-2+--+-- __NOTE:__ For /SSL\/TLS/ support you may establish the connection using+-- the functions (such as @connectSMTPSSL@) provided by the @Network.HaskellNet.SMTP.SSL@ module+-- of the <http://hackage.haskell.org/package/HaskellNet-SSL HaskellNet-SSL> package.+--+-- @bracket-@ style is not the only possible style for resource management,+-- it's possible to use <http://hackage.haskell.org/package/resourcet resourcet> or+-- <http://hackage.haskell.org/package/resource-pool resource-pool> as well. In both of the+-- approaches you need to use low-level 'connectSTM*' and 'closeSMTP' functions.+--+-- Basic example using @resourcet@.+--+-- @+-- \{\-\# LANGUAGE OverloadedStrings \#\-\}+-- import "Network.HaskellNet.SMTP"+-- import "Network.HaskellNet.Auth"+-- import "Control.Monad.Trans.Resource"+-- import "System.Exit" (die)+--+-- main :: IO ()+-- main = 'Control.Monad.Trans.Resource.runResourceT' $ do+-- (key, conn)+-- <- 'Control.Monad.Trans.Resource.allocate'+-- ('connectSMTP' "your.smtp.server.com")+-- ('closeSMTP')+-- ... conn+-- @+--+-- This approach allows resource management even if the code does not form+-- a stack, so is more general.+--+-- __NOTE__. SMTP protocol advices to use 'QUIT' command for graceful connection+-- close. Before version 0.6 the library never sent it, so does 'closeSMTP' call.+--+-- Starting from 0.6 'doSMTP'-family uses graceful exit and sends 'QUIT' before terminating+-- a connection. This way of termination is exposed as 'gracefullyCloseSTMP' function,+-- however it's not a default method because it requires a connection to be in+-- a valid state. So it's not possible to guarantee backwards compatibility.+ -- | connecting SMTP server with the specified name and port number. connectSMTPPort :: String -- ^ name of the server -> PortNumber -- ^ port number@@ -149,229 +175,180 @@ -> IO SMTPConnection connectSMTP = flip connectSMTPPort 25 -tryCommand :: SMTPConnection -> Command -> Int -> [ReplyCode]- -> IO ByteString-tryCommand conn cmd tries expectedReplies = do- (code, msg) <- sendCommand conn cmd- case () of- _ | code `elem` expectedReplies -> return msg- _ | tries > 1 ->- tryCommand conn cmd (tries - 1) expectedReplies- | otherwise -> do- bsClose (bsstream conn)- fail $ "cannot execute command " ++ show cmd ++- ", " ++ prettyExpected expectedReplies ++- ", " ++ prettyReceived code msg-- where- prettyReceived :: Int -> ByteString -> String- prettyReceived co ms = "but received" ++ show co ++ " (" ++ BS.unpack ms ++ ")"-- prettyExpected :: [ReplyCode] -> String- prettyExpected [x] = "expected reply code of " ++ show x- prettyExpected xs = "expected any reply code of " ++ show xs---- | create SMTPConnection from already connected Stream-connectStream :: BSStream -> IO SMTPConnection+-- | Create SMTPConnection from already connected Stream+--+-- Throws @CantConnect :: SMTPException@ in case if got illegal+-- greeting.+connectStream :: HasCallStack => BSStream -> IO SMTPConnection connectStream st = do (code1, _) <- parseResponse st- unless (code1 == 220) $- do bsClose st- fail "cannot connect to the server"- senderHost <- getHostName+ unless (code1 == 220) $ do+ bsClose st+ throwIO $ UnexpectedGreeting code1+ senderHost <- T.pack <$> getHostName msg <- tryCommand (SMTPC st []) (EHLO senderHost) 3 [250] return (SMTPC st (tail $ BS.lines msg)) -parseResponse :: BSStream -> IO (ReplyCode, ByteString)-parseResponse st =- do (code, bdy) <- readLines- return (read $ BS.unpack code, BS.unlines bdy)- where readLines =- do l <- bsGetLine st- 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)- else return (c, [BS.tail bdy]) ---- | send a method to a server-sendCommand :: SMTPConnection -> Command -> IO (ReplyCode, ByteString)-sendCommand (SMTPC conn _) (DATA dat) =- do bsPutCrLf conn $ BS.pack "DATA"- (code, msg) <- parseResponse conn- unless (code == 354) $ fail $ "this server cannot accept any data. code: " ++ show code ++ ", msg: " ++ BS.unpack msg- mapM_ (sendLine . stripCR) $ BS.lines dat ++ [BS.pack "."]- parseResponse conn- where sendLine = bsPutCrLf conn- stripCR bs = case BS.unsnoc bs of- Just (line, '\r') -> line- _ -> bs-sendCommand (SMTPC conn _) (AUTH LOGIN username password) =- do bsPutCrLf conn command- (_, _) <- parseResponse conn- bsPutCrLf conn $ BS.pack userB64- (_, _) <- parseResponse conn- bsPutCrLf conn $ BS.pack passB64- parseResponse conn- where command = BS.pack "AUTH LOGIN"- (userB64, passB64) = login username password-sendCommand (SMTPC conn _) (AUTH at username password) =- do bsPutCrLf conn command- (code, msg) <- parseResponse conn- unless (code == 334) $ fail $ "authentication failed. code: " ++ show code ++ ", msg: " ++ BS.unpack msg- bsPutCrLf conn $ BS.pack $ auth at (BS.unpack msg) username password- parseResponse conn- where command = BS.pack $ unwords ["AUTH", show at]-sendCommand (SMTPC conn _) meth =- do bsPutCrLf conn $ BS.pack command- parseResponse conn- where command = case meth of- (HELO param) -> "HELO " ++ param- (EHLO param) -> "EHLO " ++ param- (MAIL param) -> "MAIL FROM:<" ++ param ++ ">"- (RCPT param) -> "RCPT TO:<" ++ param ++ ">"- (EXPN param) -> "EXPN " ++ param- (VRFY param) -> "VRFY " ++ param- (HELP msg) -> if null msg- then "HELP\r\n"- else "HELP " ++ msg- NOOP -> "NOOP"- RSET -> "RSET"- QUIT -> "QUIT"- (DATA _) ->- error "BUG: DATA pattern should be matched by sendCommand patterns"- (AUTH {}) ->- error "BUG: AUTH pattern should be matched by sendCommand patterns"---- | close the connection. This function send the QUIT method, so you--- do not have to QUIT method explicitly.-closeSMTP :: SMTPConnection -> IO ()-closeSMTP (SMTPC conn _) = bsClose conn--{--I must be being stupid here--I can't seem to be able to catch the exception arising from the-connection already being closed this would be the correct way to do it-but instead we're being naughty above by just closes the connection-without first sending QUIT--closeSMTP c@(SMTPC conn _) =- do sendCommand c QUIT- bsClose conn `catch` \(_ :: IOException) -> return ()--}+-- $authentication {- |-This function will return 'True' if the authentication succeeds.-Here's an example of sending a mail with a server that requires-authentication:+Authenticates user on the remote server. Returns 'True' if the authentication succeeds,+otherwise returns 'False'. -> 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."+Usage example:++@+\{\-\# LANGUAGE OverloadedStrings \#\-\}+authSucceed <- 'authenticate' 'PLAIN' "username" "password" conn+if authSucceed+then 'sendPlainTextMail' "receiver\@server.com" "sender\@server.com" "subject" "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- -> [String] -- ^ receivers- -> ByteString -- ^ data- -> SMTPConnection- -> IO ()-sendMail sender receivers dat conn = do- sendAndCheck (MAIL sender)- mapM_ (sendAndCheck . RCPT) receivers- sendAndCheck (DATA dat)- return ()- where- -- Try the command once and @fail@ if the response isn't 250.- sendAndCheck cmd = tryCommand conn cmd 1 [250, 251]+-- $authentication+-- __N.B.__ The choice of the authentication method is currently explicit and the library+-- does not analyze server capabilities reply for choosing the right method.+-- --- | doSMTPPort open a connection, and do an IO action with the--- connection, and then close it.+-- | 'doSMTPPort' opens a connection to the given port server and+-- performs an IO action with the connection, and then close it.+--+-- 'SMTPConnection' is freed once 'IO' action scope is finished, it means that+-- 'SMTPConnection' value should not escape the action scope. doSMTPPort :: String -> PortNumber -> (SMTPConnection -> IO a) -> IO a-doSMTPPort host port =- bracket (connectSMTPPort host port) closeSMTP+doSMTPPort host port f =+ bracket (connectSMTPPort host port)+ (\(SMTPC conn _) -> bsClose conn)+ (\c -> f c >>= \x -> quitSMTP c >> pure x) --- | doSMTP is similar to doSMTPPort, except that it does not require--- port number but connects to the server with port 25.+-- | 'doSMTP' is similar to 'doSMTPPort', except that it does not require+-- port number and connects to the default SMTP port — 25. doSMTP :: String -> (SMTPConnection -> IO a) -> IO a 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' is similar to 'doSMTPPort', except that its argument+-- is a Stream data instead of hostname and port number. Using this function+-- you can embed connections maintained by the other libraries or add debug info+-- in a common way.+--+-- Using this function you can create an 'SMTPConnection' from an already+-- opened connection stream. See more info on the 'BStream' abstraction in the+-- "Network.HaskellNet.BSStream" module. doSMTPStream :: BSStream -> (SMTPConnection -> IO a) -> IO a-doSMTPStream s = bracket (connectStream s) closeSMTP+doSMTPStream s f =+ bracket (connectStream s)+ (\(SMTPC conn _) -> bsClose conn)+ (\c -> f c >>= \x -> quitSMTP c >> pure x) +-- $sending-mail+--+-- Since version 0.6 there is only one function 'sendMail' that sends a email+-- rendered using mime-mail package. Historically there is a family of @send*Mail@+-- functions that provide simpler interface but they basically mimic the functions+-- from the mime-mail package, and it's encouraged to use those functions directly.+--+-- +------------------------+------------+----------+-------------+-------------++-- | Method | Plain text | Html body| Attachments | Note |+-- | | body | | | |+-- +========================+============+==========+=============+=============++-- | 'sendMail' | Uses mail-mime 'Mail' type | |+-- +------------------------+------------+----------+-------------+-------------++-- | 'sendPlainTextMail' | ✓ | ✗ | ✗ | deprecated |+-- +------------------------+------------+----------+-------------+-------------++-- | 'sendMimeMail' | ✓ | ✓ | ✓ (filepath)| deprecated |+-- +------------------------+------------+----------+-------------+-------------++-- | 'sendMimeMail'' | ✓ | ✓ | ✓ (memory) | deprecated |+-- +------------------------+------------+----------+-------------+-------------++-- | 'sendMimeMail2' | Uses mail-mime 'Mail' type | deprecated |+-- +------------------------+-------------------------------------+-------------++ -- | Send a plain text mail.-sendPlainTextMail :: String -- ^ receiver- -> String -- ^ sender- -> String -- ^ subject+--+-- __DEPRECATED__. Instead of @sendPlainTextMail to from subject plainBody@ use:+--+-- @+-- mail = 'Network.Mail.Mime.simpleMail'' to from subject plainBody+-- sendMail mail conn+-- @+{-# DEPRECATED sendPlainTextMail "Use 'sendMail (Network.Mail.Mime.simpleMail' to from subject plainBody)' instead" #-}+sendPlainTextMail :: Address -- ^ receiver+ -> Address -- ^ sender+ -> T.Text -- ^ 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+sendPlainTextMail to from subject body con =+ let mail = simpleMail' to from subject body+ in sendMail mail con + -- | Send a mime mail. The attachments are included with the file path.-sendMimeMail :: String -- ^ receiver- -> String -- ^ sender- -> String -- ^ subject+--+-- __DEPRECATED__. Instead of @sendMimeMail to from subject plainBody htmlBody attachments@ use:+--+-- @+-- mail <- 'Network.Mail.Mime.simpleMail' to from subject plainBody htmlBody attachments+-- sendMail mail conn+-- @+--+{-# DEPRECATED sendMimeMail "Use 'Network.Mail.Mime.simpleMail to from subject plainBody htmlBody attachments >>= \\mail -> sendMail mail conn' instead" #-}+sendMimeMail :: Address -- ^ receiver+ -> Address -- ^ sender+ -> T.Text -- ^ 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- renderedMail <- renderMail' myMail- sendMail from [to] (lazyToStrict renderedMail) con- where- address = Address Nothing . T.pack+ myMail <- simpleMail to from subject plainBody htmlBody attachments+ sendMail myMail con -- | Send a mime mail. The attachments are included with in-memory 'ByteString'.-sendMimeMail' :: String -- ^ receiver- -> String -- ^ sender- -> String -- ^ subject+--+-- __DEPRECATED__. Instead of @sendMimeMail to from subject plainBody htmlBody attachments@ use:+--+-- @+-- let mail = Network.Mail.Mime.simpleMailInMemory to from subject plainBody htmlBody attachments+-- sendMail mail conn+-- @+--+{-# DEPRECATED sendMimeMail' "Use 'sendMail (Network.Mail.Mime.simpleMailInMemory to from subject plainBody htmlBody attachments) conn'" #-}+sendMimeMail' :: Address -- ^ receiver+ -> Address -- ^ sender+ -> T.Text -- ^ subject -> LT.Text -- ^ plain text body -> LT.Text -- ^ html body -> [(T.Text, T.Text, B.ByteString)] -- ^ attachments: [(content_type, file_name, content)] -> SMTPConnection -> IO () sendMimeMail' to from subject plainBody htmlBody attachments con = do- let myMail = simpleMailInMemory (address to) (address from) (T.pack subject)- plainBody htmlBody attachments- sendMimeMail2 myMail con- where- address = Address Nothing . T.pack--sendMimeMail2 :: Mail -> SMTPConnection -> IO ()-sendMimeMail2 mail con = do- let (Address _ from) = mailFrom mail- recps = map (T.unpack . addressEmail)- $ (mailTo mail ++ mailCc mail ++ mailBcc mail)- when (null recps) $ fail "no receiver specified."- renderedMail <- renderMail' $ mail { mailBcc = [] }- sendMail (T.unpack from) recps (lazyToStrict renderedMail) con---- haskellNet uses strict bytestrings--- TODO: look at making haskellnet lazy-lazyToStrict :: B.ByteString -> S.ByteString-lazyToStrict = B.toStrict+ let myMail = simpleMailInMemory to from subject plainBody htmlBody attachments+ sendMail myMail con -crlf :: BS.ByteString-crlf = BS.pack "\r\n"+-- | Sends email in generated using 'mime-mail' package.+--+-- Throws 'UserError' @::@ 'IOError' if recipient address not specified.+{-# DEPRECATED sendMimeMail2 "Use sendMail instead" #-}+sendMimeMail2 :: HasCallStack => Mail -> SMTPConnection -> IO ()+sendMimeMail2 = sendMail -bsPutCrLf :: BSStream -> ByteString -> IO ()-bsPutCrLf h s = bsPut h s >> bsPut h crlf >> bsFlush h+-- | Sends email using 'Mail' type from the mime-mail package.+--+-- Sender is taken from the 'mailFrom' field of the @mail@. Message+-- is sent to all the recipients in the 'mailTo', 'mailCc', 'mailBcc' fields.+-- But 'mailBcc' emails are not visible to other recipients as it should be.+--+-- @since 0.6+sendMail :: HasCallStack => Mail -> SMTPConnection -> IO ()+sendMail mail conn = do+ let recps = mailTo mail ++ mailCc mail ++ mailBcc mail+ when (null recps) $ throwIO $ NoRecipients mail+ renderedMail <- renderMail' $ mail { mailBcc = [] }+ sendMailData (mailFrom mail) recps (B.toStrict renderedMail) conn
+ src/Network/HaskellNet/SMTP/Internal.hs view
@@ -0,0 +1,354 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DerivingStrategies #-}+-- |+-- Internal functions that are used in the SMTP protocol,+-- you may need these module in case if you want to implement additional+-- functionality that does not exist in the "Network.HaskellNet.SMTP".+--+-- __Example__.+--+-- One example could be sending multiple emails over the same stream+-- in order to use that you may want to use 'RSET' command, so you can implement:+--+-- @+-- import "Network.HaskellNet.SMTP.Internal"+--+-- resetConnection :: SMTPConnection -> IO ()+-- resetConnection conn = do+-- (code, _) <- 'sendCommand' conn 'RSET'+-- 'unless' (code == 250) $ 'throwIO' $ 'UnexpectedReply' 'RSET' [250] code ""+-- @+--+module Network.HaskellNet.SMTP.Internal+ ( SMTPConnection(..)+ , Command(..)+ , SMTPException(..)+ , ReplyCode+ , tryCommand+ , parseResponse+ , sendCommand+ , sendMailData+ , closeSMTP+ , gracefullyCloseSMTP+ , quitSMTP+ -- * Reexports+ , Address(..)+ ) where++import Control.Exception+import Control.Monad (unless)+import Data.Char (isDigit)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Typeable++import Network.HaskellNet.Auth+import Network.HaskellNet.BSStream++import Network.Mail.Mime++import Prelude++-- | All communication with server is done using @SMTPConnection@ value.+data SMTPConnection = SMTPC {+ -- | Connection communication channel.+ bsstream :: !BSStream,+ -- | Server properties as per reply to the 'EHLO' request.+ _response :: ![ByteString]+ }++-- | SMTP commands.+--+-- Supports basic and extended SMTP protocol without TLS support.+--+-- For each command we provide list of the expected reply codes that happens in success and failure cases+-- respectively.+data Command+ = -- | The @HELO@ command initiates the SMTP session conversation. The client greets the server and introduces itself.+ -- As a rule, HELO is attributed with an argument that specifies the domain name or IP address of the SMTP client.+ --+ -- Success: 250+ -- Failure: 504, 550+ HELO T.Text+ | -- | @EHLO@ is an alternative to HELO for servers that support the SMTP service extensions (ESMTP)+ --+ -- Success: 250+ -- Failure: 502, 504, 550+ EHLO T.Text+ | -- | @MAIL FROM@ command initiates a mail transfer. As an argument, MAIL FROM includes a sender mailbox (reverse-path)+ -- can accept optional parameters.+ --+ -- Success: 250+ --+ -- Failure: 451, 452, 455, 503, 550, 552, 553, 555+ MAIL T.Text+ | -- | The @RCPT TO@ command specifies exactly one recipient.+ --+ -- Success: 250 251+ --+ -- Failure: 450 451 452 455 503 550 551 552 553 555+ RCPT T.Text+ | -- | With the @DATA@ command, the client asks the server for permission to transfer the mail data.+ --+ -- Success: 250, 354+ --+ -- Failure: 450 451 452 503 550 552 554+ --+ -- Client just sends data and after receiving 354 starts streaming email, terminating transfer by+ -- sending @\r\n.\r\n@.+ DATA ByteString+ | -- |+ -- @EXPN@ is used to verify whether a mailing list in the argument exists on the local host.+ -- The positive response will specify the membership of the recipients.+ --+ -- Success: 250 252+ --+ -- Failure: 502 504 550+ EXPN T.Text+ | -- |+ -- @VRFY@ is used to verify whether a mailbox in the argument exists on the local host.+ -- The server response includes the user’s mailbox and may include the user’s full name.+ --+ -- Success: 250 251 252+ --+ -- Failure: 502 504 550 551 553+ VRFY T.Text+ | -- |+ -- With the @HELP@ command, the client requests a list of commands the server supports, may request+ -- help for specific command+ --+ -- Success: 211 214+ --+ -- Failure: 502 504+ HELP T.Text+ | -- | Authorization support+ AUTH AuthType UserName Password+ | -- | @NOOP@ can be used to verify if the connection is alive+ --+ -- Success: 250+ NOOP+ | -- | @RSET@ Resets the state+ --+ -- Success: 250+ RSET+ | -- | @QUIT@ asks server to close connection. Client should terminate the connection when receives+ -- status.+ --+ -- Success: 221+ QUIT+ deriving (Show, Eq)++-- | Code reply from the server. It's always 3 digit integer.+type ReplyCode = Int++-- | Exceptions that can happen during communication.+data SMTPException+ = -- | Reply code was not in the list of expected.+ --+ -- * @Command@ - command that was sent.+ -- * @[ReplyCode]@ -- list of expected codes+ -- * @ReplyCode@ -- the code that we have received+ -- * @ByteString@ -- additional data returned by the server.+ UnexpectedReply Command [ReplyCode] ReplyCode BS.ByteString+ -- | The server didn't accept the start of the message delivery+ | NotConfirmed ReplyCode BS.ByteString+ -- | The server does not support current authentication method+ | AuthNegotiationFailed ReplyCode BS.ByteString+ -- | Can't send email because no recipients were specified.+ | NoRecipients Mail+ -- | Received an unexpected greeting from the server.+ | UnexpectedGreeting ReplyCode+ deriving (Show)+ deriving (Typeable)++instance Exception SMTPException where+ displayException (UnexpectedReply cmd expected code msg) =+ "Cannot execute command " ++ show cmd +++ ", " ++ prettyExpected expected +++ ", " ++ prettyReceived code msg+ where+ prettyReceived :: Int -> ByteString -> String+ prettyReceived co ms = "but received" ++ show co ++ " (" ++ BS.unpack ms ++ ")"+ prettyExpected :: [ReplyCode] -> String+ prettyExpected [x] = "expected reply code of " ++ show x+ prettyExpected xs = "expected any reply code of " ++ show xs+ displayException (NotConfirmed code msg) =+ "This server cannot accept any data. code: " ++ show code ++ ", msg: " ++ BS.unpack msg+ displayException (AuthNegotiationFailed code msg) =+ "Authentication failed. code: " ++ show code ++ ", msg: " ++ BS.unpack msg+ displayException (NoRecipients _mail) =+ "No recipients were specified"+ displayException (UnexpectedGreeting code) =+ "Expected greeting from the server, but got: " <> show code+++-- | Safe wrapper for running a client command over the SMTP+-- connection.+--+-- /Note on current behavior/+--+-- We allow the command to fail several times, retry+-- happens in case if we have received unexpected status code.+-- In this case message will be sent again. However in case+-- of other synchronous or asynchronous exceptions there will+-- be no retries.+--+-- It case if number of retries were exceeded connection will+-- be closed automatically.+--+-- The behaviors in notes will likely be changed in the future+-- and should not be relied upon, see issues 76, 77.+tryCommand+ :: SMTPConnection -- ^ Connection+ -> Command -- ^ Supported command+ -> Int -- ^ Number of allowed retries+ -> [ReplyCode] -- ^ List of accepted codes+ -> IO ByteString -- ^ Resulting data+tryCommand conn cmd tries expectedReplies = do+ (code, msg) <- sendCommand conn cmd+ case () of+ _ | code `elem` expectedReplies -> return msg+ _ | tries > 1 ->+ tryCommand conn cmd (tries - 1) expectedReplies+ | otherwise ->+ throwIO $ UnexpectedReply cmd expectedReplies code msg++-- | Read response from the stream. Response consists of the code+-- and one or more lines of data.+--+-- In case if it's not the last line of reply the code is followed+-- by the '-' sign. We return the code and all the data with the code+-- stripped.+--+-- Eg.:+--+-- @+-- "250-8BITMIME\\r"+-- "250-PIPELINING\\r"+-- "250-SIZE 42991616\\r"+-- "250-AUTH LOGIN PLAIN XOAUTH2\\r"+-- "250-DSN\\r"+-- "250 ENHANCEDSTATUSCODES\\r"+-- @+--+-- Returns:+--+-- @+-- (250, "8BITMIME\\nPIPELINING\nSIZE 42991616\\nAUTH LOGIN PLAIN XOAUTH2\\nDSN\\nENHANCEDSTATUSCODES")+-- @+--+-- Throws 'SMTPException'.+parseResponse :: BSStream -> IO (ReplyCode, ByteString)+parseResponse st =+ do (code, bdy) <- readLines+ return (read $ BS.unpack code, BS.unlines bdy)+ where readLines =+ do l <- bsGetLine st+ 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)+ else return (c, [BS.tail bdy])++-- | Sends a 'Command' to the server. Function that performs all the logic+-- for sending messages. Throws an exception if something goes wrong.+--+-- Throws 'SMTPException'.+sendCommand+ :: SMTPConnection+ -> Command+ -> IO (ReplyCode, ByteString)+sendCommand (SMTPC conn _) (DATA dat) =+ do bsPutCrLf conn "DATA"+ (code, msg) <- parseResponse conn+ unless (code == 354) $ throwIO $ NotConfirmed code msg+ mapM_ (sendLine . stripCR) $ BS.lines dat ++ [BS.pack "."]+ parseResponse conn+ where sendLine = bsPutCrLf conn+ stripCR bs = case BS.unsnoc bs of+ Just (line, '\r') -> line+ _ -> bs+sendCommand (SMTPC conn _) (AUTH LOGIN username password) =+ do bsPutCrLf conn command+ (_, _) <- parseResponse conn+ bsPutCrLf conn $ BS.pack userB64+ (_, _) <- parseResponse conn+ bsPutCrLf conn $ BS.pack passB64+ parseResponse conn+ where command = "AUTH LOGIN"+ (userB64, passB64) = login username password+sendCommand (SMTPC conn _) (AUTH at username password) =+ do bsPutCrLf conn $ T.encodeUtf8 command+ (code, msg) <- parseResponse conn+ unless (code == 334) $ throwIO $ AuthNegotiationFailed code msg+ bsPutCrLf conn $ BS.pack $ auth at (BS.unpack msg) username password+ parseResponse conn+ where command = T.unwords ["AUTH", T.pack (show at)]+sendCommand (SMTPC conn _) meth =+ do bsPutCrLf conn $! T.encodeUtf8 command+ parseResponse conn+ where command = case meth of+ (HELO param) -> "HELO " <> param+ (EHLO param) -> "EHLO " <> param+ (MAIL param) -> "MAIL FROM:<" <> param <> ">"+ (RCPT param) -> "RCPT TO:<" <> param <> ">"+ (EXPN param) -> "EXPN " <> param+ (VRFY param) -> "VRFY " <> param+ (HELP msg) -> if T.null msg+ then "HELP\r\n"+ else "HELP " <> msg+ NOOP -> "NOOP"+ RSET -> "RSET"+ QUIT -> "QUIT"+ DATA _ -> error "sendCommand: impossible happened DATA command expected to be processed in thepreceeding clause"+ AUTH _ _ _ -> error "sendCommand: impossible happened AUTH command expected to be processed in the preceeding clause"++-- | Sends quit to the server. Connection must be terminated afterwards, i.e. it's not+-- allowed to issue any command on this connection.+quitSMTP :: SMTPConnection -> IO ()+quitSMTP c = do+ _ <- tryCommand c QUIT 1 [221]+ pure ()++-- | Terminates the connection. 'Quit' command is not send in this case.+-- It's safe to issue this command at any time if the connection is still+-- open.+closeSMTP :: SMTPConnection -> IO ()+closeSMTP (SMTPC conn _) = bsClose conn++-- | Gracefully closes SMTP connection. Connection should be in available+-- state. First it sends quit command and then closes connection itself.+-- Connection should not be used after this command exits (even if it exits with an exception).+-- This command may throw an exception in case of network failure or+-- protocol failure when sending 'QUIT' command. If it happens connection+-- nevertheless is closed.+--+-- @since 0.6+gracefullyCloseSMTP :: SMTPConnection -> IO ()+gracefullyCloseSMTP c@(SMTPC conn _) = quitSMTP c `finally` bsClose conn++-- | Sends a mail to the server.+--+-- Throws 'SMTPException'.+sendMailData :: Address -- ^ sender mail+ -> [Address] -- ^ receivers+ -> ByteString -- ^ data+ -> SMTPConnection+ -> IO ()+sendMailData sender receivers dat conn = do+ sendAndCheck (MAIL (addressEmail sender))+ mapM_ (sendAndCheck . RCPT . addressEmail) receivers+ sendAndCheck (DATA dat)+ return ()+ where+ sendAndCheck cmd = tryCommand conn cmd 1 [250, 251]++-- | Just a crlf constant.+crlf :: BS.ByteString+crlf = BS.pack "\r\n"++-- | Write a message ending with ctlf.+bsPutCrLf :: BSStream -> ByteString -> IO ()+bsPutCrLf h s = bsPut h (s <> crlf)
src/Text/Packrat/Parse.hs view
@@ -12,7 +12,6 @@ import Text.Packrat.Pos import Control.Monad-import Control.Applicative (Applicative(..)) import qualified Control.Applicative as A import qualified Control.Monad.Fail as Fail@@ -84,7 +83,7 @@ (<|>) :: Derivs d => Parser d v -> Parser d v -> Parser d v (Parser p1) <|> (Parser p2) = Parser parse where parse dvs = first dvs (p1 dvs)- first _ (result @ (Parsed {})) = result+ first _ (result@(Parsed {})) = result first dvs (NoParse err) = second err (p2 dvs) second err1 (Parsed val rem err) = Parsed val rem (joinErrors err1 err)@@ -94,7 +93,7 @@ satisfy :: Derivs d => Parser d v -> (v -> Bool) -> Parser d v satisfy (Parser p) test = Parser parse where parse dvs = check dvs (p dvs)- check dvs (result @ (Parsed val _ _)) =+ check dvs (result@(Parsed val _ _)) = if test val then result else NoParse (nullError dvs)@@ -204,7 +203,7 @@ Parsed v rem (fix dvs err) munge dvs (NoParse err) = NoParse (fix dvs err)- fix dvs (err @ (ParseError ep _)) =+ fix dvs (err@(ParseError ep _)) = if ep > dvPos dvs then err else expError (dvPos dvs) desc@@ -224,7 +223,7 @@ -- but only if the position didn't change from the first to the second. -- If it did, just return the "new" (second) set of errors. joinErrors :: ParseError -> ParseError -> ParseError-joinErrors (e @ (ParseError p m)) (e' @ (ParseError p' m'))+joinErrors (e@(ParseError p m)) (e'@(ParseError p' m')) | p' > p || null m = e' | p > p' || null m' = e | otherwise = ParseError p (m `union` m')@@ -371,4 +370,3 @@ case dvChar d of NoParse _ -> [] Parsed c rem _ -> c : dvString rem-