Monad logger

main.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Applicative
import Control.Monad.Except
import Control.Monad.IO.Class ()
import Control.Monad.Reader
import Control.Monad.Logger
import qualified Data.ByteString.Char8 as S8
import Data.Char (toUpper)
import Data.List
import Data.Monoid
import qualified Data.Text as T
import Language.Haskell.TH.Syntax (Loc(..))
import System.Log.FastLogger
import System.Log.MonadLogger.Syslog
import System.IO

-- * Our monad
--
-- $ This monad allows actions in it to log ('MonadLogger'), read configuration
-- ('MonadReader Config'), throw exceptions ('MonadError HandlerError'), and do
-- I/O ('MonadIO').

-- | Configuration.
data Config = Config

-- | Errors which can be raised.
data HandlerError = ERR
    deriving (Show)

-- | Monad for handler actions.
newtype Handler a =
    Handler {
        unHandler :: ExceptT HandlerError (LoggingT (ReaderT Config IO)) a
    }
  deriving (Applicative, Functor, Monad, MonadIO, MonadLogger,
  MonadReader Config, MonadError HandlerError)

-- | Run an action in the 'Handler' monad.
runHandler :: Config -> Handler a -> IO (Either HandlerError a)
runHandler c a = flip runReaderT c $ runLogging $ runExceptT (unHandler a)

  where
    runLogging  = runStderrLoggingT -- Or, e.g., runSyslogLoggingT

-- * Actions can log

-- | An exceptional action.
attempt :: Handler ()
attempt = do
    $(logDebugS) "HERP" "Let's try"
    throwError ERR
    $(logDebug) "But no"

-- | An action which catches and logs an exception. 
createHandler :: Handler ()
createHandler = do
    $(logDebug) "Starting"
    catchError attempt (\err -> $(logError) $ T.pack $ show err)
    $(logDebug) "Stopping"
    return ()

main :: IO ()
main = do
    putStrLn "Hello!"
    res <- runHandler Config createHandler
    case res of
        Left e -> print "Boo :-("
        Right r -> print "YAY"
    return ()

-- * Custom formatting of log messages

-- | Run a LoggingT with a custom format.
runCustomLoggingT = (`runLoggingT` output stderr)

-- | Format and output a log message.
output :: Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
output h loc src level msg = S8.hPutStrLn h ls
  where
    ls = fromLogStr $ customFmt loc src level msg

-- | Format a log message.
customFmt :: Loc -> LogSource -> LogLevel -> LogStr -> LogStr
customFmt loc src lvl msg = mconcat ["[", fmtLvl , "]",
    if T.null src then mempty else "#" `mappend` toLogStr src, " ",
    fmtLoc, " ", msg]
  where
    fmtLvl = case lvl of
        LevelOther t -> toLogStr t
        _            -> toLogStr $ S8.pack $ map toUpper $ drop 5 $ show lvl
    fmtLoc =
        let (line,col) = loc_start loc
            file = loc_filename loc