diff --git a/Network/Smtp.hs b/Network/Smtp.hs --- a/Network/Smtp.hs +++ b/Network/Smtp.hs @@ -5,30 +5,55 @@ -- Maintainer: Ertugrul Soeylemez -- Stability: experimental -- --- This package provides a monad for fast, incremental ESMTP sessions, --- with which you can, among other things, send emails. Here is an --- example session: +-- This package provides a monad transformer for fast, incremental ESMTP +-- sessions, with which you can, among other things, send emails. Here +-- is an example session: -- --- > mailSession :: ByteString -> ByteString -> ByteString -> --- > Builder -> Mail () +-- > import Network.Smtp +-- > +-- > mailSession :: +-- > MonadIO m => +-- > ByteString -> ByteString -> ByteString -> ByteString -> MailT r m () -- > mailSession srcDomain fromAddr toAddr content = do -- > waitForWelcome --- > sendHello srcDomain --- > sendMailFrom fromAddr --- > sendRcptTo toAddr --- > sendData content --- > sendQuit +-- > hello srcDomain +-- > mailFrom fromAddr +-- > rcptTo toAddr +-- > mailDataStr content +-- > quit -- --- You can use the 'sendMail' function to send a mail via a domain's MX --- server, which is looked up via DNS. Alternatively you can connect to --- a specific SMTP server directly by using the 'sendMailDirect' --- function. Finally for a low-level interface you can use the --- 'runMail' function. +-- The simplest interfaces to running SMTP sessions are 'withSmtpConn' +-- and 'withMxConn'. The latter does a DNS lookup for the given domain +-- to discover the MX server and connect to it. The former simply +-- connects to the given hostname and port. +-- +-- If you need more control over the connection handles and other +-- parameters like timeout and flood protection, you may want to use +-- 'sendMail' or 'sendMail_' instead. Those functions are also useful, +-- if you want to run an SMTP session using stdin and stdout for testing +-- and other purposes. +-- +-- Finally you can use the low level interface for running sessions. +-- See the 'runMailT' function along with 'enumHandleTimeout' and +-- 'responseLines'. This way you get the full power of iteratees. For +-- example you can run the session through a custom enumeratee, which +-- enables you to wrap the session in another protocol (e.g. proxy +-- servers or SSL). module Network.Smtp ( -- * Reexports - module Network.Smtp.Protocol + module Network.Smtp.Connect, + module Network.Smtp.Monad, + module Network.Smtp.Session, + module Network.Smtp.Simple, + module Network.Smtp.Tools, + module Network.Smtp.Types ) where -import Network.Smtp.Protocol +import Network.Smtp.Connect +import Network.Smtp.Monad +import Network.Smtp.Session +import Network.Smtp.Simple +import Network.Smtp.Tools +import Network.Smtp.Types diff --git a/Network/Smtp/Connect.hs b/Network/Smtp/Connect.hs new file mode 100644 --- /dev/null +++ b/Network/Smtp/Connect.hs @@ -0,0 +1,97 @@ +-- | +-- Module: Network.Smtp.Connect +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- High level interfaces for networking. + +{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} + +module Network.Smtp.Connect + ( -- * Connection + withMxConn, + withSmtpConn, + + -- * Initialization + withIsmtp, + + -- * Utility functions + ignoreSigPipe, + withIgnoredSigPipe + ) + where + +import Control.ContStuff +import Control.Monad.IO.Peel +import Control.Exception.Peel as Ex +import Network +import Network.DnsCache +import Network.Smtp.Simple +import Network.Smtp.Types +import System.IO +import System.Posix.Signals + + +-- | Disable the /SIGPIPE/ signal, so our program doesn't die on broken +-- pipes. + +ignoreSigPipe :: IO () +ignoreSigPipe = () <$ installHandler sigPIPE Ignore Nothing + + +-- | Run the given computation with the /SIGPIPE/ signal disabled, so +-- our program doesn't die on broken pipes. + +withIgnoredSigPipe :: IO a -> IO a +withIgnoredSigPipe = + Ex.bracket (installHandler sigPIPE Ignore Nothing) + (\old -> installHandler sigPIPE old Nothing) + . const + + +-- | Perform some useful (but not necessarily needed) initialization +-- like disabling SIGPIPE and initializing sockets, run the given +-- computation and then clean up. + +withIsmtp :: IO a -> IO a +withIsmtp = withSocketsDo . withIgnoredSigPipe + + +-- | Interface to 'withSmtpConn', which connects to the first mail +-- exchanger (MX) of the given domain on port 25. The 'Bool' parameter +-- specifies whether to fall back to the given domain itself, if no MX +-- records can be found. + +withMxConn :: + (Applicative m, DnsMonad m, MonadPeelIO m) => + Domain -> Bool -> MailT (Either SomeException a) m a -> m a +withMxConn domain fallback c = do + mMx <- resolveMX domain + hostname <- + case mMx of + Just (mx:_) -> return mx + _ | fallback -> return domain + | otherwise -> throwIO $ userError "No MX records for domain" + withSmtpConn hostname (PortNumber 25) c + + +-- | Connect to the specified SMTP server and run the given computation. +-- Note that there is also 'withMxConn', which resolves the MX server of +-- the given domain. + +withSmtpConn :: forall a m. (Applicative m, MonadPeelIO m) => + HostName -> PortID -> MailT (Either SomeException a) m a -> m a +withSmtpConn host port c = + Ex.bracket connect (liftIO . hClose) $ \h -> do + sendMail_ (defSendMail h h) c + + where + connect :: m Handle + connect = + liftIO $ do + h <- connectTo host port + hSetBuffering h NoBuffering + hSetBinaryMode h True + return h diff --git a/Network/Smtp/Monad.hs b/Network/Smtp/Monad.hs new file mode 100644 --- /dev/null +++ b/Network/Smtp/Monad.hs @@ -0,0 +1,90 @@ +-- | +-- Module: Network.Smtp.Monad +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- This module implements a monad for SMTP sessions. + +{-# LANGUAGE OverloadedStrings #-} + +module Network.Smtp.Monad + ( -- * Running sessions + runMailT, + runMailT_, + + -- * Utility functions + mailError, + mailPut, + mailPutLn, + nextResponse + ) + where + +import qualified Data.Set as S +import Control.ContStuff +import Control.Exception.Peel as Ex +import Data.ByteString (ByteString) +import Data.ByteString.Char8 () +import Data.Enumerator as E +import Data.Enumerator.Binary as EB +import Data.Enumerator.List as EL +import Data.Vector (Vector) +import Network.Smtp.Tools +import Network.Smtp.Types +import System.IO + + +-- | Format a bad response together with the supplied error message and +-- throw an 'SmtpException' in the underlying 'Iteratee'. + +mailError :: + Monad m => + SmtpCommand -> String -> Integer -> Vector ByteString -> MailT r m a +mailError cmd errMsg code msgs = + throwError $ SmtpException errMsg cmd code (formatMsgs msgs) + + +-- | Send a stream of 'ByteString's to the SMTP server. + +mailPut :: MonadIO m => Enumerator ByteString (MailT r m) () -> MailT r m () +mailPut enum = do + h <- lift $ getField mailHandle + run (enum $$ EB.iterHandle h) >>= either throwError return + + +-- | Send a list of 'ByteString's followed an SMTP line terminator to +-- the SMTP server. + +mailPutLn :: MonadIO m => [ByteString] -> MailT r m () +mailPutLn strs = mailPut $ concatEnums [enumList 16 strs, enumList 1 ["\r\n"]] + + +-- | Retrieve the next SMTP response. Throw an 'Error', if there is no +-- next response. + +nextResponse :: Monad m => MailT r m SmtpResponse +nextResponse = do + let smtpError = throwError $ userError "Connection closed prematurely" + EL.head >>= maybe smtpError return + + +-- | Run a mail session computation with the given output handle. The +-- input is supplied by an 'Enumerator' such as 'enumHandleTimeout'. + +runMailT :: (Applicative m, Monad m) => + Handle -> StringMailT (Either SomeException a) m a -> + m (Either SomeException a) +runMailT h c = + let cfg = MailConfig { mailExtensions = S.empty, + mailHandle = h } + in evalStateT cfg . run $ c + + +-- | Run a mail session computation using 'runMailT' and throw an +-- exception on error. + +runMailT_ :: (Applicative m, MonadIO m) => + Handle -> StringMailT (Either SomeException a) m a -> m a +runMailT_ h = runMailT h >=> either Ex.throwIO return diff --git a/Network/Smtp/Protocol.hs b/Network/Smtp/Protocol.hs deleted file mode 100644 --- a/Network/Smtp/Protocol.hs +++ /dev/null @@ -1,385 +0,0 @@ --- | --- Module: Network.Smtp.Protocol --- Copyright: (c) 2010 Ertugrul Soeylemez --- License: BSD3 --- Maintainer: Ertugrul Soeylemez --- Stability: experimental --- --- This module implements the low level SMTP protocol implementation. - -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} - -module Network.Smtp.Protocol - ( -- * Types - Extension, - Mail, - MailConfig(..), - - -- * Sessions - -- ** Running sessions - runMail, - sendMail, - sendMailDirect, - -- ** Chatting with the server - waitForWelcome, - sendHello, - sendMailFrom, - sendRcptTo, - sendData, - sendReset, - sendQuit, - - -- * Utilities - -- ** Parsing - codeParser, - - -- ** Input/output - 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 - - --- ===== -- --- Types -- --- ===== -- - - --- | The 'Mail' monad transformer encapsulates an SMTP session. - -type Mail a = StateT MailConfig (Iteratee ByteString IO) a - - --- | Mail session configuration. - -data MailConfig = - MailConfig { - mailExtensions :: Set Extension, - mailHandle :: Handle - } - -defMailConfig :: Handle -> MailConfig -defMailConfig h = - MailConfig { mailExtensions = S.empty, - mailHandle = h } - - --- | SMTP service extension. - -data Extension = Extension -- ^ We don't know any extensions yet. - deriving (Eq, Ord) - - --- ========= -- --- Iteratees -- --- ========= -- - --- | Wait for 220 greeting. - -waitForWelcome :: Mail () -waitForWelcome = do - accepted <- lift $ iterParser welcomeParser - if accepted - then return () - else lift $ throwError (userError "SMTP session rejected") - - --- | Try *EHLO* with fallback to *HELO*. - -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") - - --- | Send *MAIL FROM* command. - -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") - - --- | Send *RCPT TO* command. By specification this command can be --- issued multiple times. - -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") - - --- | Send *DATA* command followed by the actual mail content. - -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." - - --- | Send *RSET* command to abort the current SMTP transaction. - -sendReset :: Mail () -sendReset = do - mailPutList ["RSET\r\n"] - () <$ lift (iterParser (codeParser "250")) - - --- | Send *QUIT* command to finish the SMTP session. - -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") - - --- ======= -- --- Parsers -- --- ======= -- - - --- | Welcome notice. - -welcomeParser :: Parser Bool -welcomeParser = - P.try (True <$ codeParser "220") <|> - (False <$ codeParser "554") - - --- | Responses for EHLO and HELO commands. - -data HelloResponse - = HelloOk (Set Extension) -- ^ Code 250 with set of extensions. - | HelloTryHelo -- ^ Codes 500, 502, and 554. - | HelloInvalidArg -- ^ Code 501. - | HelloUnavailable -- ^ Code 421. - - --- | Parse EHLO reponse. - -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" - - --- | Responses for MAIL FROM command. - -data MailFromResponse - = MailFromOk -- ^ Code 250. - | MailFromParseError -- ^ Code 501. - | MailFromAlreadySpecified -- ^ Code 503. - - --- | Parse MAIL FROM response. - -mailFromResponseParser :: Parser MailFromResponse -mailFromResponseParser = - P.try (MailFromOk <$ codeParser "250") <|> - P.try (MailFromParseError <$ codeParser "501") <|> - (MailFromAlreadySpecified <$ codeParser "503") - - --- | Responses for RCPT TO command. - -data RcptToResponse - = RcptToOk -- ^ Code 250. - | RcptToUnknown -- ^ Code 550. - | RcptToError -- ^ Code 554. - - --- | Parse RCPT TO response. - -rcptToResponseParser :: Parser RcptToResponse -rcptToResponseParser = - P.try (RcptToOk <$ codeParser "250") <|> - P.try (RcptToUnknown <$ codeParser "550") <|> - (RcptToError <$ codeParser "554") - - --- | Responses to DATA command. - -data DataResponse - = DataOk -- ^ Code 250 - | DataIntermediate -- ^ Code 354 - - --- | Parse DATA response. - -dataResponseParser :: Parser DataResponse -dataResponseParser = - P.try (DataOk <$ codeParser "250") <|> - (DataIntermediate <$ codeParser "354") - - --- | Read SMTP code. - -codeParser :: ByteString -> Parser [ByteString] -codeParser code = - choice - [ P.try (codeMoreParser code), - codeFinalParser code ] - - --- | Read SMTP continued code. - -codeMoreParser :: ByteString -> Parser [ByteString] -codeMoreParser code = do - skipWhile isEndOfLine - string (code `B.snoc` '-') - (:) <$> takeTill isEndOfLine - <*> codeParser code - - --- | Read SMTP final code. - -codeFinalParser :: ByteString -> Parser [ByteString] -codeFinalParser code = do - skipWhile isEndOfLine - string (code `B.snoc` ' ') - pure <$> takeTill isEndOfLine - - --- ============= -- --- Sending mails -- --- ============= -- - --- | Run a 'Mail' computation with the given session timeout in --- microseconds. - -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 - - --- | Send mail via MX. - -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 - - --- | Send mail directly to a host. - -sendMailDirect :: Int -> Address -> Mail a -> IO a -sendMailDirect timeout addr c = - withStream addr $ \h -> - runMail timeout (defMailConfig h) c - - --- ================= -- --- Utility functions -- --- ================= -- - --- | Convert extension string to 'Extension' value, if the corresponding --- extension is known. - -stringToExtension :: ByteString -> Maybe Extension -stringToExtension _ = Nothing - - --- | Send a command to the SMTP peer. - -mailPut :: Builder -> Mail () -mailPut str = do - h <- gets mailHandle - liftIO $ toByteStringIO (B.hPutStr h) str - - --- | Send a list of strings to the SMTP peer. - -mailPutList :: [ByteString] -> Mail () -mailPutList = mailPut . mconcat . map fromByteString diff --git a/Network/Smtp/Session.hs b/Network/Smtp/Session.hs new file mode 100644 --- /dev/null +++ b/Network/Smtp/Session.hs @@ -0,0 +1,137 @@ +-- | +-- Module: Network.Smtp.Session +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- SMTP session computations. + +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} + +module Network.Smtp.Session + ( -- * Initialization + hello, + mailData, + mailDataStr, + mailFrom, + quit, + rcptTo, + reset, + waitForWelcome + ) + where + +import qualified Data.Set as S +import qualified Data.Vector as V +import Control.ContStuff +import Data.ByteString (ByteString) +import Data.Enumerator as E +import Data.List as L +import Data.Maybe +import Network.Smtp.Monad +import Network.Smtp.Tools +import Network.Smtp.Types + + +-- | Try /EHLO/ with fallback to /HELO/. + +hello :: forall m r. MonadIO m => ByteString -> MailT r m () +hello domain = do + mailPutLn ["EHLO ", domain] + SmtpResponse code msgs <- nextResponse + let exts = S.fromList . catMaybes . + L.map stringToExtension . V.toList $ msgs + + case code of + 250 -> lift $ modify (\cfg -> cfg { mailExtensions = exts }) + 500 -> tryHelo + 502 -> tryHelo + 554 -> tryHelo + _ -> mailError (SmtpHelloCmd domain) "EHLO rejected" code msgs + + where + tryHelo :: MailT r m () + tryHelo = do + mailPutLn ["HELO ", domain] + SmtpResponse code msgs <- nextResponse + case code of + 250 -> return () + _ -> mailError (SmtpHelloCmd domain) "HELO rejected" code msgs + + +-- | Send the /DATA/ command along with the mail content. Please note +-- that the last line must be properly terminated by CRLF. + +mailData :: MonadIO m => Enumerator ByteString (MailT r m) () -> MailT r m () +mailData enumMail = do + mailPutLn ["DATA"] + SmtpResponse code msgs <- nextResponse + case code of + 354 -> do + mailPut (enumMail >==> enumList 1 [".\r\n"]) + SmtpResponse code2 msgs2 <- nextResponse + case code2 of + 250 -> return () + _ -> mailError SmtpDataCmd "Mail data rejected" code2 msgs2 + _ -> mailError SmtpDataCmd "Mail rejected" code msgs + + +-- | 'ByteString' interface to 'mailData'. + +mailDataStr :: MonadIO m => ByteString -> MailT r m () +mailDataStr = mailData . enumList 1 . (:[]) + + +-- | Send /MAIL FROM/ command. + +mailFrom :: MonadIO m => ByteString -> MailT r m () +mailFrom from = do + mailPutLn ["MAIL FROM:<", from, ">"] + SmtpResponse code msgs <- nextResponse + case code of + 250 -> return () + _ -> mailError (SmtpMailFromCmd from) "MAIL FROM rejected" code msgs + + +-- | Send /QUIT/ command. + +quit :: MonadIO m => MailT r m () +quit = do + mailPutLn ["QUIT"] + SmtpResponse code msgs <- nextResponse + case code of + 221 -> return () + _ -> mailError SmtpQuitCmd "Quit rejected" code msgs + + +-- | Send /RCPT TO/ command. + +rcptTo :: MonadIO m => ByteString -> MailT r m () +rcptTo to = do + mailPutLn ["RCPT TO:<", to, ">"] + SmtpResponse code msgs <- nextResponse + case code of + 250 -> return () + _ -> mailError (SmtpRcptToCmd to) "RCPT TO rejected" code msgs + + +-- | Send /RSET/ command. + +reset :: MonadIO m => MailT r m () +reset = do + mailPutLn ["RSET"] + SmtpResponse code msgs <- nextResponse + case code of + 250 -> return () + _ -> mailError SmtpResetCmd "RSET rejected" code msgs + + +-- | Wait for the welcome greeting from the SMTP server. + +waitForWelcome :: Monad m => MailT r m () +waitForWelcome = do + SmtpResponse code msgs <- nextResponse + case code of + 220 -> return () + _ -> mailError SmtpWelcomeCmd "We're not welcome" code msgs diff --git a/Network/Smtp/Simple.hs b/Network/Smtp/Simple.hs new file mode 100644 --- /dev/null +++ b/Network/Smtp/Simple.hs @@ -0,0 +1,77 @@ +-- | +-- Module: Network.Smtp.Simple +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- Higher level interface to ismtp. + +module Network.Smtp.Simple + ( -- * Execute sessions + SendMail(..), + defSendMail, + sendMail, + sendMail_ + ) + where + +import Control.ContStuff +import Control.Exception.Peel +import Data.Enumerator +import Network.Smtp.Monad +import Network.Smtp.Tools +import Network.Smtp.Types +import System.IO + + +-- | Session configuration. + +data SendMail = + SendMail { + mailBufferSize :: Int, -- ^ Input buffer size. + mailInputHandle :: Handle, -- ^ Input handle (e.g. receiving socket). + mailMaxLine :: Int, -- ^ Maximum line length (flood protection). + mailMaxMessages :: Int, -- ^ Maximum number of messages (flood protection). + mailOutputHandle :: Handle, -- ^ Output handle (e.g. sending socket). + mailTimeout :: Int -- ^ Receive timeout in milliseconds. + } + + +-- | Default values for 'SendMail' with the given input and output +-- handle respectively. + +defSendMail :: Handle -> Handle -> SendMail +defSendMail inH outH = + SendMail { mailBufferSize = 4096, + mailInputHandle = inH, + mailMaxLine = 512, + mailMaxMessages = 128, + mailOutputHandle = outH, + mailTimeout = 60000 } + + +-- | Execute the given mail session using the supplied configuration. +-- Please note that both handles must be set to binary mode and the +-- input handle should be unbuffered ('NoBuffering'). + +sendMail :: (Applicative m, MonadIO m) => + SendMail -> MailT (Either SomeException a) m a -> + m (Either SomeException a) +sendMail cfg c = + let SendMail { mailBufferSize = bufSize, + mailInputHandle = inH, + mailMaxLine = maxLine, + mailMaxMessages = maxMsgs, + mailOutputHandle = outH, + mailTimeout = timeout } = cfg + in runMailT outH (enumHandleTimeout bufSize timeout inH $$ + responseLines maxLine maxMsgs c) + + +-- | Like 'sendMail', but throws an exception on error. + +sendMail_ :: (Applicative m, MonadIO m) => + SendMail -> MailT (Either SomeException a) m a -> + m a +sendMail_ cfg = sendMail cfg >=> either throwIO return diff --git a/Network/Smtp/Tools.hs b/Network/Smtp/Tools.hs new file mode 100644 --- /dev/null +++ b/Network/Smtp/Tools.hs @@ -0,0 +1,220 @@ +-- | +-- Module: Network.Smtp.Tools +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- Helper functions and types. + +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Smtp.Tools + ( enumHandleTimeout, + formatMsgs, + netLine, + netLines, + responseLines, + smtpResponseLine, + smtpResponse, + smtpResponses, + stringToExtension ) + where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.Vector as V +import Control.ContStuff as Cont +import Data.Enumerator as E +import Data.Enumerator.Binary as EB +import Data.Enumerator.List as EL +import Data.ByteString (ByteString) +import Data.List as L +import Data.Vector (Vector) +import Data.Word +import Network.Smtp.Types +import System.IO +import System.IO.Error as IOErr + + +-- | Enumerate from a handle with the given buffer size (first argument) +-- and timeout in milliseconds (second argument). If the timeout is +-- exceeded an exception is thrown via 'throwError'. + +enumHandleTimeout :: forall b m. MonadIO m => + Int -> Int -> Handle -> Enumerator ByteString m b +enumHandleTimeout bufSize timeout h = loop + where + loop :: Enumerator ByteString m b + loop (Continue k) = do + mHaveInput <- liftIO $ IOErr.try (hWaitForInput h timeout) + case mHaveInput of + Left err + | isEOFError err -> continue k + | otherwise -> throwError err + Right False -> throwError $ userError "Handle timed out" + Right True -> do + mStr <- liftIO $ IOErr.try (B.hGetNonBlocking h bufSize) + str <- either throwError return mStr + if B.null str + then continue k + else k (Chunks [str]) >>== loop + loop step = returnI step + + +-- | Format a 'Vector' of 'ByteString' messages from an 'SmtpResponse' +-- for output. + +formatMsgs :: Vector ByteString -> String +formatMsgs = BC.unpack . BC.unwords . V.toList + + +-- | Savely read a line with the given maximum length. If a longer line +-- is enumerated, the excess data is dropped in constant space. Returns +-- 'Nothing' on EOF. + +netLine :: forall m r. Monad m => Int -> MaybeT r (Iteratee ByteString m) ByteString +netLine n = + lift (EB.dropWhile isEol) >> netLine' n + + where + isEol :: Word8 -> Bool + isEol 10 = True + isEol 13 = True + isEol _ = False + + isNotEol :: Word8 -> Bool + isNotEol = not . isEol + + netLine' :: Int -> MaybeT r (Iteratee ByteString m) ByteString + netLine' 0 = B.empty <$ lift (EB.dropWhile isNotEol) + netLine' n = do + c <- liftF EB.head + if isNotEol c + then B.cons c <$> netLine' (n-1) + else return B.empty + + +-- | Convert a stream of bytes to a stream of lines with the given +-- maximum length. Longer lines are silently truncated in constant +-- space. + +netLines :: forall b m. Monad m => Int -> Enumeratee ByteString ByteString m b +netLines maxLen = loop + where + loop :: Enumeratee ByteString ByteString m b + loop (Continue k) = do + mLine <- evalMaybeT $ netLine maxLen + case mLine of + Just line -> k (Chunks [line]) >>== loop + Nothing -> k EOF >>== loop + loop step = return step + + +-- | Read a three digit SMTP response code. + +readRespCode :: ByteString -> Maybe Integer +readRespCode str = do + guard $ B.length str >= 3 + let [a,b,c] = L.map (subtract 48 . fromIntegral . B.index str) [0,1,2] + guard $ a < 10 && b < 10 && c < 10 + return $ 100*a + 10*b + c + + +-- | Determine whether the given SMTP response is a multiline response. + +readRespMore :: ByteString -> Maybe Bool +readRespMore str = do + guard $ B.length str >= 4 + let more = B.index str 3 + case more of + 45 -> return True + 32 -> return False + _ -> empty + + +-- | Composition of all 'Enumeratee's, which are needed to convert a raw +-- 'ByteString' stream to an 'SmtpResponse' stream. This function takes +-- the maximum line length and the response line limit as its first two +-- parameters. + +responseLines :: Monad m => + Int -> Int -> Iteratee SmtpResponse m b -> Iteratee ByteString m b +responseLines maxLine maxMsgs c = + joinI $ netLines maxLine $$ + joinI $ smtpResponses maxMsgs $$ + c + + +-- | Read the next SMTP response line from the given 'ByteString' lines +-- stream (i.e. a 'ByteString' stream converted by 'netLines'). Returns +-- 'Nothing' on EOF. Returns @Just (Left line)@, if the next line is +-- not a proper SMTP response. Otherwise returns @(code, more, msg)@. + +smtpResponseLine :: + Monad m => + MaybeT r (Iteratee ByteString m) (Either ByteString (Integer, Bool, ByteString)) +smtpResponseLine = do + line <- liftF EL.head + let res = do + guard $ B.length line >= 3 + code <- readRespCode line + if B.length line > 3 + then do + more <- readRespMore line + return (code, more, B.drop 4 line) + else return (code, False, B.empty) + return $ maybe (Left line) Right res + + +-- | Read the next SMTP response from a 'netLines'-splitted 'ByteString' +-- stream. Throws an error on protocol errors. Returns at most the +-- given number of response messages. + +smtpResponse :: forall m r. Monad m => + Int -> MaybeT r (Iteratee ByteString m) SmtpResponse +smtpResponse maxMsgs = + collectResp Nothing V.empty + + where + collectResp :: + Maybe Integer -> Vector ByteString -> + MaybeT r (Iteratee ByteString m) SmtpResponse + collectResp mCode msgs' = do + let smtpError = lift $ throwError (userError "Invalid SMTP response") + mResp <- smtpResponseLine + (code, more, msg) <- either (const smtpError) return mResp + + case mCode of + Just code' -> unless (code == code') smtpError + Nothing -> return () + + let msgs = V.take maxMsgs . V.snoc msgs' $ msg + if more + then msgs `seq` collectResp (Just code) msgs + else msgs `seq` return (SmtpResponse code msgs) + + +-- | Convert a stream of 'netLines'-splitted 'ByteString' lines to a +-- stream of SMTP responses. In case of a protocol error the +-- enumeration is aborted and an error is thrown. + +smtpResponses :: forall b m. Monad m => Int -> Enumeratee ByteString SmtpResponse m b +smtpResponses maxMsgs = + loop + + where + loop :: Enumeratee ByteString SmtpResponse m b + loop (Continue k) = do + mResp <- evalMaybeT $ smtpResponse maxMsgs + case mResp of + Just resp -> k (Chunks [resp]) >>== loop + Nothing -> k EOF >>== loop + loop step = return step + + +-- | Convert extension string to 'Extension' value, if the corresponding +-- extension is known. + +stringToExtension :: ByteString -> Maybe Extension +stringToExtension _ = Nothing diff --git a/Network/Smtp/Types.hs b/Network/Smtp/Types.hs new file mode 100644 --- /dev/null +++ b/Network/Smtp/Types.hs @@ -0,0 +1,107 @@ +-- | +-- Module: Network.Smtp.Types +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- Types used by ismtp. + +{-# LANGUAGE DeriveDataTypeable #-} + +module Network.Smtp.Types + ( -- * Mail monad + Mail, + MailT, + StringMailT, + + -- * Other types + Extension(..), + MailConfig(..), + SmtpCommand(..), + SmtpException(..), + SmtpResponse(..) + ) + where + +import Control.ContStuff +import Control.Exception as Ex +import Data.ByteString (ByteString) +import Data.Enumerator +import Data.Set (Set) +import Data.Typeable +import Data.Vector (Vector) +import System.IO +import Text.Printf + + +-- | SMTP service extension. + +data Extension + = Extension -- ^ We don't support any extensions yet. + deriving (Eq, Ord) + + +-- | The 'MailT' monad transformer encapsulates an SMTP session. + +type MailT r m = Iteratee SmtpResponse (StateT r MailConfig m) + + +-- | Convenient type alias for raw streams. Needed by +-- 'Network.Smtp.Monad.runMailT'. + +type StringMailT r m = Iteratee ByteString (StateT r MailConfig m) + + +-- | The 'Mail' monad is 'MailT' over 'IO'. + +type Mail r a = MailT r IO a + + +-- | Mail session configuration. + +data MailConfig = + MailConfig { + mailExtensions :: Set Extension, -- ^ Supported extensions. + mailHandle :: Handle -- ^ Connection handle. + } + + +-- | Failed SMTP command (used by 'SmtpException'). + +data SmtpCommand + = SmtpWelcomeCmd -- ^ Waiting for welcome message. + | SmtpHelloCmd ByteString -- ^ EHLO or HELO with domain. + | SmtpMailFromCmd ByteString -- ^ MAIL FROM with address. + | SmtpRcptToCmd ByteString -- ^ RCPT TO with address. + | SmtpDataCmd -- ^ DATA. + | SmtpResetCmd -- ^ RSET. + | SmtpQuitCmd -- ^ QUIT. + + +-- | SMTP exception. + +data SmtpException = + SmtpException { + smtpErrorMessage :: String, + smtpErrorCommand :: SmtpCommand, + smtpErrorCode :: Integer, + smtpErrorServerMessage :: String + } + deriving Typeable + +instance Ex.Exception SmtpException + +instance Show SmtpException where + show (SmtpException msg _ code srvMsg) = + printf "%s (%i): \"%s\"" msg code srvMsg + + +-- | SMTP response. + +data SmtpResponse = + SmtpResponse { + smtpCode :: Integer, -- ^ Three digit response code. + smtpMessages :: Vector ByteString -- ^ Messages sent with the code. + } + deriving (Eq, Show) diff --git a/ismtp.cabal b/ismtp.cabal --- a/ismtp.cabal +++ b/ismtp.cabal @@ -1,7 +1,7 @@ Name: ismtp -Version: 1.0.2 +Version: 2.0.0 Category: Network -Synopsis: Fast, incremental ESMTP sessions +Synopsis: Advanced ESMTP library Maintainer: Ertugrul Söylemez Author: Ertugrul Söylemez Copyright: (c) 2010 Ertugrul Söylemez @@ -12,27 +12,30 @@ Cabal-version: >= 1.6 Description: - This library provides fast, incremental SMTP sessions, so you can - control each aspect of the session. It uses iteratees and - blaze-builder for fast I/O. + This library provides fast, incremental client-side ESMTP sessions + for mail exchangers and mail transfer agents. Library Build-depends: - attoparsec >= 0.8.2.0, - attoparsec-enumerator >= 0.2, base >= 4 && <= 5, - blaze-builder >= 0.2.0.1, bytestring >= 0.9.1.7, containers >= 0.3.0.0, + contstuff >= 1.2.4, dnscache >= 1.0.1, - enumerator >= 0.4.2, - network-fancy >= 0.1.5, - stm >= 2.1.2.1, - transformers >= 0.2.2.0 + enumerator >= 0.4.7, + monad-peel >= 0.1, + network >= 2.2.1.7, + unix >= 2.4.0.2, + vector >= 0.7.0.1 GHC-Options: -W Exposed-modules: Network.Smtp - Network.Smtp.Protocol + Network.Smtp.Connect + Network.Smtp.Monad + Network.Smtp.Session + Network.Smtp.Simple + Network.Smtp.Tools + Network.Smtp.Types --Executable test -- Build-depends: