diff --git a/hslogger.cabal b/hslogger.cabal --- a/hslogger.cabal +++ b/hslogger.cabal @@ -1,5 +1,5 @@ Name: hslogger -Version: 1.0.12 +Version: 1.1.0 License: LGPL Maintainer: John Goerzen Author: John Goerzen @@ -37,7 +37,7 @@ Library Exposed-Modules: - System.Log, System.Log.Handler, + System.Log, System.Log.Handler, System.Log.Formatter, System.Log.Handler.Simple, System.Log.Handler.Syslog, System.Log.Handler.Growl, System.Log.Handler.Log4jXML, System.Log.Logger diff --git a/src/System/Log/Formatter.hs b/src/System/Log/Formatter.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Formatter.hs @@ -0,0 +1,109 @@ +{- | + +Definition of log formatter support + +A few basic, and extendable formatters are defined. + + +Please see "System.Log.Logger" for extensive documentation on the +logging system. + +-} + + +module System.Log.Formatter( LogFormatter + , nullFormatter + , simpleLogFormatter + , tfLogFormatter + , varFormatter + ) where +import Data.List +import Control.Applicative ((<$>)) +import Control.Concurrent (myThreadId) +#ifndef mingw32_HOST_OS +import System.Posix.Process (getProcessID) +#endif + +import System.Locale (defaultTimeLocale) +import Data.Time (getZonedTime,getCurrentTime,formatTime) + +import System.Log + +-- | A LogFormatter is used to format log messages. Note that it is paramterized on the +-- 'Handler' to allow the formatter to use information specific to the handler +-- (an example of can be seen in the formatter used in 'System.Log.Handler.Syslog') +type LogFormatter a = a -- ^ The LogHandler that the passed message came from + -> LogRecord -- ^ The log message and priority + -> String -- ^ The logger name + -> IO String -- ^ The formatted log message + +-- | Returns the passed message as is, ie. no formatting is done. +nullFormatter :: LogFormatter a +nullFormatter _ (_,msg) _ = return msg + +-- | Takes a format string, and returns a formatter that may be used to +-- format log messages. The format string may contain variables prefixed with +-- a $-sign which 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 +-- +-- * @$tid@ - The thread ID +-- +-- * @$pid@ - Process ID (Not available on windows) +-- +-- * @$time@ - The current time +-- +-- * @$utcTime@ - The current time in UTC Time +simpleLogFormatter :: String -> LogFormatter a +simpleLogFormatter format h (prio, msg) loggername = + tfLogFormatter "%F %X %Z" format h (prio,msg) loggername + +-- | Like 'simpleLogFormatter' but allow the time format to be specified in the first +-- parameter (this is passed to 'Date.Time.Format.formatTime') +tfLogFormatter :: String -> String -> LogFormatter a +tfLogFormatter timeFormat format = do + varFormatter [("time", formatTime defaultTimeLocale timeFormat <$> getZonedTime) + ,("utcTime", formatTime defaultTimeLocale timeFormat <$> getCurrentTime) + ] + format + +-- | An extensible formatter that allows new substition /variables/ to be defined. +-- Each variable has an associated IO action that is used to produce the +-- string to substitute for the variable name. The predefined variables are the same +-- as for 'simpleLogFormatter' /excluding/ @$time@ and @$utcTime@. +varFormatter :: [(String, IO String)] -> String -> LogFormatter a +varFormatter vars format h (prio,msg) loggername = do + outmsg <- replaceVarM (vars++[("msg", return msg) + ,("prio", return $ show prio) + ,("loggername", return loggername) + ,("tid", show <$> myThreadId) +#ifndef mingw32_HOST_OS + ,("pid", show <$> getProcessID) +#endif + ] + ) + format + return outmsg + + +-- | Replace some '$' variables in a string with supplied values +replaceVarM :: [(String, IO String)] -- ^ A list of (variableName, action to get the replacement string) pairs + -> String -- ^ String to perform substitution on + -> IO String -- ^ Resulting string +replaceVarM _ [] = return [] +replaceVarM keyVals (s:ss) | s=='$' = do (f,rest) <- replaceStart keyVals ss + repRest <- replaceVarM keyVals rest + return $ f ++ repRest + | otherwise = replaceVarM keyVals ss >>= return . (s:) + where + replaceStart [] str = return ("$",str) + replaceStart ((k,v):kvs) str | k `isPrefixOf` str = do vs <- v + return (vs, drop (length k) str) + | otherwise = replaceStart kvs str + + diff --git a/src/System/Log/Handler.hs b/src/System/Log/Handler.hs --- a/src/System/Log/Handler.hs +++ b/src/System/Log/Handler.hs @@ -40,6 +40,7 @@ LogHandler(..) ) where import System.Log +import System.Log.Formatter import System.IO {- | All log handlers should adhere to this. -} @@ -53,13 +54,18 @@ setLevel :: a -> Priority -> a -- | Gets the current level. getLevel :: a -> Priority + -- | Set a log formatter to customize the log format for this Handler + setFormatter :: a -> LogFormatter a -> a + getFormatter :: a -> LogFormatter a + getFormatter h = nullFormatter -- | Logs an event if it meets the requirements -- given by the most recent call to 'setLevel'. handle :: a -> LogRecord -> String-> IO () handle h (pri, msg) logname = if pri >= (getLevel h) - then emit h (pri, msg) logname + then do formattedMsg <- (getFormatter h) h (pri,msg) logname + emit h (pri, formattedMsg) logname else return () -- | Forces an event to be logged regardless of -- the configured level. @@ -67,6 +73,7 @@ -- | Closes the logging system, causing it to close -- any open files, etc. close :: a -> IO () + diff --git a/src/System/Log/Handler/Growl.hs b/src/System/Log/Handler/Growl.hs --- a/src/System/Log/Handler/Growl.hs +++ b/src/System/Log/Handler/Growl.hs @@ -39,8 +39,10 @@ import Network.BSD import System.Log import System.Log.Handler +import System.Log.Formatter data GrowlHandler = GrowlHandler { priority :: Priority, + formatter :: LogFormatter GrowlHandler, appName :: String, skt :: Socket, targets :: [HostAddress] } @@ -50,6 +52,9 @@ setLevel gh p = gh { priority = p } getLevel = priority + + setFormatter gh f = gh { formatter = f } + getFormatter = formatter emit gh lr _ = let pkt = buildNotification gh nmGeneralMsg lr in mapM_ (sendNote (skt gh) pkt) (targets gh) @@ -81,7 +86,7 @@ -> IO GrowlHandler growlHandler nm pri = do { s <- socket AF_INET Datagram 0 - ; return GrowlHandler { priority = pri, appName = nm, + ; return GrowlHandler { priority = pri, appName = nm, formatter=nullFormatter, skt = s, targets = [] } } diff --git a/src/System/Log/Handler/Log4jXML.hs b/src/System/Log/Handler/Log4jXML.hs --- a/src/System/Log/Handler/Log4jXML.hs +++ b/src/System/Log/Handler/Log4jXML.hs @@ -130,34 +130,30 @@ import System.Locale (defaultTimeLocale) import Data.Time import System.Log -import System.Log.Handler.Simple (GenericHandler (..)) +import System.Log.Handler +import System.Log.Handler.Simple (streamHandler, GenericHandler(..)) -- Handler that logs to a handle rendering message priorities according -- to the supplied function. log4jHandler :: (Priority -> String) -> Handle -> Priority -> IO (GenericHandler Handle) log4jHandler showPrio h pri = do - lock <- newMVar () - let mywritefunc hdl (prio, msg) loggername = withMVar lock (\_ -> do - time <- getCurrentTime - thread <- myThreadId - hPutStrLn hdl (show $ createMessage loggername time prio thread msg) - hFlush hdl - ) - return (GenericHandler { priority = pri, - privData = h, - writeFunc = mywritefunc, - closeFunc = \x -> return () }) - where - -- Creates an XML element representing a log4j event/message. - createMessage :: String -> UTCTime -> Priority -> ThreadId -> String -> XML - createMessage logger time prio thread msg = Elem "log4j:event" - [ ("logger" , logger ) - , ("timestamp", millis time ) - , ("level" , showPrio prio) - , ("thread" , show thread ) - ] - (Just $ Elem "log4j:message" [] (Just $ CDATA msg)) + hndlr <- streamHandler h pri + return $ setFormatter hndlr xmlFormatter + + where + -- A Log Formatter that creates an XML element representing a log4j event/message. + xmlFormatter :: a -> (Priority,String) -> String -> IO String + xmlFormatter _ (prio,msg) logger = do + time <- getCurrentTime + thread <- myThreadId + return . show $ Elem "log4j:event" + [ ("logger" , logger ) + , ("timestamp", millis time ) + , ("level" , showPrio prio) + , ("thread" , show thread ) + ] + (Just $ Elem "log4j:message" [] (Just $ CDATA msg)) where -- This is an ugly hack to get a unix epoch with milliseconds. -- The use of "take 3" causes the milliseconds to always be diff --git a/src/System/Log/Handler/Simple.hs b/src/System/Log/Handler/Simple.hs --- a/src/System/Log/Handler/Simple.hs +++ b/src/System/Log/Handler/Simple.hs @@ -41,20 +41,24 @@ import System.Log import System.Log.Handler +import System.Log.Formatter import System.IO import Control.Concurrent.MVar {- | A helper data type. -} data GenericHandler a = GenericHandler {priority :: Priority, + formatter :: LogFormatter (GenericHandler a), privData :: a, - writeFunc :: a -> LogRecord -> String -> IO (), + writeFunc :: a -> 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 + setFormatter sh f = sh{formatter = f} + getFormatter sh = formatter sh + emit sh (_,msg) _ = (writeFunc sh) (privData sh) msg close sh = (closeFunc sh) (privData sh) @@ -66,11 +70,12 @@ streamHandler :: Handle -> Priority -> IO (GenericHandler Handle) streamHandler h pri = do lock <- newMVar () - let mywritefunc hdl (_, msg) _ = + let mywritefunc hdl msg = withMVar lock (\_ -> do writeToHandle hdl msg hFlush hdl ) return (GenericHandler {priority = pri, + formatter = nullFormatter, privData = h, writeFunc = mywritefunc, closeFunc = \x -> return ()}) @@ -100,16 +105,6 @@ {- | Like 'streamHandler', but note the priority and logger name along with each message. -} verboseStreamHandler :: Handle -> Priority -> IO (GenericHandler Handle) -verboseStreamHandler h pri = - do lock <- newMVar () - let mywritefunc hdl (prio, msg) loggername = - withMVar lock (\_ -> do hPutStrLn hdl ("[" ++ loggername - ++ "/" ++ - show prio ++ - "] " ++ msg) - hFlush hdl - ) - return (GenericHandler {priority = pri, - privData = h, - writeFunc = mywritefunc, - closeFunc = \x -> return ()}) +verboseStreamHandler h pri = let fmt = simpleLogFormatter "[$loggername/$prio] $msg" + in do hndlr <- streamHandler h pri + return $ setFormatter hndlr fmt diff --git a/src/System/Log/Handler/Syslog.hs b/src/System/Log/Handler/Syslog.hs --- a/src/System/Log/Handler/Syslog.hs +++ b/src/System/Log/Handler/Syslog.hs @@ -60,6 +60,7 @@ ) where import System.Log +import System.Log.Formatter import System.Log.Handler import Data.Bits import Network.Socket @@ -147,7 +148,9 @@ identity :: String, logsocket :: Socket, address :: SockAddr, - priority :: Priority} + priority :: Priority, + formatter :: LogFormatter SyslogHandler + } {- | Initialize the Syslog system using the local system's default interface, \/dev\/log. Will return a new 'System.Log.Handler.LogHandler'. @@ -166,6 +169,8 @@ #ifdef mingw32_HOST_OS openlog = openlog_remote AF_INET "localhost" 514 +#elif darwin_HOST_OS +openlog = openlog_local "/var/run/syslog" #else openlog = openlog_local "/dev/log" #endif @@ -219,39 +224,45 @@ identity = ident, logsocket = sock, address = addr, - priority = pri}) + priority = pri, + formatter = syslogFormatter + }) -instance LogHandler SyslogHandler where - setLevel sh p = sh{priority = p} - getLevel sh = priority sh - emit sh (p, msg) loggername = - let code = makeCode (facility sh) p - getpid :: IO String - getpid = if (elem PID (options sh)) - then do +syslogFormatter :: LogFormatter SyslogHandler +syslogFormatter sh (p,msg) logname = + let code = makeCode (facility sh) p + getpid :: IO String + getpid = #ifndef mingw32_HOST_OS - pid <- getProcessID + getProcessID >>= return . show #else - let pid = "windows" + return "windows" #endif - return ("[" ++ show pid ++ "]") - else return "" - + vars = [("code", return $ show code) + ,("identity", return $ identity sh) + ,("pid", getpid)] + withPid = if (elem PID (options sh)) then "[$pid]" else "" + format = "<$code>$identity"++withPid++": [$loggername/$prio] $msg" + in varFormatter vars format sh (p,msg) logname + + +instance LogHandler SyslogHandler where + setLevel sh p = sh{priority = p} + getLevel sh = priority sh + setFormatter sh f = sh{formatter = f} + getFormatter sh = formatter sh + emit sh (_, msg) _ = + let sendstr :: String -> IO String sendstr [] = return [] sendstr omsg = do sent <- sendTo (logsocket sh) omsg (address sh) sendstr (genericDrop sent omsg) - in - do - pidstr <- getpid - let outstr = "<" ++ (show code) ++ ">" - ++ (identity sh) ++ pidstr ++ ": " - ++ "[" ++ loggername ++ "/" ++ (show p) ++ "] " ++ msg - if (elem PERROR (options sh)) - then hPutStrLn stderr outstr + in do + if (elem PERROR (options sh)) + then hPutStrLn stderr msg else return () - sendstr (outstr ++ "\0") - return () + sendstr (msg ++ "\0") + return () close sh = sClose (logsocket sh) diff --git a/src/System/Log/Logger.hs b/src/System/Log/Logger.hs --- a/src/System/Log/Logger.hs +++ b/src/System/Log/Logger.hs @@ -96,10 +96,18 @@ there will be called for every message. You can use 'getRootLogger' to get it or 'rootLoggerName' to work with it by name. +The formatting of log messages may be customized by setting a 'LogFormatter' +on the desired 'LogHandler'. There are a number of simple formatters defined +in "System.Log.Formatter", which may be used directly, or extend to create +your own formatter. + Here's an example to illustrate some of these concepts: > import System.Log.Logger > import System.Log.Handler.Syslog +> import System.Log.Handler.Simple +> import System.Log.Handler (setFormatter) +> import System.Log.Formatter > > -- By default, all messages of level WARNING and above are sent to stderr. > -- Everything else is ignored. @@ -134,7 +142,21 @@ > > -- This message goes nowhere. > debugM "MyApp.WorkingComponent" "Hello" - +> +> -- Now we decide we'd also like to log everything from BuggyComponent at DEBUG +> -- or higher to a file for later diagnostics. We'd also like to customize the +> -- format of the log message, so we use a 'simpleLogFormatter' +> +> h <- fileHandler "debug.log" DEBUG >>= \lh -> return $ +> setFormatter lh (simpleLogFormatter "[$time : $loggername : $prio] $msg") +> updateGlobalLogger "MyApp.BuggyComponent" (addHandler h) +> +> -- This message will go to syslog and stderr, +> -- and to the file "debug.log" with a format like : +> -- [2010-05-23 16:47:28 : MyApp.BuggyComponent : DEBUG] Some useful diagnostics... +> debugM "MyApp.BuggyComponent" "Some useful diagnostics..." +> +> -} module System.Log.Logger( @@ -184,6 +206,7 @@ ) where import System.Log import System.Log.Handler(LogHandler) +import System.Log.Formatter(LogFormatter) import qualified System.Log.Handler(handle) import System.Log.Handler.Simple import System.IO