module System.ExceptionMailer
( exceptionMailerTag
, setupExceptionMailer, setupExceptionMailer'
, mkAddress
, mailError
, Address
) where
import Prelude hiding (catch)
import System.Environment (getProgName)
import Data.String (fromString)
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import Control.Exception (SomeException, catch)
import GHC.Conc (setUncaughtExceptionHandler)
import Network.Mail.Mime
import System.Log.Logger (errorM)
exceptionMailerTag :: String
exceptionMailerTag = "ExceptionMailer"
setupExceptionMailer :: Address
-> Address
-> IO ()
setupExceptionMailer from to = setUncaughtExceptionHandler $ emailException from to
setupExceptionMailer' :: String
-> String
-> IO ()
setupExceptionMailer' from to = setupExceptionMailer (Address Nothing $ fromString from) (Address Nothing $ fromString to)
mkAddress :: String -> String -> Address
mkAddress name email = Address (Just $ fromString name) $ fromString email
mailError :: Address -> Address -> String -> IO ()
mailError from to msg = do
prog <- getProgName
m <- simpleMail' from to "Exception Mailer"
(LT.concat ["Program: ", fromString $ prog ++ "\n"
,"Exception:\n", fromString msg])
renderSendMail m
emailException :: Show a => Address -> Address -> a -> IO ()
emailException from to e = do
errorM exceptionMailerTag $ "Uncaught exception. emailing ("++
show (addressEmail to)++") : "++show e
catch (mailError from to (show e))
(\e2 -> errorM exceptionMailerTag $ "Unable to send email : "++show (e2 :: SomeException))
return ()
simpleMail' from to subject plainBody =
return Mail {
mailFrom = from
, mailTo = [to]
, mailCc = []
, mailBcc = []
, mailHeaders = [ ("Subject", subject) ]
, mailParts =
[[ Part "text/plain; charset=utf-8" QuotedPrintableText Nothing []
$ LT.encodeUtf8 plainBody
]]
}