module Network.Smtp.Protocol
(
Extension,
Mail,
MailConfig(..),
runMail,
sendMail,
sendMailDirect,
waitForWelcome,
sendHello,
sendMailFrom,
sendRcptTo,
sendData,
sendReset,
sendQuit,
codeParser,
mailPut,
mailPutList
)
where
import qualified Data.ByteString.Char8 as B
import qualified Data.Set as S
import Blaze.ByteString.Builder
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Data.Attoparsec as P (skipWhile, takeTill)
import Data.Attoparsec.Char8 as P hiding (skipWhile, takeTill)
import Data.Attoparsec.Enumerator
import Data.ByteString.Char8 (ByteString)
import Data.Enumerator as E hiding (map)
import Data.Enumerator.IO
import Data.List as L
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import Network.DnsCache
import Network.Fancy
import System.IO
type Mail a = StateT MailConfig (Iteratee ByteString IO) a
data MailConfig =
MailConfig {
mailExtensions :: Set Extension,
mailHandle :: Handle
}
defMailConfig :: Handle -> MailConfig
defMailConfig h =
MailConfig { mailExtensions = S.empty,
mailHandle = h }
data Extension = Extension
deriving (Eq, Ord)
waitForWelcome :: Mail ()
waitForWelcome = do
accepted <- lift $ iterParser welcomeParser
if accepted
then return ()
else lift $ throwError (userError "SMTP session rejected")
sendHello :: ByteString -> Mail ()
sendHello domain = do
mailPutList [ "EHLO ", domain, "\r\n" ]
response <- lift $ iterParser ehloResponseParser
case response of
HelloOk exts -> modify (\cfg -> cfg { mailExtensions = exts })
HelloTryHelo -> do
mailPutList $ [ "HELO ", domain, "\r\n" ]
lift . iterParser $ codeParser "250"
return ()
HelloInvalidArg -> lift $ throwError (userError "Invalid argument to EHLO")
HelloUnavailable -> lift $ throwError (userError "Service unavailable")
sendMailFrom :: ByteString -> Mail ()
sendMailFrom from = do
mailPutList [ "MAIL FROM:<", from, ">\r\n" ]
response <- lift $ iterParser mailFromResponseParser
case response of
MailFromOk -> return ()
MailFromParseError ->
lift $ throwError (userError "Parse error")
MailFromAlreadySpecified ->
lift $ throwError (userError "Sender already specified")
sendRcptTo :: ByteString -> Mail ()
sendRcptTo to = do
mailPutList [ "RCPT TO:<", to, ">\r\n" ]
response <- lift $ iterParser rcptToResponseParser
case response of
RcptToOk -> return ()
RcptToUnknown ->
lift $ throwError (userError "Recipient unknown")
RcptToError ->
lift $ throwError (userError "RCPT TO rejected, unknown error")
sendData :: Builder -> Mail ()
sendData content = do
mailPutList ["DATA\r\n"]
response1 <- lift $ iterParser dataResponseParser
case response1 of
DataOk ->
lift . throwError $
userError "Protocol error: Got 250 after sending DATA command."
DataIntermediate -> do
mailPut (mappend content (fromByteString ".\r\n"))
response2 <- lift $ iterParser dataResponseParser
case response2 of
DataOk -> return ()
DataIntermediate ->
lift . throwError $
userError "Protocol error: Got 354 after sending mail."
sendReset :: Mail ()
sendReset = do
mailPutList ["RSET\r\n"]
() <$ lift (iterParser (codeParser "250"))
sendQuit :: Mail ()
sendQuit = do
mailPutList ["QUIT\r\n"]
lift $ do
iterParser (codeParser "221")
E.dropWhile (B.all $ inClass "\r\n")
eof <- E.isEOF
unless eof $ throwError (userError "Session still open after QUIT")
welcomeParser :: Parser Bool
welcomeParser =
P.try (True <$ codeParser "220") <|>
(False <$ codeParser "554")
data HelloResponse
= HelloOk (Set Extension)
| HelloTryHelo
| HelloInvalidArg
| HelloUnavailable
ehloResponseParser :: Parser HelloResponse
ehloResponseParser =
choice [ HelloOk <$> P.try ok,
HelloTryHelo <$ P.try tryHelo,
HelloInvalidArg <$ P.try invArg,
HelloUnavailable <$ unavail ]
where
ok = S.fromList . catMaybes . map stringToExtension . tail
<$> codeParser "250"
tryHelo =
P.try (codeParser "500") <|>
P.try (codeParser "502") <|>
codeParser "554"
invArg = codeParser "501"
unavail = codeParser "421"
data MailFromResponse
= MailFromOk
| MailFromParseError
| MailFromAlreadySpecified
mailFromResponseParser :: Parser MailFromResponse
mailFromResponseParser =
P.try (MailFromOk <$ codeParser "250") <|>
P.try (MailFromParseError <$ codeParser "501") <|>
(MailFromAlreadySpecified <$ codeParser "503")
data RcptToResponse
= RcptToOk
| RcptToUnknown
| RcptToError
rcptToResponseParser :: Parser RcptToResponse
rcptToResponseParser =
P.try (RcptToOk <$ codeParser "250") <|>
P.try (RcptToUnknown <$ codeParser "550") <|>
(RcptToError <$ codeParser "554")
data DataResponse
= DataOk
| DataIntermediate
dataResponseParser :: Parser DataResponse
dataResponseParser =
P.try (DataOk <$ codeParser "250") <|>
(DataIntermediate <$ codeParser "354")
codeParser :: ByteString -> Parser [ByteString]
codeParser code =
choice
[ P.try (codeMoreParser code),
codeFinalParser code ]
codeMoreParser :: ByteString -> Parser [ByteString]
codeMoreParser code = do
skipWhile isEndOfLine
string (code `B.snoc` '-')
(:) <$> takeTill isEndOfLine
<*> codeParser code
codeFinalParser :: ByteString -> Parser [ByteString]
codeFinalParser code = do
skipWhile isEndOfLine
string (code `B.snoc` ' ')
pure <$> takeTill isEndOfLine
runMail :: Int -> MailConfig -> Mail a -> IO a
runMail timeout cfg comp = do
let h = mailHandle cfg
timeoutVar <- registerDelay timeout
resultVar <- newEmptyTMVarIO
mailerThread <-
forkIO $ do
hSetBuffering h NoBuffering
run (enumHandle 1 h $$ evalStateT comp cfg)
>>= atomically . putTMVar resultVar
result <-
let timeout = do
readTVar timeoutVar >>= check
return . Left . toException $ userError "Timed out"
in atomically $ timeout `orElse` readTMVar resultVar
killThread mailerThread
either throwIO return result
sendMail :: DnsMonad m => Int -> Domain -> Mail a -> m a
sendMail timeout domain c = do
mx <- resolveMX domain
let hostname = L.head $ concat (maybeToList mx) ++ [domain]
liftIO . withStream (IP hostname 25) $ \h ->
runMail timeout (defMailConfig h) c
sendMailDirect :: Int -> Address -> Mail a -> IO a
sendMailDirect timeout addr c =
withStream addr $ \h ->
runMail timeout (defMailConfig h) c
stringToExtension :: ByteString -> Maybe Extension
stringToExtension _ = Nothing
mailPut :: Builder -> Mail ()
mailPut str = do
h <- gets mailHandle
liftIO $ toByteStringIO (B.hPutStr h) str
mailPutList :: [ByteString] -> Mail ()
mailPutList = mailPut . mconcat . map fromByteString