module System.ExceptionMailer
( exceptionMailerTag
, setupExceptionMailer, setupExceptionMailer'
, mkAddress
, mailError
, Address
) where
import Prelude hiding (catch)
import System.Environment (getProgName)
import Data.String (fromString)
import Data.Maybe
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
-> Maybe String
-> String
-> IO ()
setupExceptionMailer from to subj pre = setUncaughtExceptionHandler $ emailException from to subj pre
setupExceptionMailer' :: String
-> String
-> Maybe String
-> String
-> IO ()
setupExceptionMailer' from to subj pre = setupExceptionMailer (Address Nothing $ fromString from) (Address Nothing $ fromString to) subj pre
mkAddress :: String -> String -> Address
mkAddress name email = Address (Just $ fromString name) $ fromString email
mailError :: Address -> Address -> Maybe String -> String -> IO ()
mailError from to subj msg = do
prog <- getProgName
m <- simpleMail' from to (fromString $ fromMaybe "Exception Mailer" subj)
(LT.concat ["Program: ", fromString $ prog ++ "\n"
,"Exception:\n", fromString msg])
renderSendMail m
emailException :: Show a => Address -> Address -> Maybe String -> String -> a -> IO ()
emailException from to subj pre e = do
errorM exceptionMailerTag $ "Uncaught exception. emailing ("++
show (addressEmail to)++") : "++show e
catch (mailError from to subj (pre ++ 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
]]
}