HaskellNet-0.6.2: src/Network/HaskellNet/SMTP/Internal.hs
{-# 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)