Client.hs

{-# 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.IORef
-- > 
-- > myDomain = "example.com"
-- > smtpHost = "mail.example.com"    -- <-- Your SMTP server here
-- > 
-- > main = do
-- >     now <- getClockTime
-- >     nowCT <- toCalendarTime now
-- >     let message = Message [
-- >                 From [NameAddr (Just "Mr. Nobody") "nobody@example.com"],
-- >                 To   [NameAddr (Just "Mr. Somebody") "somebody@example.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) (Just "25")
-- >     putStrLn $ "connecting to "++show (map addrAddress addrs)
-- >     sentRef <- newIORef []
-- >     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.
-- >     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 Control.Monad
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
import Data.List (foldl1')


-- | 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
         -> [AddrInfo]  -- ^ Network addresses of SMTP server (will try each in turn)
         -> [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
          -> [AddrInfo]         -- ^ Network addresses of SMTP server (will try each in turn)
          -> [Message]          -- ^ List of messages to send
          -> IO ()
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

-- | 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