log_warning )
where
-import System.IO ( hPutStr, stderr, stdout )
-import System.Log ( LogRecord )
-import System.Log.Formatter ( LogFormatter )
+import System.Log.Formatter ( simpleLogFormatter )
+import System.Log.Handler ( setFormatter )
+import System.Log.Handler.Simple ( fileHandler )
+import System.Log.Handler.Syslog (
+ Facility ( USER ),
+ openlog )
import System.Log.Logger (
- Priority ( DEBUG, ERROR, INFO, WARNING ),
+ Priority ( DEBUG, INFO ),
debugM,
errorM,
infoM,
setLevel,
updateGlobalLogger,
warningM )
-import System.Log.Handler.Simple (
- GenericHandler(..),
- streamHandler )
-import Terminal ( hPutBlueStr, hPutRedStr )
log_debug :: String -> IO ()
log_debug = debugM rootLoggerName
log_warning :: String -> IO ()
log_warning = warningM rootLoggerName
--- | Debug messages output to the console don't get a prefix, since
--- they're used to dump the network chatter.
-console_formatter :: LogRecord -> IO String
-console_formatter (DEBUG, msg) = return $ msg ++ "\n"
-console_formatter (prio, msg) = return $ (show prio) ++ ": " ++ msg ++ "\n"
-
-warn_formatter :: LogFormatter a
-warn_formatter _ x@(WARNING, _) _ = console_formatter x
-warn_formatter _ x@(ERROR, _) _ = console_formatter x
-warn_formatter _ _ _ = return ""
-
-info_formatter :: LogFormatter a
-info_formatter _ x@(INFO, _) _ = console_formatter x
-info_formatter _ _ _ = return ""
-
-debug_formatter :: LogFormatter a
-debug_formatter _ x@(DEBUG, _) _ = console_formatter x
-debug_formatter _ _ _ = return ""
-
-
-init_logging :: IO ()
-init_logging = do
- -- Set the root logger to DEBUG level so that it will *attempt* to
- -- process every message.
- updateGlobalLogger rootLoggerName (setLevel DEBUG)
-
- stdout_handler <- streamHandler stdout DEBUG
- stderr_handler <- streamHandler stderr WARNING
-
- let debug_handler = stdout_handler { formatter = debug_formatter,
- writeFunc = hPutStr }
-
- let info_handler = stdout_handler { formatter = info_formatter,
- priority = INFO,
- writeFunc = hPutBlueStr }
-
- -- This also catches ERRORs.
- let warn_handler = stderr_handler { formatter = warn_formatter,
- priority = WARNING,
- writeFunc = hPutRedStr }
-
- -- Set debug, info, and warn handlers for the root log.
- updateGlobalLogger
- rootLoggerName
- (setHandlers [debug_handler, info_handler, warn_handler])
+-- | Why don't we take a Configuration as an argument? Because it
+-- would create circular imports!
+init_logging :: FilePath -> Priority -> Bool -> IO ()
+init_logging log_file log_level syslog
+ | syslog == True = do
+ handler' <- openlog rootLoggerName [] USER level
+ -- Syslog should output the date by itself.
+ let slf = simpleLogFormatter "htsn[$pid] $prio: $msg"
+ let handler = setFormatter handler' slf
+ updateGlobalLogger rootLoggerName (setLevel level . setHandlers [handler])
+ | otherwise = do
+ handler' <- fileHandler log_file level
+ let slf = simpleLogFormatter "$time: htsn[$pid] $prio: $msg"
+ let handler = setFormatter handler' slf
+ updateGlobalLogger rootLoggerName (setLevel level . setHandlers [handler])
+ where
+ min_level = if syslog then INFO else DEBUG
+ level = if log_level < min_level then min_level else log_level