FmtLogHandler.hs

module FmtLogHandler
    (fmtLogHandler
    ,logFormatter
    ) where

import System.Log.Logger

import System.Log
import System.Log.Handler
import System.IO
import Control.Concurrent.MVar
import Data.List
import Control.Concurrent

import System.Locale (defaultTimeLocale)
import Data.Time.LocalTime (getZonedTime)
import Data.Time.Format (formatTime)

-- Copied directly from Sytem.Log.Handler.Simple (since it isn't exported)
data GenericHandler a = GenericHandler {priority :: Priority,
                                        privData :: a,
                                        writeFunc :: a -> LogRecord -> String -> IO (),
                                        closeFunc :: a -> IO () }

instance LogHandler (GenericHandler a) where
    setLevel sh p = sh{priority = p}
    getLevel sh = priority sh
    emit sh lr loggername = (writeFunc sh) (privData sh) lr loggername
    close sh = (closeFunc sh) (privData sh)

-- | Replace some '$' variables in a string with supplied values
replaceVar :: [(String, String)] -- ^ A list of (variableName, value)
           -> String   -- ^ String to perform substitution on
           -> String   -- ^ Resulting string
replaceVar _ [] = []
replaceVar keyVals (s:ss) | s=='$' = let (f,rest) = replaceStart keyVals ss
                                     in f ++ replaceVar keyVals rest
                          | otherwise = s : replaceVar keyVals ss
    where
      replaceStart [] str = ("$",str)
      replaceStart ((k,v):kvs) str | k `isPrefixOf` str = (v, drop (length k) str)
                                   | otherwise = replaceStart kvs str

type LogFormatter = LogRecord -> String -> IO String
-- | Takes a format string, and returns a function that may be used to
-- format log messages.  The format string may contain '$' variables that
-- will be replaced at runtime with corresponding values.  The currently
-- supported variables are:
--    $msg  - The actual log message
--    $loggername - The name of the logger
--    $prio - The priority level of the message
--    $time - The current time 
--    $tid  - The thread ID
logFormatter :: String -> LogFormatter
logFormatter format (prio, msg) loggername = do
    tid <- myThreadId
    cTime <- getZonedTime
    let time = formatTime defaultTimeLocale "%F %X" cTime
    let outmsg = replaceVar [("msg", msg), ("tid", show tid), ("time", time)
                            , ("prio", show prio), ("loggername", loggername)] 
                     format
    return outmsg

-- | Like 'streamHandler', but also takes a 'LogFormatter' to specify how to format
-- the log message
fmtLogHandler :: Handle -> Priority -> LogFormatter -> IO (GenericHandler Handle)
fmtLogHandler h pri formatter =
    do lock <- newMVar ()
       let mywritefunc hdl logRec loggername = 
               withMVar lock (\_ -> 
                  do
                     outmsg <- formatter logRec loggername
                     hPutStrLn hdl outmsg
                     hFlush hdl
                )
       return (GenericHandler {priority = pri,
                               privData = h,
                               writeFunc = mywritefunc,
                               closeFunc = \x -> return ()})



main = do
  lh <- fmtLogHandler stderr DEBUG (logFormatter "[$time : $tid : $prio : $loggername] $msg")
  updateGlobalLogger rootLoggerName (setHandlers [lh])
  updateGlobalLogger rootLoggerName (System.Log.Logger.setLevel ERROR)
  updateGlobalLogger "MyComp" (System.Log.Logger.setLevel DEBUG)

  infoM "" "Test log"

  warningM "" "Test log2"  

  warningM "MyComp" "Test log2"