diff --git a/Network/SMTP/Client.hs b/Network/SMTP/Client.hs --- a/Network/SMTP/Client.hs +++ b/Network/SMTP/Client.hs @@ -13,19 +13,17 @@ -- > import Network.Socket -- > import System.Time -- > import System.IO --- > import Data.Bits -- > import Data.IORef -- > -- > myDomain = "example.com" --- > smtpHost = "hubert" -- <-- Your SMTP server here +-- > smtpHost = "mail.example.com" -- <-- 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"], +-- > To [NameAddr (Just "Mr. Somebody") "somebody@example.com"], -- > Subject "I'm using SMTPClient!", -- > Date nowCT -- > ] @@ -33,13 +31,10 @@ -- > "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 +-- > addrs <- getAddrInfo Nothing (Just smtpHost) (Just "25") +-- > putStrLn $ "connecting to "++show (map addrAddress addrs) -- > sentRef <- newIORef [] --- > sendSMTP' (hPutStrLn stderr) (Just sentRef) myDomain --- > sockAddr [message] +-- > sendSMTP' (hPutStrLn stderr) (Just sentRef) myDomain addrs [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. @@ -64,6 +59,7 @@ import Network.SMTP.ClientSession import Control.Exception.Extensible +import Control.Monad import Text.ParserCombinators.Parsec.Rfc2821 ( SmtpReply(..), SmtpCode(..), @@ -82,6 +78,7 @@ import Control.Monad import Data.Typeable import Data.IORef +import Data.List (foldl1') -- | Send a list of email messages to an SMTP server. Throws SMTPException on @@ -100,7 +97,7 @@ 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 + -> [AddrInfo] -- ^ Network addresses of SMTP server (will try each in turn) -> [Message] -- ^ List of messages to send -> IO () sendSMTP = sendSMTP' (\_ -> return ()) @@ -110,21 +107,25 @@ 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 + -> [AddrInfo] -- ^ Network addresses of SMTP server (will try each in turn) -> [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 +sendSMTP' log mStatuses domain addrs messages = do + eHandle <- try . foldl1' mplus . map ( + \addr -> bracketOnError + (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) + sClose + (\sock -> do + connect sock (addrAddress addr) + socketToHandle sock ReadWriteMode + ) + ) $ addrs + case eHandle of + Left exc -> throwIO (exc :: IOException) + Right handle -> do let smtp = smtpClientSession domain messages processSMTP log mStatuses handle smtp - ) `finally` hClose handle + `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. diff --git a/Network/SMTP/Simple.hs b/Network/SMTP/Simple.hs --- a/Network/SMTP/Simple.hs +++ b/Network/SMTP/Simple.hs @@ -35,9 +35,7 @@ import Data.IORef (newIORef, readIORef) import Network.Socket - (SockAddr(..) - , inet_addr - ) + (AddrInfo, getAddrInfo) import Network.SMTP.Client import System.Time ( CalendarTime(..) @@ -60,27 +58,26 @@ [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. +-- | Simplest way to send mail. Takes the SMTP hostname, the HELO domain, and a list of SimpleMessage. sendSimpleMessages :: (String -> IO ()) -- ^ Diagnostic log function - -> String -- ^ IP address of the smarthost + -> String -- ^ Host name for the SMTP server -> 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 +sendSimpleMessages log smartHostName heloDomain simpleMessages = do nowCT <- toCalendarTime =<< getClockTime - hostAddr <- inet_addr smartHostIp - let smtpSockAddr = SockAddrInet 25 hostAddr - sendRawMessages log smtpSockAddr heloDomain (map (toMessage nowCT) simpleMessages) + addrs <- getAddrInfo Nothing (Just smartHostName) (Just "25") + sendRawMessages log addrs 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 + -> [AddrInfo] -- ^ AddrInfos for the SMTP server -> 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 +sendRawMessages log addrs heloDomain messages = do sentRef <- newIORef [] - sendSMTP' log (Just sentRef) heloDomain smtpSockAddr messages + sendSMTP' log (Just sentRef) heloDomain addrs messages statuses <- readIORef sentRef -- If no exception was caught, statuses is guaranteed to be diff --git a/SMTPClient.cabal b/SMTPClient.cabal --- a/SMTPClient.cabal +++ b/SMTPClient.cabal @@ -1,15 +1,17 @@ name: SMTPClient -version: 1.0.4 +version: 1.1.0 license: BSD3 license-file: LICENSE cabal-version: >= 1.6 -copyright: (c) Stephen Blackheath 2008, (c) Matthew Elder 2009 +copyright: (c) Stephen Blackheath 2008-2013, (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. + . + v1.1.0: IPv6 supported properly. extra-source-files: example.hs LICENSE diff --git a/example.hs b/example.hs --- a/example.hs +++ b/example.hs @@ -3,19 +3,17 @@ import Network.Socket import System.Time import System.IO -import Data.Bits import Data.IORef myDomain = "example.com" -smtpHost = "hubert" -- <-- Your SMTP server here +smtpHost = "mail.example.com" -- <-- 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"], + To [NameAddr (Just "Mr. Somebody") "somebody@example.com"], Subject "I'm using SMTPClient!", Date nowCT ] @@ -23,13 +21,10 @@ "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 + addrs <- getAddrInfo Nothing (Just smtpHost) (Just "25") + putStrLn $ "connecting to "++show (map addrAddress addrs) sentRef <- newIORef [] - sendSMTP' (hPutStrLn stderr) (Just sentRef) myDomain - sockAddr [message] + sendSMTP' (hPutStrLn stderr) (Just sentRef) myDomain addrs [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.