ismtp (empty) → 1.0.0
raw patch · 5 files changed
+480/−0 lines, 5 filesdep +attoparsecdep +attoparsec-enumeratordep +basesetup-changed
Dependencies added: attoparsec, attoparsec-enumerator, base, blaze-builder, bytestring, containers, dnscache, enumerator, network-fancy, stm, transformers
Files
- LICENSE +32/−0
- Network/Smtp.hs +16/−0
- Network/Smtp/Protocol.hs +380/−0
- Setup.lhs +12/−0
- ismtp.cabal +40/−0
+ LICENSE view
@@ -0,0 +1,32 @@+ismtp license+Copyright (c) 2010, Ertugrul Soeylemez++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in+ the documentation and/or other materials provided with the+ distribution.++ * Neither the name of the author nor the names of any contributors+ may be used to endorse or promote products derived from this+ software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/Smtp.hs view
@@ -0,0 +1,16 @@+-- |+-- Module: Network.SMTP+-- Copyright: (c) 2010 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+-- Stability: experimental+--+-- Convenience module.++module Network.Smtp+ ( -- * Reexports+ module Network.Smtp.Protocol+ )+ where++import Network.Smtp.Protocol
+ Network/Smtp/Protocol.hs view
@@ -0,0 +1,380 @@+-- |+-- 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(..),++ -- * Session+ -- ** Creating+ runMail,+ sendMail,+ sendMailDirect,+ -- ** Chatting+ waitForWelcome,+ sendHello,+ sendMailFrom,+ sendRcptTo,+ sendData,+ sendReset,+ sendQuit,++ -- * Parsers+ codeParser+ )+ 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
+ Setup.lhs view
@@ -0,0 +1,12 @@+ismtp setup script+Copyright (C) 2010, Ertugrul Soeylemez++Please see the LICENSE file for terms and conditions of use,+modification and distribution of this package, including this file.++> module Main where+>+> import Distribution.Simple+>+> main :: IO ()+> main = defaultMain
+ ismtp.cabal view
@@ -0,0 +1,40 @@+Name: ismtp+Version: 1.0.0+Category: Network+Synopsis: Incremental SMTP sessions+Maintainer: Ertugrul Söylemez <es@ertes.de>+Author: Ertugrul Söylemez <es@ertes.de>+Copyright: (c) 2010 Ertugrul Söylemez+License: BSD3+License-file: LICENSE+Build-type: Simple+Stability: experimental+Cabal-version: >= 1.6+Description:+ This library provides incremental SMTP sessions, so you can control+ each aspect of the session. It also provides a small DNS cache for+ MX records.++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,+ dnscache >= 1.0.0,+ enumerator >= 0.4.2,+ network-fancy >= 0.1.5,+ stm >= 2.1.2.1,+ transformers >= 0.2.2.0+ GHC-Options: -W+ Exposed-modules:+ Network.Smtp+ Network.Smtp.Protocol++--Executable test+-- Build-depends:+-- base >= 4 && <= 5+-- GHC-Options: -W -threaded+-- Main-is: Test.hs