Finally get logging right.

[dead/htsn.git] / src / Logging.hs

diff --git a/src/Logging.hs b/src/Logging.hs
index d8f9ed484f63b22fa1db553a10e8940b77ab9147..fb1bfc658c91a536ff72b81627319681211a9588 100644 (file)
--- a/src/Logging.hs
+++ b/src/Logging.hs
@@ -6,11 +6,14 @@ module Logging (
   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,
@@ -19,11 +22,7 @@ import System.Log.Logger (
   setLevel,
   updateGlobalLogger,
   warningM )
-import System.Log.Handler.Simple (
-  GenericHandler(..),
-  streamHandler )
 
-import Terminal ( hPutBlueStr, hPutRedStr )
 
 log_debug :: String -> IO ()
 log_debug = debugM rootLoggerName
@@ -37,49 +36,22 @@ log_info = infoM 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