diff --git a/hslogger.cabal b/hslogger.cabal --- a/hslogger.cabal +++ b/hslogger.cabal @@ -1,5 +1,5 @@ Name: hslogger -Version: 1.0.11 +Version: 1.0.12 License: LGPL Maintainer: John Goerzen Author: John Goerzen @@ -37,7 +37,7 @@ Library Exposed-Modules: - System.Log, System.Log.Handler, System.Log.Formatter, + System.Log, System.Log.Handler, 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 deleted file mode 100644 --- a/src/System/Log/Formatter.hs +++ /dev/null @@ -1,109 +0,0 @@ -{- | - -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,7 +40,6 @@ LogHandler(..) ) where import System.Log -import System.Log.Formatter import System.IO {- | All log handlers should adhere to this. -} @@ -54,18 +53,13 @@ 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 do formattedMsg <- (getFormatter h) h (pri,msg) logname - emit h (pri, formattedMsg) logname + then emit h (pri, msg) logname else return () -- | Forces an event to be logged regardless of -- the configured level. @@ -73,7 +67,6 @@ -- | 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,10 +39,8 @@ 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] } @@ -52,9 +50,6 @@ 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) @@ -86,7 +81,7 @@ -> IO GrowlHandler growlHandler nm pri = do { s <- socket AF_INET Datagram 0 - ; return GrowlHandler { priority = pri, appName = nm, formatter=nullFormatter, + ; return GrowlHandler { priority = pri, appName = nm, 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,30 +130,34 @@ import System.Locale (defaultTimeLocale) import Data.Time import System.Log -import System.Log.Handler -import System.Log.Handler.Simple (streamHandler, GenericHandler(..)) +import System.Log.Handler.Simple (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 - 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)) + 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)) 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,24 +41,20 @@ 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 -> String -> IO (), + writeFunc :: a -> LogRecord -> String -> IO (), closeFunc :: a -> IO () } instance LogHandler (GenericHandler a) where setLevel sh p = sh{priority = p} getLevel sh = priority sh - setFormatter sh f = sh{formatter = f} - getFormatter sh = formatter sh - emit sh (_,msg) _ = (writeFunc sh) (privData sh) msg + emit sh lr loggername = (writeFunc sh) (privData sh) lr loggername close sh = (closeFunc sh) (privData sh) @@ -70,12 +66,11 @@ 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 ()}) @@ -105,6 +100,16 @@ {- | Like 'streamHandler', but note the priority and logger name along with each message. -} verboseStreamHandler :: Handle -> Priority -> IO (GenericHandler Handle) -verboseStreamHandler h pri = let fmt = simpleLogFormatter "[$loggername/$prio] $msg" - in do hndlr <- streamHandler h pri - return $ setFormatter hndlr fmt +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 ()}) 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,7 +60,6 @@ ) where import System.Log -import System.Log.Formatter import System.Log.Handler import Data.Bits import Network.Socket @@ -148,9 +147,7 @@ identity :: String, logsocket :: Socket, address :: SockAddr, - priority :: Priority, - formatter :: LogFormatter SyslogHandler - } + priority :: Priority} {- | Initialize the Syslog system using the local system's default interface, \/dev\/log. Will return a new 'System.Log.Handler.LogHandler'. @@ -169,8 +166,6 @@ #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 @@ -224,45 +219,39 @@ identity = ident, logsocket = sock, address = addr, - priority = pri, - formatter = syslogFormatter - }) - -syslogFormatter :: LogFormatter SyslogHandler -syslogFormatter sh (p,msg) logname = - let code = makeCode (facility sh) p - getpid :: IO String - getpid = -#ifndef mingw32_HOST_OS - getProcessID >>= return . show -#else - return "windows" -#endif - 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 - + priority = pri}) 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 + emit sh (p, msg) loggername = + let code = makeCode (facility sh) p + getpid :: IO String + getpid = if (elem PID (options sh)) + then do +#ifndef mingw32_HOST_OS + pid <- getProcessID +#else + let pid = "windows" +#endif + return ("[" ++ show pid ++ "]") + else return "" + sendstr :: String -> IO String sendstr [] = return [] sendstr omsg = do sent <- sendTo (logsocket sh) omsg (address sh) sendstr (genericDrop sent omsg) - in do - if (elem PERROR (options sh)) - then hPutStrLn stderr msg + in + do + pidstr <- getpid + let outstr = "<" ++ (show code) ++ ">" + ++ (identity sh) ++ pidstr ++ ": " + ++ "[" ++ loggername ++ "/" ++ (show p) ++ "] " ++ msg + if (elem PERROR (options sh)) + then hPutStrLn stderr outstr else return () - sendstr (msg ++ "\0") - return () + sendstr (outstr ++ "\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,18 +96,10 @@ 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. @@ -142,21 +134,7 @@ > > -- 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( @@ -206,7 +184,6 @@ ) 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