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.

module Network.SMTP.Client (
        sendSMTP,
        sendSMTP',
        processSMTP,
        SMTPException(..),
        SmtpReply(..),
        SmtpCode(..),
        SuccessCode(..),
        Category(..),
        Message(..),
        Field(..),
        NameAddr(..)
    ) where

import Network.SMTP.ClientSession
import Control.Exception
import Text.ParserCombinators.Parsec.Rfc2821 (
        SmtpReply(..),
        SmtpCode(..),
        SuccessCode(..),
        Category(..)
    )
import Text.ParserCombinators.Parsec.Rfc2822 (
        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