Client.hs

{-# LANGUAGE DeriveDataTypeable #-}

-- | An SMTP client in the IO Monad.

module Network.SMTP.Client (
        sendSMTP,
        sendSMTP',
        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.
--
-- 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, and so it gives an indication
-- of how many messages were dispatched.
--
-- The message body may use either \"\\n\" or \"\\r\\n\" for 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
        sock <- socket AF_INET Stream defaultProtocol
        connect sock sockAddr
        handle <- socketToHandle sock ReadWriteMode
        (do
                let smtp = smtpClientSession domain messages
                process handle smtp
            ) `finally` hClose handle
    where
        
        process :: Handle -> SMTPState -> IO ()
        process 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 = []}
                    process 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