SMTPClient-1.0.4/0000755000000000000000000000000011617610036011625 5ustar0000000000000000SMTPClient-1.0.4/LICENSE0000644000000000000000000000277311617610036012643 0ustar0000000000000000Copyright (c) 2008 Stephen Blackheath Copyright (c) 2009 Matthew Elder All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. SMTPClient-1.0.4/SMTPClient.cabal0000644000000000000000000000147611617610036014543 0ustar0000000000000000name: SMTPClient version: 1.0.4 license: BSD3 license-file: LICENSE cabal-version: >= 1.6 copyright: (c) Stephen Blackheath 2008, (c) Matthew Elder 2009 author: Stephen Blackheath, Matthew Elder, Jeremy Shaw maintainer: http://blacksapphire.com/antispam/ stability: stable synopsis: A simple SMTP client library description: A simple SMTP client library for applications that want to send emails. extra-source-files: example.hs LICENSE category: Network build-type: Simple source-repository head type: darcs location: http://code.haskell.org/SMTPClient/ Library exposed-modules: Network.SMTP.Client, Network.SMTP.ClientSession, Network.SMTP.Simple build-depends: base >= 3 && < 5, hsemail == 1.*, network, old-time, old-locale, containers, extensible-exceptions >= 0.1 && < 0.2 SMTPClient-1.0.4/example.hs0000644000000000000000000000271611617610036013622 0ustar0000000000000000import Network.SMTP.ClientSession import Network.SMTP.Client import Network.Socket import System.Time import System.IO import Data.Bits import Data.IORef myDomain = "example.com" smtpHost = "hubert" -- <-- Your SMTP server here -- This will send the author an email. I don't mind! main = do now <- getClockTime nowCT <- toCalendarTime now let message = Message [ From [NameAddr (Just "Mr. Nobody") "nobody@example.com"], To [NameAddr (Just "Stephen Blackheath") "maxine@hip-to-be-square.com"], Subject "I'm using SMTPClient!", Date nowCT ] ("Dear Sir,\n"++ "It has come to my attention that this is an email.\n"++ "Yours sincerely,\n"++ "Mr. Nobody\n") addrs <- getAddrInfo Nothing (Just smtpHost) Nothing let SockAddrInet _ hostAddr = addrAddress (addrs !! 0) sockAddr = SockAddrInet (fromIntegral 25) hostAddr putStrLn $ "connecting to "++show sockAddr sentRef <- newIORef [] sendSMTP' (hPutStrLn stderr) (Just sentRef) myDomain sockAddr [message] statuses <- readIORef sentRef -- If no exception was caught, statuses is guaranteed to be -- the same length as the list of input messages, therefore head won't fail here. case head statuses of Nothing -> putStrLn "Message successfully sent" Just status -> putStrLn $ "Message send failed with status "++show status SMTPClient-1.0.4/Setup.hs0000644000000000000000000000005711617610036013263 0ustar0000000000000000import Distribution.Simple main = defaultMain SMTPClient-1.0.4/Network/0000755000000000000000000000000011617610036013256 5ustar0000000000000000SMTPClient-1.0.4/Network/SMTP/0000755000000000000000000000000011617610036014041 5ustar0000000000000000SMTPClient-1.0.4/Network/SMTP/Simple.hs0000644000000000000000000000645511617610036015640 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Network.SMTP.Simple -- Copyright : 2009 Matthew Elder -- License : BSD3 -- -- Maintainer : Matthew Elder -- Stability : provisional -- Portability : linux/windows -- -- Mail is a simple library with which you can add email functionality to your -- application. It assumes you have access to a smarthost which can relay all -- your mail. -- -- As an example: -- -- > import Network.SMTP.Simple -- > import System.IO -- > -- > main :: IO () -- > main = do -- > sendSimpleMessages (hPutStrLn stderr) "10.2.23.11" "example.com" [message] -- > where message = SimpleMessage -- > [NameAddr (Just "John Doe") "johnd@example.com"] -- > [NameAddr (Just "Team") "team@exmaple.com"] -- > "My test email using Network.SMTP.Simple" -- > "Hi, this is a test email which uses SMTPClient." module Network.SMTP.Simple ( NameAddr(..) , SimpleMessage(..) , sendRawMessages , sendSimpleMessages ) where import Data.IORef (newIORef, readIORef) import Network.Socket (SockAddr(..) , inet_addr ) import Network.SMTP.Client import System.Time ( CalendarTime(..) , getClockTime , toCalendarTime ) data SimpleMessage = SimpleMessage { from :: [NameAddr] -- ^ The sender(s) , to :: [NameAddr] -- ^ The recipient(s) , subject :: String -- ^ The subject line , body :: String -- ^ The body } deriving (Show) toMessage :: CalendarTime -> SimpleMessage -> Message toMessage ct sm = Message [From (from sm), To (to sm), Subject (subject sm), Date ct] (body sm) -- | Simplest way to send mail. Takes the smarthost ip, the HELO domain, and a list of SimpleMessage. sendSimpleMessages :: (String -> IO ()) -- ^ Diagnostic log function -> String -- ^ IP address of the smarthost -> String -- ^ HELO domain (should be the same as your from-address-domain) -> [SimpleMessage] -- ^ List of simple messages to send -> IO () sendSimpleMessages log smartHostIp heloDomain simpleMessages = do nowCT <- toCalendarTime =<< getClockTime hostAddr <- inet_addr smartHostIp let smtpSockAddr = SockAddrInet 25 hostAddr sendRawMessages log smtpSockAddr heloDomain (map (toMessage nowCT) simpleMessages) -- | Use this if you need more control than sendSimpleMessages gives you. sendRawMessages :: (String -> IO ()) -- ^ Diagnostic log function -> SockAddr -- ^ SockAddr for the smarthost -> String -- ^ HELO domain (should be the same as your from-address-domain) -> [Message] -- ^ List of messages to send -> IO () sendRawMessages log smtpSockAddr heloDomain messages = do sentRef <- newIORef [] sendSMTP' log (Just sentRef) heloDomain smtpSockAddr messages statuses <- readIORef sentRef -- If no exception was caught, statuses is guaranteed to be -- the same length as the list of input messages, therefore head won't fail here. case head statuses of Nothing -> return () Just status -> log $ "message failed: " ++ show status SMTPClient-1.0.4/Network/SMTP/ClientSession.hs0000644000000000000000000004075311617610036017170 0ustar0000000000000000-- | A pure SMTP client state machine. -- -- Data structures for representing SMTP status codes and email messages are -- re-exported here from /Text.ParserCombinators.Parsec.Rfc2821/ and -- /Text.ParserCombinators.Parsec.Rfc2822/ in the /hsemail/ package. module Network.SMTP.ClientSession ( smtpClientSession, SMTPState(..), SmtpReply(..), SmtpCode(..), SuccessCode(..), Category(..), Message, GenericMessage(..), Field(..), NameAddr(..) {-, suite-} ) where import Text.ParserCombinators.Parsec.Rfc2821 ( SmtpReply(..), SmtpCode(..), SuccessCode(..), Category(..), reply ) import Text.ParserCombinators.Parsec.Rfc2822 ( Message(..), GenericMessage(..), Field(..), NameAddr(..) ) import Data.Maybe import qualified Data.Set as Set import Prelude hiding (fail) import Data.List import System.Time import System.Locale {-import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit-} {-suite = testGroup "MetaBarter.SMTP.SMTP" [ testCase "dotAtomAllowed" test_dotAtomAllowed, testCase "quoted_string" test_quoted_string ]-} data SMTPState = SMTPState { -- | Step 1. Caller must send any lines queued up in this list to the SMTP -- server. They do not have end-of-line characters, so you must add -- \"\\r\\n\" on the end (both characters are required by RFC2821 - do not -- just send \"\\n\"). smtpOutQueue :: [String], -- | Step 2. Check if this is True, which indicates that the SMTP session -- has completed successfully and there is no more work to do. smtpSuccess :: Bool, -- | Step 3. Check if this is Just err, which indicates that a protocol error -- has occurred, and that the caller must terminate the session. smtpFailure :: Maybe String, -- | Step 4. The caller should wait for a line from the SMTP server, -- strip the \"\\r\\n\" end-of-line characters, and pass the stripped -- line to this function for processing. Go to step 1. smtpReceive :: String -> SMTPState -> SMTPState, -- | A list containing a failure status for each message that has been sent so far, -- where each element corresponds to one in the list of messages. -- If the SMTP session does not complete successfully, then this list is -- likely to be shorter than the input messages list. When smtpSuccess is -- true, this list is guaranteed to be the same length as the list of input -- messages. -- /Nothing/ means success, and /Just x/ is a failure status returned by -- the SMTP server. smtpStatuses :: [Maybe SmtpReply] } send :: String -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState send txt cont state = cont $ state { smtpOutQueue = txt:smtpOutQueue state } -- | A 'null' smtpReceive callback that discards anything given to it. nullReceive :: String -> SMTPState -> SMTPState nullReceive _ state = state receive :: (String -> SMTPState -> SMTPState) -> SMTPState -> SMTPState receive cont state = state { -- Reverse the out queue before passing it to the caller because we -- have been assembling it backwards. smtpOutQueue = reverse $ smtpOutQueue state, smtpReceive = \line state -> cont line $ state { smtpOutQueue = [], smtpReceive = nullReceive } } fail :: String -> SMTPState -> SMTPState fail errorText state = state { smtpOutQueue = [], smtpFailure = Just errorText } success :: SMTPState -> SMTPState success state = state { smtpOutQueue = [], smtpSuccess = True } equals :: SuccessCode -> Category -> SmtpReply -> Bool equals code cat reply = case reply of Reply (Code gotCode gotCat _) _ | gotCode == code && gotCat == cat -> True otherwise -> False check :: (SmtpReply -> Bool) -> String -> SmtpReply -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState check isOK descr reply cont = if isOK reply then cont else fail $ "SMTP error: got "++ (cleanUp $ show reply)++ " when I expected "++descr -- | Squish the SMTP reply description into one line. cleanUp :: String -> String cleanUp = map (\x -> if x == '\n' then '/' else x) . reverse . dropWhile (\x -> x == '\n') . reverse . filter (/= '\r') maybeRead :: Read a => String -> Maybe a maybeRead s = case reads s of [(x, "")] -> Just x _ -> Nothing for :: [a] -- loop body, passed: value next -> (a -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState) -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState for [] _ cont = cont for (x:xs) body cont = body x $ for xs body cont putStatuses :: [Maybe SmtpReply] -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState putStatuses statuses cont state = cont $ state {smtpStatuses = statuses} -- | Receive an SMTP reply, e.g. -- 250-worked -- 250-like -- 250 a charm receiveReply :: (SmtpReply -> SMTPState -> SMTPState) -> SMTPState -> SMTPState receiveReply cont = rec [] $ \revMsgs@(final:_) -> if length final < 4 || final !! 3 /= ' ' then fail ("malformed SMTP reply: "++final) else case maybeRead (take 3 final) of Just code -> cont $ mkReply code (reverse $ map (drop 4) revMsgs) Nothing -> fail ("Malformed SMTP reply: "++final) where rec :: [String] -> ([String] -> SMTPState -> SMTPState) -> SMTPState -> SMTPState rec msgs cont = receive $ \line -> if length line < 4 then fail ("malformed SMTP reply: "++line) else if line !! 3 == '-' then rec (line:msgs) cont else cont (line:msgs) mkReply :: Int -> [String] -> SmtpReply mkReply code msgs = reply (code `div` 100) ((code `div` 10) `mod` 10) (code `mod` 10) msgs equalsMailOK :: SmtpReply -> Bool equalsMailOK = equals Success MailSystem checkMailOK :: (SMTPState -> SMTPState) -> SMTPState -> SMTPState checkMailOK cont = receiveReply $ \reply -> check equalsMailOK "\"mail system OK\" (code 25x)" reply $ cont checkConnectionOK :: (SMTPState -> SMTPState) -> SMTPState -> SMTPState checkConnectionOK cont = receiveReply $ \reply -> check (equals Success Connection) "\"connection OK\" (code 22x)" reply $ cont equalsDataOK :: SmtpReply -> Bool equalsDataOK = equals IntermediateSuccess MailSystem -- | Construct a pure state machine for an SMTP client session. Caller must -- handle I/O. The message body may use either \"\\n\" or \"\\r\\n\" as an -- end-of-line marker. smtpClientSession :: String -- ^ Domain name used in EHLO command -> [Message] -- ^ List of messges to send -> SMTPState smtpClientSession domain messages = talk domain messages $ SMTPState { smtpOutQueue = [], smtpReceive = nullReceive, smtpSuccess = False, smtpFailure = Nothing, smtpStatuses = [] } -- Continuation passing style. talk :: String -> [Message] -> SMTPState -> SMTPState talk domain messages = checkConnectionOK $ send ("EHLO "++domain) $ checkMailOK $ sendMessages messages [] $ send "QUIT" $ checkConnectionOK $ success where sendMessages :: [Message] -> [Maybe SmtpReply] -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState sendMessages [] _ cont = cont sendMessages (message:rest) statuses cont = sendMessage message $ \status -> let statuses' = status:statuses in -- collate statuses backwards putStatuses (reverse statuses') $ -- reverse to store in correct order sendMessages rest statuses' cont sendMessage :: Message -> (Maybe SmtpReply -> SMTPState -> SMTPState) -> SMTPState -> SMTPState sendMessage message cont = let Message fields _ = message froms = map (\(NameAddr _ addr) -> addr) $ concatMap (\f -> case f of From from -> from _ -> []) fields tos = map (\(NameAddr _ addr) -> addr) $ concatMap (\f -> case f of To to -> to Cc to -> to Bcc to -> to _ -> []) fields in if null froms then fail "email contains no From: field" else if null tos then fail "email contains no To:, Cc: or Bcc: field" else ( send ((("MAIL FROM:"++) . angle_addr (head froms)) "") $ receiveReply $ \reply -> if not $ equalsMailOK reply then cont (Just reply) -- failure status else ( for tos (\to next -> send ((("RCPT TO:"++) . angle_addr to) "") $ receiveReply $ \reply -> if not $ equalsMailOK reply then cont (Just reply) -- failure status else next ) $ send "DATA" $ receiveReply $ \reply -> if not $ equalsDataOK reply then cont (Just reply) -- failure status else ( let msgLines = formatMessage message in for msgLines (\line cont -> send (if line == "." then ". " else line) $ cont ) $ send "." $ receiveReply $ \reply -> if not $ equalsMailOK reply then cont (Just reply) -- failure status else cont Nothing -- success ) ) ) atext_alphabet = Set.fromList $ "abcdefghijklmnopqrstuvwxyz"++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ"++ "0123456789"++ "!#$%&'*+-/=?^_`{|}~" atomAllowed :: String -> Bool atomAllowed "" = False atomAllowed txt = all (`Set.member` atext_alphabet) txt dotAtomAllowed :: String -> Bool dotAtomAllowed str = let (at, rest) = break (== '.') str in if not $ atomAllowed at then False else if null rest then True else dotAtomAllowed (tail rest) {- test_dotAtomAllowed = do assertEqual "" False (dotAtomAllowed "") assertEqual "a" True (dotAtomAllowed "a") assertEqual "a<" False (dotAtomAllowed "a<") assertEqual ".a" False (dotAtomAllowed ".a") assertEqual "abc.012$" True (dotAtomAllowed "abc.012$") assertEqual "01.%^.xyzzy" True (dotAtomAllowed "01.%^.xyzzy") assertEqual "01..xyzzy" False (dotAtomAllowed "01..xyzzy") assertEqual "01.xyzzy." False (dotAtomAllowed "01.xyzzy.") -} addr_spec :: String -> ShowS addr_spec addr = let (local, at_domain) = break (=='@') addr domain = if "@" `isPrefixOf` at_domain then tail at_domain else at_domain in dotatom_or_quoted local . ("@"++) . dotatom_or_domain_literal domain angle_addr :: String -> ShowS angle_addr addr = ("<"++) . addr_spec addr . (">"++) msg_id :: String -> ShowS msg_id mid = angle_addr mid atom_or_quoted :: String -> ShowS atom_or_quoted text = if atomAllowed text then (text++) else quoted_string text phrase = atom_or_quoted display_name = phrase dotatom_or_quoted :: String -> ShowS dotatom_or_quoted text = if dotAtomAllowed text then (text++) else quoted_string text quoted_string :: String -> ShowS quoted_string text = ("\""++) . (quoted_ text++) . ("\""++) where quoted_ [] = [] quoted_ (x:xs) = case x of '\\' -> '\\':'\\':quoted_ xs '"' -> '\\':'"':quoted_ xs _ -> x:quoted_ xs {- test_quoted_string = do assertEqual "" (quoted_string "" "") "\"\"" assertEqual "Hello" (quoted_string "Hello" "") "\"Hello\"" assertEqual "Say, \"Hello\"" (quoted_string "Say, \"Hello\"" "") "\"Say, \\\"Hello\\\"\"" assertEqual "Backslash\\" (quoted_string "Backslash\\" "") "\"Backslash\\\\\"" -} dotatom_or_domain_literal :: String -> ShowS dotatom_or_domain_literal text = if dotAtomAllowed text then (text++) else domain_literal text domain_literal :: String -> ShowS domain_literal text = ("["++) . (quoted_ text++) . ("]"++) where quoted_ [] = [] quoted_ (x:xs) = case x of '\\' -> '\\':'\\':quoted_ xs '[' -> '\\':'[':quoted_ xs ']' -> '\\':']':quoted_ xs _ -> x:quoted_ xs name_addr :: NameAddr -> ShowS name_addr (NameAddr mName addr) = (case mName of Just name -> display_name name . (" "++) Nothing -> id) . angle_addr addr address_list :: [NameAddr] -> ShowS address_list addrs = foldr (.) id $ intersperse (",\n"++) $ map name_addr addrs formatMessage :: Message -> [String] formatMessage (Message fields body) = concatMap (indent . formatField) fields ++ [""] ++ map (reverse . dropWhile (=='\r') . reverse) (lines body) indent :: String -> [String] indent text = case lines text of [] -> [] (l:ls) -> l:map (" "++) ls formatField :: Field -> String formatField (OptionalField name value) = name ++ ": " ++ value formatField (From addrs) = (("From: "++) . address_list addrs) "" formatField (Sender addr) = (("From: "++) . name_addr addr) "" formatField (ReturnPath txt) = "Return-Path: "++txt formatField (ReplyTo addrs) = (("Reply-To: "++) . address_list addrs) "" formatField (To addrs) = (("To: "++) . address_list addrs) "" formatField (Cc addrs) = (("Cc: "++) . address_list addrs) "" formatField (Bcc addrs) = (("Bcc: "++) . address_list addrs) "" formatField (MessageID mid) = (("Message-ID: "++) . msg_id mid) "" formatField (InReplyTo mids) = (("In-Reply-To: "++) . foldr (.) id (map msg_id mids)) "" formatField (References mids) = (("References: "++) . foldr (.) id (map msg_id mids)) "" formatField (Subject txt) = "Subject: "++txt formatField (Comments txt) = "Comments: "++txt formatField (Keywords kws) = (("Keywords: "++) . foldr (.) id (intersperse (",\n"++) $ map phrase (concat kws))) "" formatField (Date date) = "Date: "++formatDate date formatField (ResentDate date) = "Resent-Date: "++formatDate date formatField (ResentFrom addrs) = (("Resent-From: "++) . address_list addrs) "" formatField (ResentSender addr) = (("Resent-From: "++) . name_addr addr) "" formatField (ResentTo addrs) = (("Resent-To: "++) . address_list addrs) "" formatField (ResentCc addrs) = (("Resent-Cc: "++) . address_list addrs) "" formatField (ResentBcc addrs) = (("Resent-Bcc: "++) . address_list addrs) "" formatField (ResentMessageID mid) = (("Resent-Message-ID: "++) . msg_id mid) "" formatField (ResentReplyTo addrs) = (("Resent-Reply-To: "++) . address_list addrs) "" formatField (Received (ps, date)) = (("Received: "++) . pairs ps . (";"++) . (formatDate date++)) "" formatField (ObsReceived ps) = (("Received: "++) . pairs ps) "" formatDate :: CalendarTime -> String formatDate ct = formatCalendarTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S " ct ++ formatTimeZone (ctTZ ct) formatTimeZone :: Int -> String formatTimeZone offset = if offset < 0 then "-"++ftz (-offset) else "+"++ftz offset where ftz offset = dig2 (offset `div` 3600) ++ dig2 ((offset `div` 60) `mod` 60) dig2 n = (\n -> if n < 10 then "0"++show n else show n) (n `mod` 100) pairs :: [(String, String)] -> ShowS pairs ps = foldr (.) id $ intersperse ("\n"++) $ map pair ps where pair (name, value) = (name++) . (" "++) . (value++) SMTPClient-1.0.4/Network/SMTP/Client.hs0000644000000000000000000001423411617610036015617 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} -- | An SMTP client in the IO Monad. -- -- Data structures for representing SMTP status codes and email messages are -- re-exported here from /Text.ParserCombinators.Parsec.Rfc2821/ and -- /Text.ParserCombinators.Parsec.Rfc2822/ in the /hsemail/ package. -- -- Here's a working example: -- -- > import Network.SMTP.ClientSession -- > import Network.SMTP.Client -- > import Network.Socket -- > import System.Time -- > import System.IO -- > import Data.Bits -- > import Data.IORef -- > -- > myDomain = "example.com" -- > smtpHost = "hubert" -- <-- Your SMTP server here -- > -- > -- This will send the author an email. I don't mind! -- > main = do -- > now <- getClockTime -- > nowCT <- toCalendarTime now -- > let message = Message [ -- > From [NameAddr (Just "Mr. Nobody") "nobody@example.com"], -- > To [NameAddr (Just "Stephen Blackheath") "maxine@hip-to-be-square.com"], -- > Subject "I'm using SMTPClient!", -- > Date nowCT -- > ] -- > ("Dear Sir,\n"++ -- > "It has come to my attention that this is an email.\n"++ -- > "Yours sincerely,\n"++ -- > "Mr. Nobody\n") -- > addrs <- getAddrInfo Nothing (Just smtpHost) Nothing -- > let SockAddrInet _ hostAddr = addrAddress (addrs !! 0) -- > sockAddr = SockAddrInet (fromIntegral 25) hostAddr -- > putStrLn $ "connecting to "++show sockAddr -- > sentRef <- newIORef [] -- > sendSMTP' (hPutStrLn stderr) (Just sentRef) myDomain -- > sockAddr [message] -- > statuses <- readIORef sentRef -- > -- If no exception was caught, statuses is guaranteed to be -- > -- the same length as the list of input messages, therefore head won't fail here. -- > case head statuses of -- > Nothing -> putStrLn "Message successfully sent" -- > Just status -> putStrLn $ "Message send failed with status "++show status module Network.SMTP.Client ( sendSMTP, sendSMTP', processSMTP, SMTPException(..), SmtpReply(..), SmtpCode(..), SuccessCode(..), Category(..), Message, GenericMessage(..), Field(..), NameAddr(..) ) where import Network.SMTP.ClientSession import Control.Exception.Extensible import Text.ParserCombinators.Parsec.Rfc2821 ( SmtpReply(..), SmtpCode(..), SuccessCode(..), Category(..) ) import Text.ParserCombinators.Parsec.Rfc2822 ( Message(..), GenericMessage(Message), Field(..), NameAddr(..) ) import Network.Socket import Control.Applicative import System.IO import Control.Monad import Data.Typeable import Data.IORef -- | Send a list of email messages to an SMTP server. Throws SMTPException on -- failure at the communication protocol level, and it can also throw -- socket-level exceptions. -- -- The optional IORef is used to store a list of statuses for messages sent so -- far, where Nothing means success. The list elements correspond to the elements -- of the input message list. If the caller catches an exception, this list is -- likely to be shorter than the input message list: The length of the list -- indicates how many messages were dispatched. If no exception is caught, the -- length of the statuses will equal the length of the input messages list. -- -- The message body may use either \"\\n\" or \"\\r\\n\" as an end-of-line -- marker and in either case it will be sent correctly to the server. sendSMTP :: Maybe (IORef [Maybe SmtpReply]) -- ^ For storing failure statuses of messages sent so far -> String -- ^ Domain name for EHLO command -> SockAddr -- ^ Network address of SMTP server -> [Message] -- ^ List of messages to send -> IO () sendSMTP = sendSMTP' (\_ -> return ()) -- | Like sendSMTP but takes an additional function for logging all input and -- output for diagnostic purposes. sendSMTP' :: (String -> IO ()) -- ^ Diagnostic log function -> Maybe (IORef [Maybe SmtpReply]) -- ^ For storing failure statuses of messages sent so far -> String -- ^ Domain name for EHLO command -> SockAddr -- ^ Network address of SMTP server -> [Message] -- ^ List of messages to send -> IO () sendSMTP' log mStatuses domain sockAddr messages = do handle <- bracketOnError (socket AF_INET Stream defaultProtocol) sClose (\sock -> do connect sock sockAddr socketToHandle sock ReadWriteMode ) (do let smtp = smtpClientSession domain messages processSMTP log mStatuses handle smtp ) `finally` hClose handle -- | A lower level function that does the I/O processing for an SMTP client session on a handle. -- Returns when the session has completed, with the handle still open. processSMTP :: (String -> IO ()) -- ^ Diagnostic log function -> Maybe (IORef [Maybe SmtpReply]) -- ^ For storing failure statuses of messages sent so far -> Handle -> SMTPState -> IO () processSMTP log mStatuses h state = do case mStatuses of Just statuses -> writeIORef statuses (smtpStatuses state) Nothing -> return () forM_ (smtpOutQueue state) $ \line -> do log $ "-> "++line hPutStr h line hPutStr h "\r\n" hFlush h case (smtpSuccess state, smtpFailure state) of (True, _) -> do log "SUCCEEDED" (False, Just err) -> throwIO $ SMTPException err otherwise -> do -- Strip trailing \r. hGetLine has already stripped \n for us. reply <- reverse . dropWhile (=='\r') . reverse <$> hGetLine h log $ "<- "++reply let state' = smtpReceive state reply $ state {smtpOutQueue = []} processSMTP log mStatuses h state' -- | An exception indicating a communications failure at the level of the SMTP protocol. data SMTPException = SMTPException String deriving (Eq, Show, Typeable) instance Exception SMTPException where