diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,5 @@ ismtp license -Copyright (c) 2010, Ertugrul Soeylemez +Copyright (c) 2011, Ertugrul Soeylemez All rights reserved. diff --git a/Network/Smtp.hs b/Network/Smtp.hs --- a/Network/Smtp.hs +++ b/Network/Smtp.hs @@ -1,9 +1,8 @@ -- | -- Module: Network.SMTP --- Copyright: (c) 2010 Ertugrul Soeylemez +-- Copyright: (c) 2011 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez --- Stability: experimental -- -- This package provides a monad transformer for fast, incremental ESMTP -- sessions, with which you can, among other things, send emails. Here @@ -22,6 +21,12 @@ -- > 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 @@ -34,11 +39,11 @@ -- 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). +-- 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. 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 @@ -1,9 +1,8 @@ -- | -- Module: Network.Smtp.Connect --- Copyright: (c) 2010 Ertugrul Soeylemez +-- Copyright: (c) 2011 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez --- Stability: experimental -- -- High level interfaces for networking. @@ -15,11 +14,7 @@ withSmtpConn, -- * Initialization - withIsmtp, - - -- * Utility functions - ignoreSigPipe, - withIgnoredSigPipe + withIsmtp ) where @@ -31,32 +26,14 @@ 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 +withIsmtp = withSocketsDo -- | Interface to 'withSmtpConn', which connects to the first mail @@ -66,7 +43,7 @@ withMxConn :: (Applicative m, DnsMonad m, MonadPeelIO m) => - Domain -> Bool -> MailT (Either SomeException a) m a -> m a + Domain -> Bool -> MailT a m a -> m a withMxConn domain fallback c = do mMx <- resolveMX domain hostname <- @@ -81,8 +58,9 @@ -- 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 :: + 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 diff --git a/Network/Smtp/Ext/Auth.hs b/Network/Smtp/Ext/Auth.hs --- a/Network/Smtp/Ext/Auth.hs +++ b/Network/Smtp/Ext/Auth.hs @@ -1,9 +1,8 @@ -- | -- Module: Network.Smtp.Ext.Auth --- Copyright: (c) 2010 Ertugrul Soeylemez +-- Copyright: (c) 2011 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez --- Stability: experimental -- -- This module implements the authentication extension to SMTP as -- defined in RFC 2554. diff --git a/Network/Smtp/Monad.hs b/Network/Smtp/Monad.hs --- a/Network/Smtp/Monad.hs +++ b/Network/Smtp/Monad.hs @@ -1,9 +1,8 @@ -- | -- Module: Network.Smtp.Monad --- Copyright: (c) 2010 Ertugrul Soeylemez +-- Copyright: (c) 2011 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez --- Stability: experimental -- -- This module implements a monad for SMTP sessions. @@ -12,8 +11,10 @@ module Network.Smtp.Monad ( -- * Running sessions runMailT, - runMailT_, + -- * Manipulating sessions + mailSetWriteTimeout, + -- * Utility functions mailError, mailPut, @@ -24,12 +25,13 @@ import qualified Data.Set as S import Control.ContStuff -import Control.Exception.Peel as Ex +--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.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 @@ -43,15 +45,17 @@ Monad m => SmtpCommand -> String -> Integer -> Vector ByteString -> MailT r m a mailError cmd errMsg code msgs = - throwError $ SmtpException errMsg cmd code (formatMsgs msgs) + lift . 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 + h <- getField mailHandle + timeout <- getField mailWriteTimeout + run (enum $$ iterHandleTimeout timeout h) >>= + either (lift . throwError) return -- | Send a list of 'ByteString's followed an SMTP line terminator to @@ -61,30 +65,38 @@ 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 = do - let smtpError = throwError $ userError "Connection closed prematurely" - EL.head >>= maybe smtpError return +nextResponse = + lift $ 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'. +-- | 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) => - Handle -> StringMailT (Either SomeException a) m a -> - m (Either SomeException a) -runMailT h c = + Int -> Int -> Handle -> MailT a m a -> + Iteratee ByteString m a +runMailT maxLine maxMsgs 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 + mailHandle = h, + mailWriteTimeout = 15000 } + in netLines maxLine =$ smtpResponses maxMsgs =$ evalStateT cfg c diff --git a/Network/Smtp/Session.hs b/Network/Smtp/Session.hs --- a/Network/Smtp/Session.hs +++ b/Network/Smtp/Session.hs @@ -1,9 +1,8 @@ -- | -- Module: Network.Smtp.Session --- Copyright: (c) 2010 Ertugrul Soeylemez +-- Copyright: (c) 2011 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez --- Stability: experimental -- -- SMTP session computations. @@ -18,6 +17,7 @@ quit, rcptTo, reset, + verify, waitForWelcome ) where @@ -44,7 +44,7 @@ L.drop 1 . V.toList $ msgs case code of - 250 -> lift $ modify (\cfg -> cfg { mailExtensions = exts }) + 250 -> modify (\cfg -> cfg { mailExtensions = exts }) 500 -> tryHelo 502 -> tryHelo 554 -> tryHelo @@ -94,7 +94,8 @@ _ -> mailError (SmtpMailFromCmd from) "MAIL FROM rejected" code msgs --- | Send /QUIT/ command. +-- | 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 = do @@ -102,6 +103,7 @@ SmtpResponse code msgs <- nextResponse case code of 221 -> return () + 250 -> return () _ -> mailError SmtpQuitCmd "Quit rejected" code msgs @@ -125,6 +127,24 @@ case code of 250 -> return () _ -> mailError SmtpResetCmd "RSET rejected" code msgs + + +-- | Send the /VRFY/ command to find out, whether the mail exchangers +-- knows the given user. Nowadays most mail exchangers disable this +-- command for security reasons. +-- +-- Please note that many SMTP servers will give you false positives or +-- false negatives to prevent spamming attempts. It is not recommended +-- to use this command. + +verify :: MonadIO m => ByteString -> MailT r m Bool +verify checkUser = do + mailPutLn ["VRFY ", checkUser] + SmtpResponse code msgs <- nextResponse + case code of + 250 -> return True + 550 -> return False + _ -> mailError (SmtpVerifyCmd checkUser) "VRFY rejected" code msgs -- | Wait for the welcome greeting from the SMTP server. diff --git a/Network/Smtp/Simple.hs b/Network/Smtp/Simple.hs --- a/Network/Smtp/Simple.hs +++ b/Network/Smtp/Simple.hs @@ -1,9 +1,8 @@ -- | -- Module: Network.Smtp.Simple --- Copyright: (c) 2010 Ertugrul Soeylemez +-- Copyright: (c) 2011 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez --- Stability: experimental -- -- Higher level interface to ismtp. @@ -34,7 +33,8 @@ 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. + mailTimeout :: Int, -- ^ Session timeout in milliseconds. + mailTimeoutIO :: Int -- ^ Read/write timeout in milliseconds. } @@ -48,30 +48,29 @@ mailMaxLine = 512, mailMaxMessages = 128, mailOutputHandle = outH, - mailTimeout = 60000 } + mailTimeout = 60000, + mailTimeoutIO = 15000 } -- | 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'). +-- Please note that both handles must be set to binary mode and be +-- unbuffered. See 'hSetBuffering' and 'hSetBinaryMode'. sendMail :: (Applicative m, MonadIO m) => - SendMail -> MailT (Either SomeException a) m a -> - m (Either SomeException a) -sendMail cfg c = + 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 } = cfg - in runMailT outH (enumHandleTimeout bufSize timeout inH $$ - responseLines maxLine maxMsgs c) + mailTimeout = timeout, + mailTimeoutIO = ioTimeout } = cfg + run $ enumHandleTimeout bufSize timeout inH $$ + runMailT maxLine maxMsgs outH (mailSetWriteTimeout ioTimeout >> c) -- | Like 'sendMail', but throws an exception on error. -sendMail_ :: (Applicative m, MonadIO m) => - SendMail -> MailT (Either SomeException a) m a -> - m a +sendMail_ :: (Applicative m, MonadIO m) => SendMail -> MailT a m a -> m a sendMail_ cfg = sendMail cfg >=> either throwIO return diff --git a/Network/Smtp/Tools.hs b/Network/Smtp/Tools.hs --- a/Network/Smtp/Tools.hs +++ b/Network/Smtp/Tools.hs @@ -1,9 +1,8 @@ -- | -- Module: Network.Smtp.Tools --- Copyright: (c) 2010 Ertugrul Soeylemez +-- Copyright: (c) 2011 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez --- Stability: experimental -- -- Helper functions and types. @@ -12,9 +11,6 @@ module Network.Smtp.Tools ( enumHandleTimeout, formatMsgs, - netLine, - netLines, - responseLines, smtpResponseLine, smtpResponse, smtpResponses, @@ -63,19 +59,6 @@ 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 diff --git a/Network/Smtp/Types.hs b/Network/Smtp/Types.hs --- a/Network/Smtp/Types.hs +++ b/Network/Smtp/Types.hs @@ -1,9 +1,8 @@ -- | -- Module: Network.Smtp.Types --- Copyright: (c) 2010 Ertugrul Soeylemez +-- Copyright: (c) 2011 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez --- Stability: experimental -- -- Types used by ismtp. @@ -13,7 +12,6 @@ ( -- * Mail monad Mail, MailT, - StringMailT, -- * SMTP service extensions Extension(..), @@ -54,39 +52,35 @@ -- | 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) +type MailT r m = StateT r MailConfig (Iteratee SmtpResponse m) -- | The 'Mail' monad is 'MailT' over 'IO'. -type Mail r a = MailT r IO a +type Mail r = MailT r IO -- | Mail session configuration. data MailConfig = MailConfig { - mailExtensions :: Set Extension, -- ^ Supported extensions. - mailHandle :: Handle -- ^ Connection handle. + mailExtensions :: Set Extension, -- ^ Supported extensions. + mailHandle :: Handle, -- ^ Connection handle. + mailWriteTimeout :: Int -- ^ Write timeout in milliseconds. } -- | Failed SMTP command (used by 'SmtpException'). data SmtpCommand - = SmtpWelcomeCmd -- ^ Waiting for welcome message. + = SmtpDataCmd -- ^ DATA. | SmtpHelloCmd ByteString -- ^ EHLO or HELO with domain. | SmtpMailFromCmd ByteString -- ^ MAIL FROM with address. + | SmtpQuitCmd -- ^ QUIT. | SmtpRcptToCmd ByteString -- ^ RCPT TO with address. - | SmtpDataCmd -- ^ DATA. | SmtpResetCmd -- ^ RSET. - | SmtpQuitCmd -- ^ QUIT. + | SmtpVerifyCmd ByteString -- ^ VRFY with the given user name. + | SmtpWelcomeCmd -- ^ Waiting for welcome message. -- | SMTP exception. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,5 +1,5 @@ ismtp setup script -Copyright (C) 2010, Ertugrul Soeylemez +Copyright (C) 2011, Ertugrul Soeylemez Please see the LICENSE file for terms and conditions of use, modification and distribution of this package, including this file. diff --git a/ismtp.cabal b/ismtp.cabal --- a/ismtp.cabal +++ b/ismtp.cabal @@ -1,14 +1,14 @@ Name: ismtp -Version: 2.0.3 +Version: 3.0.1 Category: Network Synopsis: Advanced ESMTP library Maintainer: Ertugrul Söylemez Author: Ertugrul Söylemez -Copyright: (c) 2010 Ertugrul Söylemez +Copyright: (c) 2011 Ertugrul Söylemez License: BSD3 License-file: LICENSE Build-type: Simple -Stability: experimental +Stability: beta Cabal-version: >= 1.6 Description: @@ -24,9 +24,8 @@ dnscache >= 1.0.1, enumerator >= 0.4.7, monad-peel >= 0.1, - netlines >= 0.3.0, + netlines >= 0.4.3, network >= 2.2.1.7, - unix >= 2.4.0.2, vector >= 0.7.0.1 GHC-Options: -W Exposed-modules: @@ -39,8 +38,9 @@ Network.Smtp.Tools Network.Smtp.Types --- Executable test +-- Executable ismtp-test -- Build-depends: --- base >= 4 && <= 5 +-- base >= 4 && <= 5, +-- unix -- GHC-Options: -W -threaded -- Main-is: Test.hs