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, append)
import qualified Data.ByteString.Char8 as BS
import Network.BSD (getHostName)
import Network
import Control.Exception
import Control.Monad (unless)
import Data.List (intersperse)
import Data.Char (chr, ord, isSpace, 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 Prelude hiding (catch)
data (BSStream s) => SMTPConnection s = SMTPC !s ![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)
codeToResponse :: Num a => a -> Response
codeToResponse 211 = SystemStatus
codeToResponse 214 = HelpMessage
codeToResponse 220 = ServiceReady
codeToResponse 221 = ServiceClosing
codeToResponse 250 = Ok
codeToResponse 251 = UserNotLocal
codeToResponse 252 = CannotVerify
codeToResponse 354 = StartMailInput
codeToResponse 421 = ServiceNotAvailable
codeToResponse 450 = MailboxUnavailable
codeToResponse 451 = ErrorInProcessing
codeToResponse 452 = InsufficientSystemStorage
codeToResponse 500 = SyntaxError
codeToResponse 501 = ParameterError
codeToResponse 502 = CommandNotImplemented
codeToResponse 503 = BadSequence
codeToResponse 504 = ParameterNotImplemented
codeToResponse 550 = MailboxUnavailableError
codeToResponse 551 = UserNotLocalError
codeToResponse 552 = ExceededStorage
codeToResponse 553 = MailboxNotAllowed
codeToResponse 554 = TransactionFailed
crlf = BS.pack "\r\n"
isRight :: Either a b -> Bool
isRight (Right _) = True
isRight _ = False
connectSMTPPort :: String
-> PortNumber
-> IO (SMTPConnection Handle)
connectSMTPPort hostname port = connectTo hostname (PortNumber port) >>= connectStream
connectSMTP :: String
-> IO (SMTPConnection Handle)
connectSMTP = flip connectSMTPPort 25
connectStream :: BSStream s => s -> IO (SMTPConnection s)
connectStream st =
do (code, msg) <- parseResponse st
unless (code == 220) $
do bsClose st
fail "cannot connect to the server"
senderHost <- getHostName
(code, msg) <- sendCommand (SMTPC st []) (EHLO senderHost)
unless (code == 250) $
do (code, msg) <- sendCommand (SMTPC st []) (HELO senderHost)
unless (code == 250) $
do bsClose st
fail "cannot connect to the server"
return (SMTPC st (tail $ BS.lines msg))
parseResponse :: BSStream s => s -> 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 (c, ls) <- readLines
return (c, (BS.tail bdy:ls))
else return (c, [BS.tail bdy])
sendCommand :: BSStream s => SMTPConnection s -> 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."
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
(code, msg) <- parseResponse conn
bsPutCrLf conn $ BS.pack userB64
(code, msg) <- 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"
closeSMTP :: BSStream s => SMTPConnection s -> IO ()
closeSMTP c@(SMTPC conn _) = do bsClose conn
sendMail :: BSStream s =>
String
-> [String]
-> ByteString
-> SMTPConnection s
-> 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 Handle -> IO a) -> IO a
doSMTPPort host port execution =
bracket (connectSMTPPort host port) closeSMTP execution
doSMTP :: String -> (SMTPConnection Handle -> IO a) -> IO a
doSMTP host execution = doSMTPPort host 25 execution
doSMTPStream :: BSStream s => s -> (SMTPConnection s -> IO a) -> IO a
doSMTPStream s execution = bracket (connectStream s) closeSMTP execution
sendMimeMail :: BSStream s => String -> String -> String -> LT.Text -> LT.Text -> [(String, FilePath)] -> SMTPConnection s -> IO ()
sendMimeMail to from subject plainBody htmlBody attachments con = do
myMail <- simpleMail to from subject plainBody htmlBody attachments
renderedMail <- renderMail' myMail
sendMail from [to] (lazyToStrict renderedMail) con
closeSMTP con
lazyToStrict = S.concat . B.toChunks