module Network.Mail.SMTP
(
sendMail
, sendMailWithLogin
, simpleMail
, Command(..)
, Response(..)
, ReplyCode
, SMTPConnection
, UserName
, Password
, AuthType(..)
, Address (..)
, sendmail
, sendmailCustom
, renderSendMail
, renderSendMailCustom
, connectSMTPPort
, connectSMTP
, sendCommand
, closeSMTP
, renderAndSend
)
where
import System.IO
import Control.Monad (unless)
import Data.Monoid
import Data.Char (isDigit)
import Network
import Network.BSD (getHostName)
import Network.Mail.SMTP.Auth
import Network.Mail.Mime hiding (simpleMail)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as S
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import Data.Text.Encoding
data SMTPConnection = SMTPC !Handle ![ByteString]
data Command = HELO ByteString
| EHLO ByteString
| MAIL ByteString
| RCPT ByteString
| DATA ByteString
| EXPN ByteString
| VRFY ByteString
| HELP ByteString
| AUTH AuthType UserName Password
| NOOP
| RSET
| QUIT
deriving (Show, Eq)
type ReplyCode = Int
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)
connectSMTPPort :: String
-> PortNumber
-> IO SMTPConnection
connectSMTPPort hostname port =
connectTo hostname (PortNumber port) >>= connectStream
connectSMTP :: String
-> IO SMTPConnection
connectSMTP = flip connectSMTPPort 25
tryOnce :: SMTPConnection -> Command -> ReplyCode -> IO ByteString
tryOnce = tryCommand 1
tryCommand :: Int -> SMTPConnection -> Command -> ReplyCode
-> IO ByteString
tryCommand tries st cmd expectedReply | tries <= 0 = do
closeSMTP st
fail $ "cannot execute command " ++ show cmd ++
", expected reply code " ++ show expectedReply
tryCommand tries st cmd expectedReply = do
(code, msg) <- sendCommand st cmd
if code == expectedReply then
return msg else
tryCommand (tries 1) st cmd expectedReply
connectStream :: Handle -> IO SMTPConnection
connectStream st =
do (code1, _) <- parseResponse st
unless (code1 == 220) $
do hClose st
fail "cannot connect to the server"
senderHost <- getHostName
msg <- tryCommand 3 (SMTPC st []) (EHLO $ BS.pack senderHost) 250
return (SMTPC st (tail $ BS.lines msg))
parseResponse :: Handle -> IO (ReplyCode, ByteString)
parseResponse st =
do (code, bdy) <- readLines
return (read $ BS.unpack code, BS.unlines bdy)
where readLines =
do l <- BS.hGetLine 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])
sendCommand :: SMTPConnection -> Command -> IO (ReplyCode, ByteString)
sendCommand (SMTPC conn _) (DATA dat) =
do bsPutCrLf conn "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 = bsPutCrLf conn
sendCommand (SMTPC conn _) (AUTH LOGIN username password) =
do bsPutCrLf conn command
_ <- parseResponse conn
bsPutCrLf conn userB64
_ <- parseResponse conn
bsPutCrLf conn passB64
(code, msg) <- parseResponse conn
unless (code == 235) $ fail "authentication failed."
return (code, msg)
where command = "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 $ auth at (BS.unpack msg) username password
parseResponse conn
where command = BS.pack $ unwords ["AUTH", show at]
sendCommand (SMTPC conn _) meth =
do bsPutCrLf conn 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 BS.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"
closeSMTP :: SMTPConnection -> IO ()
closeSMTP c@(SMTPC conn _) = sendCommand c QUIT >> hClose conn
sendRenderedMail :: ByteString
-> [ByteString]
-> ByteString
-> SMTPConnection
-> IO ()
sendRenderedMail sender receivers dat conn = do
_ <- tryOnce conn (MAIL sender) 250
mapM_ (\r -> tryOnce conn (RCPT r) 250) receivers
_ <- tryOnce conn (DATA dat) 250
return ()
renderAndSend ::SMTPConnection -> Mail -> IO ()
renderAndSend conn mail@Mail{..} = do
rendered <- lazyToStrict `fmap` renderMail' mail
sendRenderedMail from to rendered conn
where enc = encodeUtf8 . addressEmail
from = enc mailFrom
to = map enc mailTo
sendMail :: String -> PortNumber -> Mail -> IO ()
sendMail host port mail = do
con <- connectSMTPPort host port
renderAndSend con mail
closeSMTP con
sendMailWithLogin :: String -> PortNumber -> UserName -> Password -> Mail -> IO ()
sendMailWithLogin host port user pass mail = do
con <- connectSMTPPort host port
_ <- sendCommand con (AUTH LOGIN user pass)
renderAndSend con mail
closeSMTP con
simpleMail :: Address
-> [Address]
-> [Address]
-> [Address]
-> T.Text
-> TL.Text
-> Maybe TL.Text
-> Mail
simpleMail from to cc bcc subject plainBody htmlBody =
Mail { mailFrom = from
, mailTo = to
, mailCc = cc
, mailBcc = bcc
, mailHeaders = [ ("Subject", subject) ]
, mailParts = [ parts plainBody htmlBody ]
}
where
plainPart plain' = Part "text/plain; charset=utf-8"
QuotedPrintableText Nothing [] $ TL.encodeUtf8 plain'
htmlPart html' = Part "text/html; charset=utf-8"
QuotedPrintableText Nothing [] $ TL.encodeUtf8 html'
parts plain' Nothing = [ plainPart plain' ]
parts plain' (Just html') = [ plainPart plain', htmlPart html' ]
lazyToStrict :: B.ByteString -> S.ByteString
lazyToStrict = S.concat . B.toChunks
crlf :: BS.ByteString
crlf = BS.pack "\r\n"
bsPutCrLf :: Handle -> ByteString -> IO ()
bsPutCrLf h s = BS.hPut h s >> BS.hPut h crlf >> hFlush h