module Network.HaskellNet.SMTP
(
Command(..)
, Response(..)
, SMTPConnection
, connectSMTPPort
, connectSMTP
, connectStream
, sendCommand
, closeSMTP
, sendMail
, doSMTPPort
, doSMTP
, doSMTPStream
, sendMimeMail
)
where
import Network.HaskellNet.BSStream
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Network.BSD (getHostName)
import Network
import Control.Applicative ((<$>))
import Control.Exception
import Control.Monad (unless)
import Data.Char (isDigit)
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)
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)
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 =
(handleToStream <$> connectTo hostname (PortNumber port))
>>= connectStream
connectSMTP :: String
-> 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
connectStream :: 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
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])
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"
closeSMTP :: SMTPConnection -> IO ()
closeSMTP (SMTPC conn _) = bsClose conn
sendMail :: String
-> [String]
-> ByteString
-> 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
doSMTPPort :: String -> PortNumber -> (SMTPConnection -> IO a) -> IO a
doSMTPPort host port execution =
bracket (connectSMTPPort host port) closeSMTP execution
doSMTP :: String -> (SMTPConnection -> IO a) -> IO a
doSMTP host execution = doSMTPPort host 25 execution
doSMTPStream :: BSStream -> (SMTPConnection -> IO a) -> IO a
doSMTPStream s execution = bracket (connectStream s) closeSMTP execution
sendMimeMail :: String -> String -> String -> LT.Text
-> LT.Text -> [(T.Text, FilePath)] -> 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
lazyToStrict :: B.ByteString -> S.ByteString
lazyToStrict = S.concat . B.toChunks
crlf :: BS.ByteString
crlf = BS.pack "\r\n"
bsPutCrLf :: BSStream -> ByteString -> IO ()
bsPutCrLf h s = bsPut h s >> bsPut h crlf >> bsFlush h