Client.hs

{-# LANGUAGE DeriveDataTypeable #-}

module Network.SMTP.Client (
        sendSMTP,
        sendSMTP_,
        SMTPException(..)
    ) where

import Network.SMTP.ClientSession
import Control.Exception
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 message body may contain either \"\n\" or \"\\r\\n\" for an end-of-line
-- marker and in all cases it will be sent correctly to the server.
sendSMTP :: String      -- ^ Domain name for EHLO command
         -> SockAddr    -- ^ Network address of SMTP server
         -> [Message]   -- ^ List of messages to send
         -> IO ()
sendSMTP = sendSMTP_ (\_ -> return ()) Nothing

-- | Like sendSMTP_ but takes an additional function for logging all input and
-- output for diagnostic purposes.  Also an optional IORef for storing the
-- number of emails sent so far.  The emails are sent strictly in order, so this
-- count can be used when an exception is caught to mark sent emails.
sendSMTP_ :: (String -> IO ())  -- ^ Diagnostic log function
          -> Maybe (IORef Int)  -- ^ Optional IORef for storing the number of
                                -- emails successfully sent so far.
          -> String             -- ^ Domain name for EHLO command
          -> SockAddr           -- ^ Network address of SMTP server
          -> [Message]          -- ^ List of messages to send
          -> IO ()
sendSMTP_ log mSentSoFar 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 mSentSoFar of
                Just sentSoFar -> writeIORef sentSoFar (smtpSent state)
                Nothing -> return ()
        
            forM_ (reverse $ 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
                    putStrLn $ "<- "++reply
                    let state' = smtpReceive state reply $ state {smtpOutQueue = []}
                    process h state'


data SMTPException = SMTPException String
    deriving (Eq, Show, Typeable)

instance Exception SMTPException where