diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,22 @@ +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) ------------------ diff --git a/HaskellNet.cabal b/HaskellNet.cabal --- a/HaskellNet.cabal +++ b/HaskellNet.cabal @@ -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 . + Additional documentation on the major updates can be found in the + file +Version: 0.6 Copyright: (c) 2006 Jun Mukai Author: Jun Mukai Maintainer: Alexander Vershilov , @@ -14,14 +16,10 @@ 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 + GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 @@ -29,6 +27,7 @@ Extra-Source-Files: CHANGELOG README.md + Updating.md example/*.hs Source-Repository head @@ -51,6 +50,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,6 +62,8 @@ Network.Compat Text.Packrat.Pos Text.Packrat.Parse + Reexported-modules: + Network.Mail.Mime Build-Depends: base >= 4.3 && < 4.15, @@ -71,7 +73,7 @@ pretty, array, cryptohash-md5, - base64-string, + base64, old-time, mime-mail >= 0.4.7 && < 0.6, text diff --git a/Updating.md b/Updating.md new file mode 100644 --- /dev/null +++ b/Updating.md @@ -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 " + will be parsed as `Address Nothing "FirstName LastName "` 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. diff --git a/example/smtp.hs b/example/smtp.hs --- a/example/smtp.hs +++ b/example/smtp.hs @@ -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 diff --git a/example/smtp2.hs b/example/smtp2.hs new file mode 100644 --- /dev/null +++ b/example/smtp2.hs @@ -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 = "

Hello world!

" +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 + diff --git a/src/Network/HaskellNet/Auth.hs b/src/Network/HaskellNet/Auth.hs --- a/src/Network/HaskellNet/Auth.hs +++ b/src/Network/HaskellNet/Auth.hs @@ -2,17 +2,19 @@ where import Crypto.Hash.MD5 -import qualified Codec.Binary.Base64.String as B64 (encode, decode) +import Data.Text.Encoding.Base64 as B64 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 data AuthType = PLAIN | LOGIN | CRAM_MD5 @@ -26,14 +28,10 @@ showMain CRAM_MD5 = "CRAM-MD5" 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 . B64.encodeBase64 . T.pack b64Decode :: String -> String -b64Decode = map (toEnum.fromEnum) . B64.decode . map (toEnum.fromEnum) +b64Decode = T.unpack . B64.decodeBase64Lenient . T.pack showOctet :: [Word8] -> String showOctet = concatMap hexChars diff --git a/src/Network/HaskellNet/SMTP.hs b/src/Network/HaskellNet/SMTP.hs --- a/src/Network/HaskellNet/SMTP.hs +++ b/src/Network/HaskellNet/SMTP.hs @@ -1,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 - - 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 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 package. +-- +-- @bracket-@ style is not the only possible style for resource management, +-- it's possible to use or +-- 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 diff --git a/src/Network/HaskellNet/SMTP/Internal.hs b/src/Network/HaskellNet/SMTP/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/HaskellNet/SMTP/Internal.hs @@ -0,0 +1,356 @@ +{-# 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 "BUG: DATA pattern should be matched by sendCommand patterns" + (AUTH {}) -> + error "BUG: AUTH pattern should be matched by sendCommand patterns" + +-- | 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)