module Happstack.Util.Mail
( NameAddr(..)
, SimpleMessage(..)
, sendRawMessages
, sendSimpleMessages
) where
import Data.IORef (newIORef, readIORef)
import Network.Socket
(SockAddr(..)
, inet_addr
)
import Network.SMTP.Client
import System.Log.Logger (Priority(..), logM)
import System.Time
( CalendarTime(..)
, getClockTime
, toCalendarTime
)
data SimpleMessage
= SimpleMessage
{ from :: [NameAddr]
, to :: [NameAddr]
, subject :: String
, body :: String
}
deriving (Show)
toMessage :: CalendarTime -> SimpleMessage -> Message
toMessage ct sm =
Message
[From (from sm), To (to sm), Subject (subject sm), Date ct]
(body sm)
log' :: Priority -> String -> IO ()
log' = logM "Happstack.Util.Mail"
sendSimpleMessages :: String
-> String
-> [SimpleMessage]
-> IO ()
sendSimpleMessages smartHostIp heloDomain simpleMessages = do
nowCT <- toCalendarTime =<< getClockTime
hostAddr <- inet_addr smartHostIp
let smtpSockAddr = SockAddrInet 25 hostAddr
sendRawMessages smtpSockAddr heloDomain (map (toMessage nowCT) simpleMessages)
sendRawMessages :: SockAddr
-> String
-> [Message]
-> IO ()
sendRawMessages smtpSockAddr heloDomain messages = do
log' NOTICE $ "connecting to SMTP smarthost: " ++ show smtpSockAddr
sentRef <- newIORef []
sendSMTP' (log' INFO) (Just sentRef) heloDomain smtpSockAddr messages
statuses <- readIORef sentRef
log' NOTICE $ "attempting to send messages:\n" ++ show messages
case head statuses of
Nothing ->
return ()
Just status ->
log' ERROR $ "message failed: " ++ show status