ismtp 1.0.2 → 2.0.0

raw patch · 9 files changed

+786/−415 lines, 9 filesdep +contstuffdep +monad-peeldep +networkdep −attoparsecdep −attoparsec-enumeratordep −blaze-builderdep ~enumeratorPVP ok

version bump matches the API change (PVP)

Dependencies added: contstuff, monad-peel, network, unix, vector

Dependencies removed: attoparsec, attoparsec-enumerator, blaze-builder, network-fancy, stm, transformers

Dependency ranges changed: enumerator

API changes (from Hackage documentation)

Files

• Network/Smtp.hs +42/−17
• Network/Smtp/Connect.hs +97/−0
• Network/Smtp/Monad.hs +90/−0
• Network/Smtp/Protocol.hs +0/−385
• Network/Smtp/Session.hs +137/−0
• Network/Smtp/Simple.hs +77/−0
• Network/Smtp/Tools.hs +220/−0
• Network/Smtp/Types.hs +107/−0
• ismtp.cabal +16/−13

@@ -5,30 +5,55 @@ -- Maintainer: Ertugrul Soeylemez <es@ertes.de> -- 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

@@ -0,0 +1,97 @@+-- |+-- Module:     Network.Smtp.Connect+-- Copyright:  (c) 2010 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+-- 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

@@ -0,0 +1,90 @@+-- |+-- Module:     Network.Smtp.Monad+-- Copyright:  (c) 2010 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+-- 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

@@ -1,385 +0,0 @@--- |--- Module:     Network.Smtp.Protocol--- Copyright:  (c) 2010 Ertugrul Soeylemez--- License:    BSD3--- Maintainer: Ertugrul Soeylemez <es@ertes.de>--- 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

@@ -0,0 +1,137 @@+-- |+-- Module:     Network.Smtp.Session+-- Copyright:  (c) 2010 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+-- 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

@@ -0,0 +1,77 @@+-- |+-- Module:     Network.Smtp.Simple+-- Copyright:  (c) 2010 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+-- 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

@@ -0,0 +1,220 @@+-- |+-- Module:     Network.Smtp.Tools+-- Copyright:  (c) 2010 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+-- 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

@@ -0,0 +1,107 @@+-- |+-- Module:     Network.Smtp.Types+-- Copyright:  (c) 2010 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+-- 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)

@@ -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 <es@ertes.de> Author:        Ertugrul Söylemez <es@ertes.de> 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: