diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/Smtp.hs b/Network/Smtp.hs new file mode 100644 --- /dev/null +++ b/Network/Smtp.hs @@ -0,0 +1,16 @@ +-- | +-- Module: Network.SMTP +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- Convenience module. + +module Network.Smtp + ( -- * Reexports + module Network.Smtp.Protocol + ) + where + +import Network.Smtp.Protocol diff --git a/Network/Smtp/Protocol.hs b/Network/Smtp/Protocol.hs new file mode 100644 --- /dev/null +++ b/Network/Smtp/Protocol.hs @@ -0,0 +1,380 @@ +-- | +-- 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(..), + + -- * 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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -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 diff --git a/ismtp.cabal b/ismtp.cabal new file mode 100644 --- /dev/null +++ b/ismtp.cabal @@ -0,0 +1,40 @@ +Name: ismtp +Version: 1.0.0 +Category: Network +Synopsis: Incremental SMTP sessions +Maintainer: Ertugrul Söylemez +Author: Ertugrul Söylemez +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