diff --git a/Network/Smtp.hs b/Network/Smtp.hs --- a/Network/Smtp.hs +++ b/Network/Smtp.hs @@ -8,12 +8,11 @@ -- sessions, with which you can, among other things, send emails. Here -- is an example session: -- --- > import Network.Smtp --- > --- > mailSession :: --- > MonadIO m => --- > ByteString -> ByteString -> ByteString -> ByteString -> MailT r m () --- > mailSession srcDomain fromAddr toAddr content = do +-- > testSession :: +-- > (MailMonad m, MonadIO m) => +-- > ByteString -> ByteString -> ByteString -> ByteString -> +-- > Iteratee SmtpResponse m () +-- > testSession srcDomain fromAddr toAddr content = do -- > waitForWelcome -- > hello srcDomain -- > mailFrom fromAddr @@ -21,12 +20,6 @@ -- > mailDataStr content -- > quit -- --- The @r@ type parameter is related to contstuff's 'StateT' monad --- transformer, which is used internally. If you don't know what to do, --- just leave it fully polymorphic like in the example above. You only --- need to care about @r@, if you want to make use of the CPS features --- of 'StateT'. --- -- 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 @@ -36,14 +29,18 @@ -- 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. +-- or if you want to combine multiple stateful iteratees. This also +-- means that you have to run the underlying state computation yourself +-- for whatever state monad you work in. See documentation for +-- 'sendMail'. -- --- Finally you can use the low level interface for running sessions. --- See the 'runMailT' function along with 'enumHandleTimeout'. 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). This is not --- possible with the higher level functions. +-- Finally you can use the low level interface for running sessions. In +-- this case you will need to use the iteratee functions directly. This +-- is normally not necessary, as 'sendMail' does most of the boilerplate +-- for you. It can become useful, when you want to use some +-- enumeratees, e.g. to encapsulate the session in SSL or to go through +-- a proxy server. You can use the 'responseLines' function to convert +-- a raw 'ByteString' stream to a stream of 'SmtpResponse's. module Network.Smtp ( -- * Reexports diff --git a/Network/Smtp/Connect.hs b/Network/Smtp/Connect.hs --- a/Network/Smtp/Connect.hs +++ b/Network/Smtp/Connect.hs @@ -62,8 +62,9 @@ forall a m. (Applicative m, MonadPeelIO m) => HostName -> PortID -> MailT a m a -> m a withSmtpConn host port c = - Ex.bracket connect (liftIO . hClose) $ \h -> do - sendMail_ (defSendMail h h) c + Ex.bracket connect (liftIO . hClose) $ \h -> + let (cfg, stateComp) = sendMail_ (defSendMail h h) c + in evalStateT cfg stateComp where connect :: m Handle diff --git a/Network/Smtp/Monad.hs b/Network/Smtp/Monad.hs --- a/Network/Smtp/Monad.hs +++ b/Network/Smtp/Monad.hs @@ -6,36 +6,27 @@ -- -- This module implements a monad for SMTP sessions. -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} module Network.Smtp.Monad - ( -- * Running sessions - runMailT, - - -- * Manipulating sessions - mailSetWriteTimeout, - - -- * Utility functions + ( -- * Utility functions mailError, + mailNetworkError, 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.Enumerator.NetLines 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 @@ -43,60 +34,42 @@ mailError :: Monad m => - SmtpCommand -> String -> Integer -> Vector ByteString -> MailT r m a + SmtpCommand -> String -> Integer -> Vector ByteString -> + Iteratee SmtpResponse m b mailError cmd errMsg code msgs = - lift . throwError $ SmtpException errMsg cmd code (formatMsgs msgs) + throwError $ SmtpSessionError errMsg cmd code (formatMsgs msgs) +-- | Throws an 'SmtpNetworkError' with the given message. + +mailNetworkError :: Monad m => String -> Iteratee a m b +mailNetworkError = throwError . SmtpNetworkError + + -- | Send a stream of 'ByteString's to the SMTP server. -mailPut :: MonadIO m => Enumerator ByteString (MailT r m) () -> MailT r m () +mailPut :: + (MailMonad m, MonadIO m) => + Enumerator ByteString (Iteratee SmtpResponse m) () -> + Iteratee SmtpResponse m () mailPut enum = do - h <- getField mailHandle - timeout <- getField mailWriteTimeout + h <- lift getMailHandle + timeout <- lift getMailWriteTimeout run (enum $$ iterHandleTimeout timeout h) >>= - either (lift . throwError) return + 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 :: (MailMonad m, MonadIO m) => [ByteString] -> Iteratee SmtpResponse m () mailPutLn strs = mailPut $ concatEnums [enumList 16 strs, enumList 1 ["\r\n"]] --- | Set the write timeout for the current mail session in milliseconds. - -mailSetWriteTimeout :: Int -> MailT r m () -mailSetWriteTimeout timeout = - modify (\cfg -> cfg { mailWriteTimeout = timeout }) - - -- | Retrieve the next SMTP response. Throw an 'Error', if there is no -- next response. -nextResponse :: Monad m => MailT r m SmtpResponse +nextResponse :: Monad m => Iteratee SmtpResponse m SmtpResponse nextResponse = - lift $ do - let smtpError = throwError $ userError "Connection closed prematurely" - EL.head >>= maybe smtpError return - - --- | Run a mail session computation with the given protocol line length --- limit (first argument), response lines limit (second argument) and --- output handle. The input is supplied by an 'Enumerator' such as --- 'enumHandleTimeout'. --- --- The inner iteratee uses 'SmtpResponse' as its input type and hence --- expects the 'netLines' and 'smtpResponses' enumeratees to be applied. --- This is done by 'runMailT' for you, so the resulting iteratee takes a --- raw 'ByteString' stream as input. - -runMailT :: (Applicative m, Monad m) => - Int -> Int -> Handle -> MailT a m a -> - Iteratee ByteString m a -runMailT maxLine maxMsgs h c = - let cfg = MailConfig { mailExtensions = S.empty, - mailHandle = h, - mailWriteTimeout = 15000 } - in netLines maxLine =$ smtpResponses maxMsgs =$ evalStateT cfg c + EL.head >>= + maybe (mailNetworkError "Connection closed prematurely") return diff --git a/Network/Smtp/Session.hs b/Network/Smtp/Session.hs --- a/Network/Smtp/Session.hs +++ b/Network/Smtp/Session.hs @@ -36,7 +36,7 @@ -- | Try /EHLO/ with fallback to /HELO/. -hello :: forall m r. MonadIO m => ByteString -> MailT r m () +hello :: forall m. (MailMonad m, MonadIO m) => ByteString -> Iteratee SmtpResponse m () hello domain = do mailPutLn ["EHLO ", domain] SmtpResponse code msgs <- nextResponse @@ -44,14 +44,14 @@ L.drop 1 . V.toList $ msgs case code of - 250 -> modify (\cfg -> cfg { mailExtensions = exts }) + 250 -> lift $ setMailExtensions exts 500 -> tryHelo 502 -> tryHelo 554 -> tryHelo _ -> mailError (SmtpHelloCmd domain) "EHLO rejected" code msgs where - tryHelo :: MailT r m () + tryHelo :: Iteratee SmtpResponse m () tryHelo = do mailPutLn ["HELO ", domain] SmtpResponse code msgs <- nextResponse @@ -63,7 +63,10 @@ -- | 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 :: + (MailMonad m, MonadIO m) => + Enumerator ByteString (Iteratee SmtpResponse m) () -> + Iteratee SmtpResponse m () mailData enumMail = do mailPutLn ["DATA"] SmtpResponse code msgs <- nextResponse @@ -79,13 +82,13 @@ -- | 'ByteString' interface to 'mailData'. -mailDataStr :: MonadIO m => ByteString -> MailT r m () +mailDataStr :: (MailMonad m, MonadIO m) => ByteString -> Iteratee SmtpResponse m () mailDataStr = mailData . enumList 1 . (:[]) -- | Send /MAIL FROM/ command. -mailFrom :: MonadIO m => ByteString -> MailT r m () +mailFrom :: (MailMonad m, MonadIO m) => ByteString -> Iteratee SmtpResponse m () mailFrom from = do mailPutLn ["MAIL FROM:<", from, ">"] SmtpResponse code msgs <- nextResponse @@ -97,7 +100,7 @@ -- | Send /QUIT/ command. Please note: This iteratee violates the -- standard by recognizing a 250 result code as success. -quit :: MonadIO m => MailT r m () +quit :: (MailMonad m, MonadIO m) => Iteratee SmtpResponse m () quit = do mailPutLn ["QUIT"] SmtpResponse code msgs <- nextResponse @@ -109,7 +112,7 @@ -- | Send /RCPT TO/ command. -rcptTo :: MonadIO m => ByteString -> MailT r m () +rcptTo :: (MailMonad m, MonadIO m) => ByteString -> Iteratee SmtpResponse m () rcptTo to = do mailPutLn ["RCPT TO:<", to, ">"] SmtpResponse code msgs <- nextResponse @@ -120,7 +123,7 @@ -- | Send /RSET/ command. -reset :: MonadIO m => MailT r m () +reset :: (MailMonad m, MonadIO m) => Iteratee SmtpResponse m () reset = do mailPutLn ["RSET"] SmtpResponse code msgs <- nextResponse @@ -137,7 +140,7 @@ -- false negatives to prevent spamming attempts. It is not recommended -- to use this command. -verify :: MonadIO m => ByteString -> MailT r m Bool +verify :: (MailMonad m, MonadIO m) => ByteString -> Iteratee SmtpResponse m Bool verify checkUser = do mailPutLn ["VRFY ", checkUser] SmtpResponse code msgs <- nextResponse @@ -149,7 +152,7 @@ -- | Wait for the welcome greeting from the SMTP server. -waitForWelcome :: Monad m => MailT r m () +waitForWelcome :: MailMonad m => Iteratee SmtpResponse m () waitForWelcome = do SmtpResponse code msgs <- nextResponse case code of diff --git a/Network/Smtp/Simple.hs b/Network/Smtp/Simple.hs --- a/Network/Smtp/Simple.hs +++ b/Network/Smtp/Simple.hs @@ -6,6 +6,8 @@ -- -- Higher level interface to ismtp. +{-# LANGUAGE ScopedTypeVariables #-} + module Network.Smtp.Simple ( -- * Execute sessions SendMail(..), @@ -15,10 +17,11 @@ ) where +import qualified Data.Set as S +import Control.Arrow 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 @@ -54,23 +57,40 @@ -- | Execute the given mail session using the supplied configuration. -- Please note that both handles must be set to binary mode and be --- unbuffered. See 'hSetBuffering' and 'hSetBinaryMode'. +-- unbuffered. See 'hSetBuffering' and 'hSetBinaryMode'. This function +-- returns the mail session computation as well as the initial session +-- configuration for the underlying state monad. -sendMail :: (Applicative m, MonadIO m) => - SendMail -> MailT a m a -> m (Either SomeException a) -sendMail cfg c = do - let SendMail { mailBufferSize = bufSize, - mailInputHandle = inH, - mailMaxLine = maxLine, - mailMaxMessages = maxMsgs, - mailOutputHandle = outH, - mailTimeout = timeout, - mailTimeoutIO = ioTimeout } = cfg - run $ enumHandleTimeout bufSize timeout inH $$ - runMailT maxLine maxMsgs outH (mailSetWriteTimeout ioTimeout >> c) +sendMail :: + forall a m. (MailMonad m, MonadIO m) => + SendMail -> Iteratee SmtpResponse m a -> + (MailConfig, m (Either SomeException a)) +sendMail cfg c = (state, comp) + where + comp :: m (Either SomeException a) + comp = + run $ + enumHandleTimeout bufSize timeout inH $$ + responseLines maxLine maxMsgs $ c + state :: MailConfig + state = MailConfig { mailExtensions = S.empty, + mailHandle = outH, + mailWriteTimeout = ioTimeout } + + SendMail { mailBufferSize = bufSize, + mailInputHandle = inH, + mailMaxLine = maxLine, + mailMaxMessages = maxMsgs, + mailOutputHandle = outH, + mailTimeout = timeout, + mailTimeoutIO = ioTimeout } = cfg + + -- | Like 'sendMail', but throws an exception on error. -sendMail_ :: (Applicative m, MonadIO m) => SendMail -> MailT a m a -> m a -sendMail_ cfg = sendMail cfg >=> either throwIO return +sendMail_ :: + (MailMonad m, MonadIO m) => + SendMail -> Iteratee SmtpResponse m a -> (MailConfig, m a) +sendMail_ cfg = second (>>= either throwIO return) . sendMail cfg diff --git a/Network/Smtp/Tools.hs b/Network/Smtp/Tools.hs --- a/Network/Smtp/Tools.hs +++ b/Network/Smtp/Tools.hs @@ -11,6 +11,7 @@ module Network.Smtp.Tools ( enumHandleTimeout, formatMsgs, + responseLines, smtpResponseLine, smtpResponse, smtpResponses, @@ -59,6 +60,16 @@ 45 -> return True 32 -> return False _ -> empty + + +-- | Turns a raw 'ByteString' stream into a stream of SMTP response +-- lines with the given maximum line length (first argument) and maximum +-- number of lines per response (second argument). + +responseLines :: + Monad m => Int -> Int -> Iteratee SmtpResponse m b -> Iteratee ByteString m b +responseLines maxLine maxMsgs iter = + netLines maxLine =$ smtpResponses maxMsgs =$ iter -- | Read the next SMTP response line from the given 'ByteString' lines diff --git a/Network/Smtp/Types.hs b/Network/Smtp/Types.hs --- a/Network/Smtp/Types.hs +++ b/Network/Smtp/Types.hs @@ -6,10 +6,13 @@ -- -- Types used by ismtp. -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE + DeriveDataTypeable, + FlexibleInstances #-} module Network.Smtp.Types - ( -- * Mail monad + ( -- * Mail monads + MailMonad(..), Mail, MailT, @@ -36,6 +39,58 @@ import Text.Printf +-- | Mail configuration state monad. Minimal complete definition: +-- 'mapMailConfig'. + +class (Functor m, Monad m) => MailMonad m where + -- | Get the current mail configuration. + getMailConfig :: m MailConfig + getMailConfig = mapMailConfig id + + -- | Get supported SMTP service extensions. + getMailExtensions :: m (Set Extension) + getMailExtensions = mailExtensions <$> getMailConfig + + -- | Get mail handle. + getMailHandle :: m Handle + getMailHandle = mailHandle <$> getMailConfig + + -- | Get write timeout for mail session in milliseconds. + getMailWriteTimeout :: m Int + getMailWriteTimeout = mailWriteTimeout <$> getMailConfig + + -- | Map over the current mail configuration with the given function + -- and return the new configuration. + mapMailConfig :: (MailConfig -> MailConfig) -> m MailConfig + + -- | Modify the current mail configuration. + modifyMailConfig :: (MailConfig -> MailConfig) -> m () + modifyMailConfig = (() <$) . mapMailConfig + + -- | Set the current mail configuration. + putMailConfig :: MailConfig -> m () + putMailConfig cfg = modifyMailConfig (const cfg) + + -- | Set the set of supported SMTP service extensions. + setMailExtensions :: Set Extension -> m () + setMailExtensions exts = + modifyMailConfig (\cfg -> cfg { mailExtensions = exts }) + + -- | Set the ouput handle. + setMailHandle :: Handle -> m () + setMailHandle h = modifyMailConfig (\cfg -> cfg { mailHandle = h }) + + -- | Modify the mail write timeout. + setMailWriteTimeout :: Int -> m () + setMailWriteTimeout timeout = + modifyMailConfig (\cfg -> cfg { mailWriteTimeout = timeout }) + +instance MailMonad (StateT r MailConfig m) where + mapMailConfig f = + StateT $ \k s0 -> + let s1 = f s0 in k s1 s1 + + -- | Authentication methods for the SMTP authentication extension. data AuthMethod @@ -52,7 +107,7 @@ -- | The 'MailT' monad transformer encapsulates an SMTP session. -type MailT r m = StateT r MailConfig (Iteratee SmtpResponse m) +type MailT r m = Iteratee SmtpResponse (StateT r MailConfig m) -- | The 'Mail' monad is 'MailT' over 'IO'. @@ -85,19 +140,24 @@ -- | SMTP exception. -data SmtpException = - SmtpException { - smtpErrorMessage :: String, - smtpErrorCommand :: SmtpCommand, - smtpErrorCode :: Integer, - smtpErrorServerMessage :: String - } +data SmtpException + = SmtpNetworkError { + smtpErrorMessage :: String + } + | SmtpSessionError { + smtpErrorMessage :: String, + smtpErrorCommand :: SmtpCommand, + smtpErrorCode :: Integer, + smtpErrorServerMessage :: String + } + deriving Typeable instance Ex.Exception SmtpException instance Show SmtpException where - show (SmtpException msg _ code srvMsg) = + show (SmtpNetworkError msg) = "SMTP network error: " ++ msg + show (SmtpSessionError msg _ code srvMsg) = printf "%s (%i): \"%s\"" msg code srvMsg diff --git a/ismtp.cabal b/ismtp.cabal --- a/ismtp.cabal +++ b/ismtp.cabal @@ -1,5 +1,5 @@ Name: ismtp -Version: 3.0.1 +Version: 4.0.1 Category: Network Synopsis: Advanced ESMTP library Maintainer: Ertugrul Söylemez @@ -8,23 +8,23 @@ License: BSD3 License-file: LICENSE Build-type: Simple -Stability: beta +Stability: stable Cabal-version: >= 1.6 Description: - This library provides fast, incremental client-side ESMTP sessions - for mail exchangers and mail transfer agents. + This library provides fast, incremental, iteratee-based client-side + ESMTP sessions for mail exchangers and other mail transfer agents. Library Build-depends: base >= 4 && <= 5, bytestring >= 0.9.1.7, containers >= 0.3.0.0, - contstuff >= 1.2.4, + contstuff >= 1.2.6, dnscache >= 1.0.1, enumerator >= 0.4.7, monad-peel >= 0.1, - netlines >= 0.4.3, + netlines >= 1.0.0, network >= 2.2.1.7, vector >= 0.7.0.1 GHC-Options: -W @@ -41,6 +41,7 @@ -- Executable ismtp-test -- Build-depends: -- base >= 4 && <= 5, +-- cmdargs >= 0.6.8, -- unix -- GHC-Options: -W -threaded -- Main-is: Test.hs