module Network.Mail.SMTP
(
sendMail
, sendMail'
, sendMailWithLogin
, sendMailWithLogin'
, simpleMail
, plainTextPart
, htmlPart
, filePart
, module Network.Mail.SMTP.Types
, SMTPConnection
, sendmail
, sendmailCustom
, renderSendMail
, renderSendMailCustom
, connectSMTP
, connectSMTP'
, sendCommand
, login
, closeSMTP
, renderAndSend
)
where
import Network.Mail.SMTP.Auth
import Network.Mail.SMTP.Types
import System.IO
import System.FilePath (takeFileName)
import Control.Monad (unless)
import Data.Monoid
import Data.Char (isDigit)
import Network
import Network.BSD (getHostName)
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]
instance Eq SMTPConnection where
(==) (SMTPC a _) (SMTPC b _) = a == b
connectSMTP :: HostName
-> IO SMTPConnection
connectSMTP = flip connectSMTP' 25
connectSMTP' :: HostName
-> PortNumber
-> IO SMTPConnection
connectSMTP' hostname port =
connectTo hostname (PortNumber port) >>= connectStream
tryOnce :: SMTPConnection -> Command -> ReplyCode -> IO ByteString
tryOnce = tryCommand 1
tryCommand :: Int -> SMTPConnection -> Command -> ReplyCode
-> IO ByteString
tryCommand tries st cmd expectedReply = do
(code, msg) <- sendCommand st cmd
if code == expectedReply
then return msg
else if tries > 1
then tryCommand (tries 1) st cmd expectedReply
else do
closeSMTP st
fail $ "Unexpected reply to: " ++ show cmd ++
", Expected reply code: " ++ show expectedReply ++
", Got this instead: " ++ show code ++ " " ++ show msg
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 $ split dat ++ [BS.pack "."]
parseResponse conn
where
sendLine = bsPutCrLf conn
split = map stripCR . BS.lines
stripCR s = if cr `BS.isSuffixOf` s then BS.init s else s
cr = BS.pack "\r"
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) = encodeLogin 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 :: HostName -> Mail -> IO ()
sendMail host mail = do
con <- connectSMTP host
renderAndSend con mail
closeSMTP con
sendMail' :: HostName -> PortNumber -> Mail -> IO ()
sendMail' host port mail = do
con <- connectSMTP' host port
renderAndSend con mail
closeSMTP con
sendMailWithLogin :: HostName -> UserName -> Password -> Mail -> IO ()
sendMailWithLogin host user pass mail = do
con <- connectSMTP host
_ <- sendCommand con (AUTH LOGIN user pass)
renderAndSend con mail
closeSMTP con
sendMailWithLogin' :: HostName -> PortNumber -> UserName -> Password -> Mail -> IO ()
sendMailWithLogin' host port user pass mail = do
con <- connectSMTP' host port
_ <- sendCommand con (AUTH LOGIN user pass)
renderAndSend con mail
closeSMTP con
login :: SMTPConnection -> UserName -> Password -> IO (ReplyCode, ByteString)
login con user pass = sendCommand con (AUTH LOGIN user pass)
simpleMail :: Address
-> [Address]
-> [Address]
-> [Address]
-> T.Text
-> [Part]
-> Mail
simpleMail from to cc bcc subject parts =
Mail { mailFrom = from
, mailTo = to
, mailCc = cc
, mailBcc = bcc
, mailHeaders = [ ("Subject", subject) ]
, mailParts = [parts]
}
plainTextPart :: TL.Text -> Part
plainTextPart = Part "text/plain; charset=utf-8"
QuotedPrintableText Nothing [] . TL.encodeUtf8
htmlPart :: TL.Text -> Part
htmlPart = Part "text/html; charset=utf-8"
QuotedPrintableText Nothing [] . TL.encodeUtf8
filePart :: T.Text
-> FilePath
-> IO Part
filePart ct fp = do
content <- B.readFile fp
return $ Part ct Base64 (Just $ T.pack (takeFileName fp)) [] content
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