{- Copyright (C) 2003, Massimo Zaniboni 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 Massimo Zaniboni nor the names of its 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. -} -- | A very simple SMTP Client library for sending emails. -- module Network.SMTP.Client.HSmtpClient ( sendStringAsEMail, SMTPAuthMethod(..) ) where import Data.List import Data.Char import Control.Monad import Control.Exception import System.IO import System.Directory import System.Time import Network import Base64 debugSMTP = False -- ^ if True then display debug info -- | SMTP authorization method -- data SMTPAuthMethod = PlainSMTPAuth | LoginSMTPAuth | NoSMTPAuth -- | Send an email using a SMTP email server. -- -- > example = do -- > r <- sendStringAsEmail -- > "pippo " -- user -- > "pluto" -- password -- > PlainSMTPAuth -- Auth method -- > "pippo@qwerty.org" -- from -- > "paperina@qwerty.org" -- to -- > "test" -- subject -- > "" -- cc -- > "" -- bcc -- > "mail.qwerty.org" -- stmp_server -- > 25 -- default SMTP port -- > "localhost" -- user domain -- > "This is a test" -- content -- > ["paperina@qwerty.org", -- rcpt_lines -- > "minni@qwery.it.it"] -- > -- > case r of -- > True -> putStrLn "Success" -- > False -> putStrLn "Fail" -- sendStringAsEMail :: String -- ^ user -> String -- ^ password -> SMTPAuthMethod -- ^ the Auth method to use -> String -- ^ from -> String -- ^ to -> String -- ^ subject -> String -- ^ cc -> String -- ^ bcc -> String -- ^ smtp server -> PortNumber -- ^ smtp port -> String -- ^ helo domain (also "localhost") -> String -- ^ content -> [String] -- ^ target recipients -> IO (Bool) -- ^ True if the EMAIL is sent sendStringAsEMail user password authMethod from to subject cc bcc smtpServer smtpPort heloDomain content rcptLines = do sfd <- smtpConnect smtpServer smtpPort finally (do c1 <- smtpEHLO sfd heloDomain if not c1 then return False else do c1 <- case authMethod of PlainSMTPAuth -> smtpAuthenticatePlain sfd user password LoginSMTPAuth -> smtpAuthenticateLogin sfd user password NoSMTPAuth -> return True c2 <- smtpMailFrom sfd from c3 <- smtpRcptTo sfd rcptLines c4 <- smtpData sfd if (c1 && c2 && c3 && c4) then do sendSMTField sfd "Subject" subject sendSMTField sfd "From" from sendSMTField sfd "To" to sendSMTField sfd "Cc" cc sendSMTField sfd "Bcc" bcc hPutStr sfd "\r\n" sendContent sfd content e1 <- smtpEOM sfd e2 <- smtpQuit sfd return (e1 && e2) else return False ) (do -- chiude le risorse smtpDisconnect sfd ) where sendSMTField sfd header content = do if content /= "" then do hPutStr sfd (header ++ ": " ++ content ++ "\r\n") return () else return () sendContent sfd content = do Control.Exception.catch (do hPutStr sfd "\r\n" mapM_ (\line -> hPutStr sfd (adaptLineToSMP line)) (lines content) return True ) (const (return False) :: Exception -> IO Bool) adaptLineToSMP line = let noReturns = filter (/= '\r') line validDot = if noReturns == "." then ".." else noReturns in validDot ++ "\r\n" -- NOTE: because a "\r\n.\r\n" line is a end_of_content SMTP -- "\r\n..\r\n" stays for "\r\n.\r\n" content smtpConnect :: String -> PortNumber -> IO Handle smtpConnect smtp_server port = do sfd <- connectTo smtp_server (PortNumber port) return sfd smtpDisconnect sfd = hClose sfd smtpResponse :: Handle -> Bool -> IO Bool smtpResponse sfd is_221_fatal = do (r,_) <- smtpResponseComplete sfd is_221_fatal return r smtpResponseComplete :: Handle -> Bool -> IO (Bool,String) smtpResponseComplete sfd is_221_fatal = do hFlush sfd -- NOTE: force the send of previous SMTP command line <- hGetLine sfd if debugSMTP then do putStrLn ("response: " ++ line) return () else do return () (r, realLine) <- if (length line < 3) then return (False, line) else if ((line !! 3) == '-') then smtpResponseComplete sfd is_221_fatal else if (any (\fatalCode -> isPrefixOf fatalCode line) fatal) then return (False, line) else if (any (\notifyCode -> isPrefixOf notifyCode line) notify) then return (True, line) else if (any (\okCode -> isPrefixOf okCode line) ok) then return (True, line) else return (False, line) return (r,realLine) where fatal = ["421", "432", "450", "451", "452", "454", "500", "501", "502", "503", "504", "530", "534", "535", "538", "550", "552", "553", "554" ] ++ (if is_221_fatal then ["221"] else []) notify = ["211", "214", "251", "252", "551"] ok = ["220", "221", "235", "250", "334", "354" ] smtpEHLO sfd helo_domain = do (_, heloLine) <- smtpResponseComplete sfd True -- read off the greeting hPutStr sfd ("EHLO " ++ "localhost" ++ "\r\n") r <- smtpResponse sfd True return r where heloDomain heloLine = takeWhile (/= ' ') (tail (dropWhile (/= ' ') heloLine)) smtpAuthenticatePlain sfd user password = do hPutStr sfd "AUTH PLAIN " hPutStr sfd ((Base64.encode ("\0"++user++"\0"++password))++"\r\n") r <- smtpResponse sfd True return r smtpAuthenticateLogin sfd user password = do hPutStr sfd "AUTH LOGIN\r\n" e1 <- smtpResponse sfd True r <- if e1 then do hPutStr sfd (Base64.encode user) e2 <- smtpResponse sfd True if e2 then do hPutStr sfd (Base64.encode password) e3 <- smtpResponse sfd True return e3 else return False else return False return r smtpMailFrom sfd from = do hPutStr sfd ("MAIL FROM: <" ++ from ++ ">\r\n") r <- smtpResponse sfd True return r smtpQuit sfd = do hPutStr sfd ("QUIT" ++ "\r\n") r <- smtpResponse sfd False return r smtpRset sfd = do hPutStr sfd ("RSET" ++ "\r\n") r <- smtpResponse sfd False return r smtpData sfd = do hPutStr sfd ("DATA" ++ "\r\n") r <- smtpResponse sfd False return r smtpRcptTo :: Handle -> [String] -> IO (Bool) smtpRcptTo sfd addressList = do result <- foldM (addAddress) (True) addressList return result where addAddress result address = do hPutStr sfd ("RCPT TO: <" ++ address ++">\r\n") e <- smtpResponse sfd True if e == False then return False else return result -- Send End of Message -- smtpEOM sfd = do hPutStr sfd ("\r\n.\r\n") smtpResponse sfd True