Attempt to implement syslog logging; fail at least with metalog.

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

diff --git a/src/Logging.hs b/src/Logging.hs
index d8f9ed484f63b22fa1db553a10e8940b77ab9147..94f4f7aa63bc383c23277c13bb8d93dd5b713cb3 100644 (file)
--- a/src/Logging.hs
+++ b/src/Logging.hs
@@ -6,11 +6,13 @@ module Logging (
   log_warning )
 where
 
-import System.IO ( hPutStr, stderr, stdout )
-import System.Log ( LogRecord )
-import System.Log.Formatter ( LogFormatter )
+import System.Log.Handler.Simple ( fileHandler )
+import System.Log.Handler.Syslog (
+  Facility ( USER ),
+  Option ( PID ),
+  openlog )
 import System.Log.Logger (
-  Priority ( DEBUG, ERROR, INFO, WARNING ),
+  Priority ( DEBUG, INFO ),
   debugM,
   errorM,
   infoM,
@@ -19,11 +21,6 @@ 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 +34,14 @@ 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])
+init_logging :: FilePath -> Priority -> Bool -> IO ()
+init_logging log_file log_level syslog
+  | syslog == True = do
+      handler <- openlog rootLoggerName [PID] USER level
+      updateGlobalLogger rootLoggerName (setLevel level . setHandlers [handler])
+  | otherwise = do
+      handler <- fileHandler log_file level
+      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