HaskellNet 0.3.1 → 0.6.2
raw patch · 18 files changed
Files
- CHANGELOG +155/−1
- HaskellNet.cabal +51/−27
- README.md +4/−5
- Updating.md +31/−0
- example/imap.hs +5/−5
- example/smtp.hs +68/−22
- example/smtp2.hs +34/−0
- src/Network/Compat.hs +53/−0
- src/Network/HaskellNet/Auth.hs +35/−11
- src/Network/HaskellNet/BSStream.hs +3/−0
- src/Network/HaskellNet/IMAP.hs +158/−52
- src/Network/HaskellNet/IMAP/Connection.hs +1/−3
- src/Network/HaskellNet/IMAP/Parsers.hs +20/−9
- src/Network/HaskellNet/IMAP/Types.hs +3/−0
- src/Network/HaskellNet/POP3.hs +25/−16
- src/Network/HaskellNet/SMTP.hs +295/−196
- src/Network/HaskellNet/SMTP/Internal.hs +354/−0
- src/Text/Packrat/Parse.hs +44/−20
CHANGELOG view
@@ -1,4 +1,158 @@+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)+------------------++ - Allow 0 spaces or more than 1 space in separator (thanks Daniel Smith <danielspencersmith@gmail.com>)+ - Use cryptohash-md5 instead of cryptohash (thanks to amesgen <amesgen@amesgen.de>)+ - Fix long passwords encoding (thanks to Victor Nawothnig <Victor.Nawothnig@gmail.com>)++0.5.2 (2020-03-19)+------------------++ - Improved Monad failure messages from sendCommmand (thanks Scott+ Fleischman)+ - Fixed IMAP append (thanks Keijo Kapp)+ - Added support for GHC 8.8.1 (thanks Oleg Grenrus)+ - Added support for network-3 (thanks Oleg Grenrus)+ - Increased upper bound on mime-mail to include 0.5 (thanks Marek+ Suchánek)+ - Improved failure message for AUTH failures (thanks Tom McLaughlin)+ - Avoided unsafe use of unsafe bytestring length functions in+ getResponse (thanks Javran Cheng)+ - Added support for UNSEEN in STATUS commands (thanks Dominik Xaver+ Hörl)++0.5.1 (2016-05-05)+------------------++ - SMTP: Strip carriage returns from the on lines before sending++0.5 (2015-11-5)+---------------++ - No longer render Bcc field when rendering messages (thanks Dan Aloni+ <alonid@gmail.com>)+ - Implemented IDLE command (thanks Alexander Inyukhin+ <shurick@sectorb.msk.ru>)+ - Added stream wait function (bsWaitForInput field of type BSStream)+ (thanks Alexander Inyukhin <shurick@sectorb.msk.ru>)+ - SMTP: RCPT also includes Cc and Bcc lists rather than just To list+ (thanks Author: Dan Aloni <alonid@gmail.com>)++0.4.4 -> 0.4.5 (2015-06-18)+---------------------------++ - IMAP: select command must quote the mailbox name+ (see https://github.com/jtdaugherty/HaskellNet/issues/35)++0.4.3 -> 0.4.4 (2015-04-11)+---------------------------++ - Fix a bug in IMAP Parser for listing Mboxes+ (see https://github.com/jtdaugherty/HaskellNet/issues/34)+ - Protocols modules re-exports AuthType+ (see https://github.com/dpwright/HaskellNet-SSL/issues/10)++0.4.2 -> 0.4.3 (2015-04-06)+---------------------------++ - Parser for IMAP LIST to return mailbox names unquoted+ (see https://github.com/jtdaugherty/HaskellNet/issues/34)+ - Update to build with GHC 7.10.1++0.4.1 -> 0.4.2+--------------++ - Add sendMimeMail' to send mime mails with in-memory attachments++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+----------++ - Merge pull request #22 from dpwright/parse-fix:+ Fix parser error when passing parameters to FETCH+ (See http://stackoverflow.com/questions/26183675/error-when-fetching-subject-from-email-using-haskellnets-imap)+ - Merge pull request #20 from vincenthz/master:+ Replace Crypto by the much faster cryptohash+ - Merge pull request #19 from fegu/patch-1+ remove closeSMTP at end of sendMimeMail+ (sendMail and sendMimeMail should have the same behaviour towards the+ connection given to the function. In addition, Office365 causes the+ closeSMTP of sendMimeMail to raise an exception of already closed. Thus,+ removed.)+ - Merge pull request #18 from michaelbeaumont/issue17+ Stopped the POP3 module from removing whitespace before response lines+ except for the initial line with the POP3 status. Retrieved messages can now+ be correctly parsed.+ - Merge pull request #16 from fegu/master+ Fix store command to enable Office365 support (Adding a space between UID+ and flags in STORE command. This should have been there all the time, but+ while some IMAP servers (notably Gmail) accepts that it is missing, others+ (notably Office365) requires it.)+ - Merge pull request #10 from ppetr/master+ Improve `tryCommand` so that it includes the failed server response.+ - Improve a bad piece of code in `sendMail`.+ It used pattern matching and then catching the exception using `handle`,+ which is very non-idiomatic and error prone. Also the code seemed to catch+ the failure only to rethrow it.+ - Merge pull request #8 from ppetr/master+ Upgrade to mime-mail >= 0.4.+ - Merge pull request #5 from sordina/master+ Adding show constraint to show6 in Network/HaskellNet/IMAP.hs for+ compatibility with GHC 7.4.1+ - Merge pull request #4 from nh2/ghc-7.2+ Fix compilation with GHC 7.0 and 7.2 (fixes Char and List imports)+ 0.2.5 -> 0.3 ------------ @@ -38,4 +192,4 @@ Network.HaskellNet.Connection (POP connection functions) * IMAP.Parsers: - removed unused Either handling functions- - constraind exports (originally exported everything)+ - constraind exports (originally exported everything)commit 682edece1bf5fb5923ea5bd04309819c630ff33d
HaskellNet.cabal view
@@ -1,37 +1,48 @@ 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.3.1+Description: This package provides client support for the POP3,+ 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: Jonathan Daugherty <drcygnus@gmail.com>+Maintainer: Alexander Vershilov <alexander.vershilov@sirius.online>,+ Jonathan Daugherty <cygnus@foobox.com>,+ Leza Morais Lutonda <lemol-c@outlook.com> License: BSD3-License-file: LICENSE+License-file: LICENSE Category: Network-Homepage: https://github.com/jtdaugherty/HaskellNet-Cabal-version: >=1.6-Build-type: Simple+Homepage: https://github.com/qnikst/HaskellNet+Cabal-version: 1.22+Build-type: Simple+Tested-with:+ 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 type: git- location: git://github.com/jtdaugherty/HaskellNet.git--Source-Repository this- type: git- location: git://github.com/shapr/HaskellNet.git- tag: nonmaintainerupload+ location: git://github.com/qnikst/HaskellNet.git +Flag network-bsd+ description: Use network-bsd+ manual: False+ default: True Library Hs-Source-Dirs: src+ default-language: Haskell2010 GHC-Options: -Wall -fno-warn-unused-do-bind Exposed-modules:@@ -40,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@@ -48,18 +60,30 @@ Network.HaskellNet.Debug Other-modules:+ Network.Compat Text.Packrat.Pos Text.Packrat.Parse+ Reexported-modules:+ Network.Mail.Mime Build-Depends:- base >= 4 && < 5,- network,- mtl,- bytestring,- pretty,- array,- Crypto > 4.2.1,- base64-string,- old-time,- mime-mail >= 0.4,- 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++ if flag(network-bsd)+ Build-Depends: network-bsd >=2.7 && <2.9,+ network >=2.7+ else+ Build-Depends: network <2.7
README.md view
@@ -1,6 +1,8 @@ HaskellNet ========== +[](https://github.com/qnikst/HaskellNet/actions/workflows/ci.yml)+ This package provides client support for the E-mail protocols POP3, SMTP, and IMAP. @@ -11,12 +13,9 @@ 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 :trace main---(The source for the 0.3.1 non-maintainer upload can be found at https://github.com/shapr/HaskellNet)
+ 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/imap.hs view
@@ -1,6 +1,6 @@-import System.IO+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+ import Network.HaskellNet.IMAP-import qualified Data.ByteString.Char8 as BS import Control.Monad imapServer = "imap.mail.org"@@ -11,8 +11,8 @@ con <- connectIMAP imapServer login con username password mboxes <- list con- mapM print mboxes+ mapM_ print mboxes select con "INBOX" msgs <- search con [ALLs]- mapM_ (\x -> print x) (take 4 msgs)- forM_ (take 4msgs) (\x -> fetch con x >>= print)+ mapM_ print (take 4 msgs)+ forM_ (take 4msgs) (fetch con >=> print)
example/smtp.hs view
@@ -1,32 +1,78 @@-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 = "<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")] +-- | Send plain text mail+example1 = doSMTP server $ \conn -> do+ let mail = simpleMail' to from subject plainBody+ sendMail mail 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 -> do+ let mail = simpleMail' to from subject plainBody+ sendMail mail conn +-- | Manually open and close the connection+example3 = do+ conn <- connectSMTP server+ let mail = simpleMail' to from subject plainBody+ sendMail mail 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 -> do+ mail <- simpleMail to from subject plainBody htmlBody []+ sendMail mail conn ---htmlP = SinglePart [("Content-Type", "text/html; charset=utf-8", "Content-Transfer-Encoding", ""] BS.pack $ encode $ +-- | With file attachments (modify the `attachments` binding)+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 -> 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 do mail <- simpleMail to from subject plainBody htmlBody []+ sendMail mail 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", subject)]+ [[htmlPart htmlBody, plainPart plainBody]]+ newMail' <- addAttachments attachments newMail+ 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/Compat.hs view
@@ -0,0 +1,53 @@+module Network.Compat where++import Network.Socket+import Network.BSD (getProtocolNumber)+import System.IO (Handle, IOMode (..))++import qualified Control.Exception as Exception++connectTo :: String -- Hostname+ -> PortNumber -- Port Identifier+ -> IO Handle -- Connected Socket+connectTo host port = do+ proto <- getProtocolNumber "tcp"+ let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]+ , addrProtocol = proto+ , addrSocketType = Stream }+ addrs <- getAddrInfo (Just hints) (Just host) (Just serv)+ firstSuccessful "connectTo" $ map tryToConnect addrs+ where+ serv = show port++ tryToConnect addr =+ Exception.bracketOnError+ (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))+ close -- only done if there's an error+ (\sock -> do+ connect sock (addrAddress addr)+ socketToHandle sock ReadWriteMode+ )++-- Returns the first action from a list which does not throw an exception.+-- If all the actions throw exceptions (and the list of actions is not empty),+-- the last exception is thrown.+-- The operations are run outside of the catchIO cleanup handler because+-- catchIO masks asynchronous exceptions in the cleanup handler.+-- In the case of complete failure, the last exception is actually thrown.+firstSuccessful :: String -> [IO a] -> IO a+firstSuccessful caller = go Nothing+ where+ -- Attempt the next operation, remember exception on failure+ go _ (p:ps) =+ do r <- tryIO p+ case r of+ Right x -> return x+ Left e -> go (Just e) ps++ -- All operations failed, throw error if one exists+ go Nothing [] = ioError $ userError $ caller ++ ": firstSuccessful: empty list"+ go (Just e) [] = Exception.throwIO e++-- Version of try implemented in terms of the locally defined catchIO+tryIO :: IO a -> IO (Either Exception.IOException a)+tryIO m = Exception.catch (fmap Right m) (return . Left)
src/Network/HaskellNet/Auth.hs view
@@ -1,20 +1,30 @@+{-# language CPP #-}+ module Network.HaskellNet.Auth where -import Data.Digest.MD5-import Codec.Utils-import qualified Codec.Binary.Base64.String as B64 (encode, decode)+import Crypto.Hash.MD5+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@@ -23,23 +33,36 @@ showMain PLAIN = "PLAIN" showMain LOGIN = "LOGIN" showMain CRAM_MD5 = "CRAM-MD5"+ showMain XOAUTH2 = "XOAUTH2" b64Encode :: String -> String-b64Encode = map (toEnum.fromEnum) . 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 :: [Octet] -> String-showOctet = concat . map hexChars+showOctet :: [Word8] -> String+showOctet = concatMap hexChars where hexChars c = [arr ! (c `div` 16), arr ! (c `mod` 16)] arr = listArray (0, 15) "0123456789abcdef" -hmacMD5 :: String -> String -> [Octet]-hmacMD5 text key = hash $ okey ++ hash (ikey ++ map (toEnum.fromEnum) text)+hashMD5 :: [Word8] -> [Word8]+hashMD5 = B.unpack . hash . B.pack++hmacMD5 :: String -> String -> [Word8]+hmacMD5 text key = hashMD5 $ okey ++ hashMD5 (ikey ++ map (toEnum.fromEnum) text) where koc = map (toEnum.fromEnum) key key' = if length koc > 64- then hash koc ++ replicate 48 0+ then hashMD5 $ koc ++ replicate 48 0 else koc ++ replicate (64-length koc) 0 ipad = replicate 64 0x36 opad = replicate 64 0x5c@@ -47,7 +70,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)@@ -60,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/BSStream.hs view
@@ -28,6 +28,8 @@ -- ^Close the stream. , bsIsOpen :: IO Bool -- ^Is the stream open?+ , bsWaitForInput :: Int -> IO Bool+ -- ^Is data available? } -- |Build a byte string stream which operates on a 'Handle'.@@ -41,4 +43,5 @@ op <- hIsOpen h if op then (hClose h) else return () , bsIsOpen = hIsOpen h+ , bsWaitForInput = hWaitForInput h }
src/Network/HaskellNet/IMAP.hs view
@@ -8,30 +8,33 @@ -- ** 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(..)+ , A.AuthType(..) ) where -import Network+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 -import Control.Applicative ((<$>)) import Control.Monad import System.Time@@ -41,6 +44,8 @@ import Data.Char import Text.Packrat.Parse (Result)+import Control.Applicative -- support old toolchains+import Prelude -- suffixed by `s' data SearchQuery = ALLs@@ -66,6 +71,7 @@ | SUBJECTs String | TEXTs String | TOs String+ | XGMRAW String | UIDs [UID] @@ -86,7 +92,7 @@ showQuery (NOTs qry) = "NOT " ++ show qry showQuery OLDs = "OLD" showQuery (ONs t) = "ON " ++ dateToStringIMAP t- showQuery (ORs q1 q2) = "OR " ++ show q1 ++ " " ++ show q2 + showQuery (ORs q1 q2) = "OR " ++ show q1 ++ " " ++ show q2 showQuery (SENTBEFOREs t) = "SENTBEFORE " ++ dateToStringIMAP t showQuery (SENTONs t) = "SENTON " ++ dateToStringIMAP t showQuery (SENTSINCEs t) = "SENTSINCE " ++ dateToStringIMAP t@@ -95,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"@@ -108,13 +115,16 @@ data FlagsQuery = ReplaceFlags [Flag] | PlusFlags [Flag] | MinusFlags [Flag]+ | ReplaceGmailLabels [GmailLabel]+ | PlusGmailLabels [GmailLabel]+ | MinusGmailLabels [GmailLabel] ---------------------------------------------------------------------- -- establish connection connectIMAPPort :: String -> PortNumber -> IO IMAPConnection connectIMAPPort hostname port =- handleToStream <$> connectTo hostname (PortNumber port)+ handleToStream <$> connectTo hostname port >>= connectStream connectIMAP :: String -> IO IMAPConnection@@ -163,12 +173,13 @@ getLs = do l <- strip <$> bsGetLine s case () of- _ | isLiteral l -> do l' <- getLiteral l (getLitLen l)+ _ | BS.null l -> return [l]+ | isLiteral l -> do l' <- getLiteral l (getLitLen l) ls <- getLs return (l' : ls) | isTagged l -> (l:) <$> getLs | otherwise -> return [l]- getLiteral l len = + getLiteral l len = do lit <- bsGet s len l2 <- strip <$> bsGetLine s let l' = BS.concat [l, crlfStr, lit, l2]@@ -176,7 +187,8 @@ then getLiteral l' (getLitLen l2) else return l' crlfStr = BS.pack "\r\n"- isLiteral l = BS.last l == '}' &&+ isLiteral l = not (BS.null l) &&+ BS.last l == '}' && BS.last (fst (BS.spanEnd isDigit (BS.init l))) == '{' getLitLen = read . BS.unpack . snd . BS.spanEnd isDigit . BS.init isTagged l = BS.head l == '*' && BS.head (BS.tail l) == ' '@@ -193,6 +205,26 @@ -- IMAP commands -- +idle :: IMAPConnection -> Int -> IO ()+idle conn timeout =+ do+ (buf',num) <- sendCommand' conn "IDLE"+ buf <-+ if BS.take 2 buf' == BS.pack "+ "+ then do+ _ <- bsWaitForInput (stream conn) timeout+ bsPutCrLf (stream conn) $ BS.pack "DONE"+ getResponse $ stream conn+ else+ 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)+ PREAUTH _ msg -> fail ("preauth: " ++ msg)+ noop :: IMAPConnection -> IO () noop conn = sendCommand conn "NOOP" pNone @@ -204,7 +236,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@@ -243,8 +275,10 @@ _select :: String -> IMAPConnection -> String -> IO () _select cmd conn mboxName =- do mbox' <- sendCommand conn (cmd ++ mboxName) pSelect+ do mbox' <- sendCommand conn (cmd ++ quoted mboxName) pSelect setMailboxInfo conn $ mbox' { _mailbox = mboxName }+ where+ quoted s = "\"" ++ s ++ "\"" select :: IMAPConnection -> MailboxName -> IO () select = _select "SELECT "@@ -289,28 +323,29 @@ in sendCommand conn cmd pStatus append :: IMAPConnection -> MailboxName -> ByteString -> IO ()-append conn mbox mailData = appendFull conn mbox mailData [] Nothing+append conn mbox mailData = appendFull conn mbox mailData Nothing Nothing appendFull :: IMAPConnection -> MailboxName -> ByteString- -> [Flag] -> Maybe CalendarTime -> IO ()+ -> Maybe [Flag] -> Maybe CalendarTime -> IO () appendFull conn mbox mailData flags' time = do (buf, num) <- sendCommand' conn- (unwords ["APPEND", mbox- , fstr, tstr, "{" ++ show len ++ "}"])- unless (BS.null buf || (BS.head buf /= '+')) $+ (concat ["APPEND ", mbox+ , fstr, tstr, " {" ++ show len ++ "}"])+ when (BS.null buf || (BS.head buf /= '+')) $ fail "illegal server response" mapM_ (bsPutCrLf $ stream conn) mailLines+ bsPutCrLf (stream conn) BS.empty 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- fstr = unwords $ map show flags'+ tstr = maybe "" ((" "++) . datetimeToStringIMAP) time+ fstr = maybe "" ((" ("++) . (++")") . unwords . map show) flags' check :: IMAPConnection -> IO () check conn = sendCommand conn "CHECK" pNone@@ -338,12 +373,18 @@ 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 +-- | 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]"- 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 =@@ -353,16 +394,16 @@ 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+ return $ maybe BS.empty BS.pack $ lookup' fetchCmd lst fetchFlags :: IMAPConnection -> UID -> IO [Flag] fetchFlags conn uid =@@ -376,7 +417,14 @@ 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++-- | 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 =@@ -388,7 +436,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]@@ -398,16 +446,19 @@ storeFull :: IMAPConnection -> String -> FlagsQuery -> Bool -> IO [(UID, [Flag])] storeFull conn uidstr query isSilent =- fetchCommand conn ("UID STORE " ++ uidstr ++ flgs query) procStore+ fetchCommand conn ("UID STORE " ++ uidstr ++ " " ++ flgs query) procStore 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))+ (lookup' "UID" ps)+ ,maybe [] (eval' dvFlags "") (lookup' "FLAG" ps)) store :: IMAPConnection -> UID -> FlagsQuery -> IO ()@@ -420,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 @@ -450,3 +534,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 == query k = return v+ | otherwise = lookup' q xs+ where+ 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+-- 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]
src/Network/HaskellNet/IMAP/Connection.hs view
@@ -25,9 +25,6 @@ , modifyIORef ) import Control.Applicative- ( (<$>)- , (<*>)- ) import Network.HaskellNet.BSStream import Network.HaskellNet.IMAP.Types@@ -37,6 +34,7 @@ , Flag , UID )+import Prelude data IMAPConnection = IMAPC { stream :: BSStream
src/Network/HaskellNet/IMAP/Parsers.hs view
@@ -110,7 +110,7 @@ Parser pSearch = do untagged <- many (pSearchLine <|> pOtherLine) resp <- Parser pDone- let (mboxUp, searchRes) = mkMboxUpdate untagged + let (mboxUp, searchRes) = mkMboxUpdate untagged return (resp, mboxUp, concat searchRes) @@ -165,7 +165,7 @@ ; char ')' ; return $ PERMANENTFLAGS fs } , string "READ-ONLY" >> return READ_ONLY- , string "READ-WRITE" >> return READ_WRITE + , string "READ-WRITE" >> return READ_WRITE , string "TRYCREATE" >> return TRYCREATE , do { string "UNSEEN" >> space ; num <- many1 digit@@ -229,7 +229,7 @@ pListLine :: String -> Parser RespDerivs (Either a ([Attribute], String, MailboxName))-pListLine list = +pListLine list = do string "* " >> string list >> space attrs <- parseAttrs sep <- parseSep@@ -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@@ -248,7 +248,13 @@ char ')' return attrs parseSep = space >> char '"' >> anyChar `manyTill` char '"'- parseMailbox = space >> anyChar `manyTill` crlfP+ parseMailbox = do space+ q <- optional $ char '"'+ case q of+ Just _ -> do mbox <- anyChar `manyTill` char '"'+ anyChar `manyTill` crlfP+ return mbox+ Nothing -> anyChar `manyTill` crlfP pStatusLine :: Parser RespDerivs (Either a [(MailboxStatus, Integer)]) pStatusLine =@@ -262,6 +268,7 @@ , string "RECENT" >>= return . read , string "UIDNEXT" >>= return . read , string "UIDVALIDITY" >>= return . read+ , string "UNSEEN" >>= return . read ] space num <- many1 digit >>= return . read@@ -294,7 +301,7 @@ ; fs <- pFlag `sepBy` space ; char ')' ; return $ \mbox ->- mbox { _isFlagWritable = + mbox { _isFlagWritable = Keyword "*" `elem` fs , _permanentFlags = filter (/= Keyword "*") fs } }@@ -317,11 +324,14 @@ num <- many1 digit string " FETCH" >> spaces char '('- pairs <- pPair `sepBy` space- char ')'+ pairs <- pPair `manyTill` char ')' crlfP return $ Right $ (read num, pairs)- where pPair = do key <- anyChar `manyTill` space+ where pPair = do key <- (do k <- anyChar `manyTill` char '['+ ps <- anyChar `manyTill` char ']'+ space+ return (k++"["++ps++"]"))+ <|> anyChar `manyTill` space value <- (do char '(' v <- pParen `sepBy` space char ')'@@ -334,6 +344,7 @@ v <- noneOf "\"" `manyTill` char '"' return ("\""++v++"\"")) <|> many1 atomChar+ spaces return (key, value) pParen = (do char '"' v <- noneOf "\"" `manyTill` char '"'
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@@ -97,6 +99,7 @@ | RECENT -- ^ the number of messages with the \Recent flag set | UIDNEXT -- ^ the next unique identifier value of the mailbox | UIDVALIDITY -- ^ the unique identifier validity value of the mailbox+ | UNSEEN -- ^ the number of messages with the \Unseen flag set deriving (Show, Read, Eq)
src/Network/HaskellNet/POP3.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Network.HaskellNet.POP3 ( -- * Establishing Connection connectPop3Port@@ -25,19 +26,23 @@ , doPop3Port , doPop3 , doPop3Stream+ -- * Other types+ , A.AuthType(..) ) where -import Network.HaskellNet.BSStream-import Network+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 import qualified Data.ByteString.Char8 as BS-import Data.Digest.MD5+import Crypto.Hash.MD5 import Numeric (showHex) -import Control.Applicative ((<$>))+import Control.Applicative import Control.Exception import Control.Monad (when, unless) @@ -46,28 +51,32 @@ import System.IO -import Prelude hiding (catch)+import Prelude import Network.HaskellNet.POP3.Types import Network.HaskellNet.POP3.Connection hexDigest :: [Char] -> [Char]-hexDigest = concatMap (flip showHex "") . hash . map (toEnum.fromEnum)+hexDigest = concatMap (flip showHex "") . B.unpack . hash . B.pack . map (toEnum.fromEnum) +blank :: Char -> Bool+blank a = isSpace a || isControl a++trimR :: ByteString -> ByteString+trimR s = let rs = BS.reverse s in+ BS.dropWhile blank rs+ strip :: ByteString -> ByteString strip = trimR . trimR- where- trimR s = let rs = BS.reverse s in- BS.dropWhile blank rs -blank :: Char -> Bool-blank a = isSpace a || isControl a+stripEnd :: ByteString -> ByteString+stripEnd = BS.reverse . trimR -- | connecting to the pop3 server specified by the hostname and port -- number connectPop3Port :: String -> PortNumber -> IO POP3Connection connectPop3Port hostname port =- handleToStream <$> (connectTo hostname (PortNumber port))+ handleToStream <$> (connectTo hostname port) >>= connectStream -- | connecting to the pop3 server specified by the hostname. 110 is@@ -101,7 +110,7 @@ return (Ok, BS.unlines (BS.drop 4 reply : rest)) else return (Err, BS.drop 5 reply) where st = stream conn- getRest = do l <- strip <$> bsGetLine st+ getRest = do l <- stripEnd <$> bsGetLine st if l == BS.singleton '.' then return [] else (l:) <$> getRest@@ -150,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,98 +1,173 @@ {-# LANGUAGE ScopedTypeVariables #-}+{- |++This module provides functions client side of the SMTP protocol.++A basic usage example:++@+\{\-\# LANGUAGE OverloadedStrings \#\-\}+import "Network.HaskellNet.SMTP"+import "Network.HaskellNet.Auth"+import "Network.Mail.Mime"+import "System.Exit" (die)++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."+@++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.++__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(..)- , SMTPConnection- -- * Establishing Connection- , connectSMTPPort- , connectSMTP- , connectStream- -- * Operation to a Connection- , sendCommand- , closeSMTP- -- * Other Useful Operations - , 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- )- where+ , sendMimeMail'+ , sendMimeMail2+ -- * 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+import Network.Socket+import Network.Compat -import Control.Applicative ((<$>))+import Control.Applicative import Control.Exception-import Control.Monad (unless)--import Data.Char (isDigit)+import Control.Monad (unless, when) import Network.HaskellNet.Auth -import System.IO- 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 -import Prelude hiding (catch)+import GHC.Stack+import Prelude+import Network.HaskellNet.SMTP.Internal -data SMTPConnection = SMTPC !BSStream ![ByteString] -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)+-- $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. -type ReplyCode = Int+-- $controlling-connections -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-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 -> IO SMTPConnection connectSMTPPort hostname port =- (handleToStream <$> connectTo hostname (PortNumber port))+ (handleToStream <$> connectTo hostname port) >>= connectStream -- | connecting SMTP server with the specified name and port 25.@@ -100,156 +175,180 @@ -> IO SMTPConnection connectSMTP = flip connectSMTPPort 25 -tryCommand :: BSStream -> Command -> Int -> ReplyCode- -> IO ByteString-tryCommand st cmd tries expectedReply | tries <= 0 = do- bsClose st- fail $ "cannot execute command " ++ show cmd ++- ", expected reply code " ++ show expectedReply-tryCommand st cmd tries expectedReply = do- (code, msg) <- sendCommand (SMTPC st []) cmd- if code == expectedReply then- return msg else- tryCommand st cmd (tries - 1) expectedReply---- | 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- msg <- tryCommand st (EHLO senderHost) 3 250+ 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, _) <- parseResponse conn- 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-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."- 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+-- $authentication -{--I must be being stupid here+{- |+Authenticates user on the remote server. Returns 'True' if the authentication succeeds,+otherwise returns 'False'. -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+Usage example: -closeSMTP c@(SMTPC conn _) =- do sendCommand c QUIT- bsClose conn `catch` \(_ :: IOException) -> return ()+@+\{\-\# 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 =- catcher `handle` mainProc- where mainProc =- do (250, _) <- sendCommand conn (MAIL sender)- vals <- mapM (sendCommand conn . RCPT) receivers- unless (all ((==250) . fst) vals) $ fail "sendMail error"- (250, _) <- sendCommand conn (DATA dat)- return ()- catcher e@(PatternMatchFail _) = throwIO e+-- $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 execution =- bracket (connectSMTPPort host port) closeSMTP execution+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 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' 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 execution = bracket (connectStream s) closeSMTP execution+doSMTPStream s f =+ bracket (connectStream s)+ (\(SMTPC conn _) -> bsClose conn)+ (\c -> f c >>= \x -> quitSMTP c >> pure x) -sendMimeMail :: String -> String -> String -> LT.Text- -> LT.Text -> [(T.Text, FilePath)] -> SMTPConnection -> IO ()+-- $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.+--+-- __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 =+ let mail = simpleMail' to from subject body+ in sendMail mail con+++-- | Send a mime mail. The attachments are included with the file path.+--+-- __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 Nothing $ T.pack to) (Address Nothing- $ T.pack from)- (T.pack subject) plainBody htmlBody attachments- renderedMail <- renderMail' myMail- sendMail from [to] (lazyToStrict renderedMail) con- closeSMTP con+ myMail <- simpleMail to from subject plainBody htmlBody attachments+ sendMail myMail con --- haskellNet uses strict bytestrings--- TODO: look at making haskellnet lazy-lazyToStrict :: B.ByteString -> S.ByteString-lazyToStrict = S.concat . B.toChunks+-- | Send a mime mail. The attachments are included with in-memory 'ByteString'.+--+-- __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 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
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | Packrat parsing: Simple, Powerful, Lazy, Linear time by Bryan -- Ford. This module achieves monadic parsing library similar to -- Parsec.@@ -11,7 +12,10 @@ import Text.Packrat.Pos import Control.Monad+import qualified Control.Applicative as A +import qualified Control.Monad.Fail as Fail+ -- Data types data Message = Expected String@@ -37,10 +41,21 @@ infixl 1 <?> infixl 1 <?!> -instance Derivs d => Monad (Parser d) where +instance Derivs d => Functor (Parser d) where+ f `fmap` (Parser p1) = Parser $ parse . p1+ where parse (Parsed val rem err) =+ let val2 = f val+ in Parsed val2 rem err+ parse (NoParse err) = NoParse err++instance Derivs d => Applicative (Parser d) where+ pure x = Parser (\dvs -> Parsed x dvs (nullError dvs))+ (<*>) = ap++instance Derivs d => Monad (Parser d) where (Parser p1) >>= f = Parser parse where parse dvs = first (p1 dvs)- first (Parsed val rem err) = + first (Parsed val rem err) = let Parser p2 = f val in second err (p2 rem) first (NoParse err) = NoParse err@@ -48,17 +63,27 @@ Parsed val rem (joinErrors err1 err) second err1 (NoParse err) = NoParse (joinErrors err1 err)- return x = Parser (\dvs -> Parsed x dvs (nullError dvs))+ return = pure++#if !(MIN_VERSION_base(4,13,0))+ fail = Fail.fail+#endif++instance Derivs d => Fail.MonadFail (Parser d) where fail msg = Parser (\dvs -> NoParse (msgError (dvPos dvs) msg)) +instance Derivs d => A.Alternative (Parser d) where+ empty = Parser $ NoParse . nullError+ (<|>) = (<|>)+ instance Derivs d => MonadPlus (Parser d) where- mzero = Parser (\dvs -> NoParse $ nullError dvs)- mplus = (<|>)+ mzero = A.empty+ mplus = (A.<|>) (<|>) :: 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)@@ -68,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)@@ -76,7 +101,7 @@ notFollowedBy :: (Derivs d, Show v) => Parser d v -> Parser d () notFollowedBy (Parser p) = Parser parse- where parse dvs = case (p dvs) of+ where parse dvs = case p dvs of Parsed val _ _ -> NoParse (msgError (dvPos dvs) ("unexpected " ++ show val))@@ -86,7 +111,7 @@ optional p = (do v <- p; return (Just v)) <|> return Nothing option :: Derivs d => v -> Parser d v -> Parser d v-option v p = (do v' <- p; return v') <|> return v+option v p = p <|> return v many :: Derivs d => Parser d v -> Parser d [v] many p = (do { v <- p; vs <- many p; return (v : vs) } )@@ -96,7 +121,7 @@ many1 p = do { v <- p; vs <- many p; return (v : vs) } count :: Derivs d => Int -> Parser d v -> Parser d [v]-count n p = sequence $ replicate n p+count = replicateM sepBy1 :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v] sepBy1 p psep = do v <- p@@ -178,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@@ -198,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')@@ -233,11 +258,11 @@ ParseError p1 _ <= ParseError p2 _ = p1 <= p2 ParseError p1 _ >= ParseError p2 _ = p1 >= p2 -- Special behavior: "max" joins two errors- max p1 p2 = joinErrors p1 p2+ max = joinErrors min _ _ = undefined instance Show ParseError where- show (ParseError pos []) = + show (ParseError pos []) = show pos ++ ": unknown error" show (ParseError pos msgs) = expectmsg expects ++ messages msgs where expects = getExpects msgs@@ -265,14 +290,14 @@ anyChar = Parser dvChar char :: Derivs d => Char -> Parser d Char-char ch = satisfy anyChar (\c -> c == ch) <?> show ch+char ch = satisfy anyChar (== ch) <?> show ch oneOf :: Derivs d => [Char] -> Parser d Char-oneOf chs = satisfy anyChar (\c -> c `elem` chs)+oneOf chs = satisfy anyChar (`elem` chs) <?> ("one of the characters " ++ show chs) noneOf :: Derivs d => [Char] -> Parser d Char-noneOf chs = satisfy anyChar (\c -> not (c `elem` chs))+noneOf chs = satisfy anyChar (`notElem` chs) <?> ("any character not in " ++ show chs) @@ -332,7 +357,7 @@ getDerivs = Parser (\dvs -> Parsed dvs dvs (nullError dvs)) setDerivs :: Derivs d => d -> Parser d ()-setDerivs newdvs = Parser (\dvs -> Parsed () newdvs (nullError dvs))+setDerivs newdvs = Parser (Parsed () newdvs . nullError) getPos :: Derivs d => Parser d Pos getPos = Parser (\dvs -> Parsed (dvPos dvs) dvs (nullError dvs))@@ -344,5 +369,4 @@ dvString d = case dvChar d of NoParse _ -> []- Parsed c rem _ -> (c : dvString rem)-+ Parsed c rem _ -> c : dvString rem