X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FLogging.hs;h=ede739a28ba9a9027bbbebc894dc51a5ad0cdd18;hb=fdd40277556133bd14cf0a3f13749f4663b5f3ba;hp=d8f9ed484f63b22fa1db553a10e8940b77ab9147;hpb=49c23c133221c9686dde0d52d06904db8d048724;p=dead%2Fhtsn.git

diff --git a/src/Logging.hs b/src/Logging.hs
index d8f9ed4..ede739a 100644
--- a/src/Logging.hs
+++ b/src/Logging.hs
@@ -6,11 +6,16 @@ module Logging (
   log_warning )
 where
 
-import System.IO ( hPutStr, stderr, stdout )
-import System.Log ( LogRecord )
-import System.Log.Formatter ( LogFormatter )
+import Control.Monad ( when )
+import System.Log.Formatter ( simpleLogFormatter )
+import System.Log.Handler ( setFormatter )
+import System.Log.Handler.Simple ( GenericHandler, fileHandler )
+import System.Log.Handler.Syslog (
+  Facility ( USER ),
+  openlog )
 import System.Log.Logger (
-  Priority ( DEBUG, ERROR, INFO, WARNING ),
+  Priority ( INFO ),
+  addHandler,
   debugM,
   errorM,
   infoM,
@@ -19,67 +24,58 @@ import System.Log.Logger (
   setLevel,
   updateGlobalLogger,
   warningM )
-import System.Log.Handler.Simple (
-  GenericHandler(..),
-  streamHandler )
 
-import Terminal ( hPutBlueStr, hPutRedStr )
 
+-- | Log a message at the DEBUG level.
 log_debug :: String -> IO ()
 log_debug = debugM rootLoggerName
 
+-- | Log a message at the ERROR level.
 log_error :: String -> IO ()
 log_error = errorM rootLoggerName
 
+-- | Log a message at the INFO level.
 log_info :: String -> IO ()
 log_info = infoM rootLoggerName
 
+-- | Log a message at the WARNING level.
 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])
+-- | Set up the logging. All logs are handled by the global "root"
+--   logger provided by HSLogger. We remove all of its handlers so
+--   that it does nothing; then we conditionally add back two handlers
+--   -- one for syslog, and one for a normal file -- dependent upon
+--   the 'syslog' and 'log_file' configuration items.
+--
+--   Why don't we take a Configuration as an argument? Because it
+--   would create circular imports!
+init_logging :: Maybe FilePath -> Priority -> Bool -> IO ()
+init_logging log_file log_level syslog = do
+  -- First set the global log level and clear the default handler.
+  let no_handlers = [] :: [GenericHandler a]
+  updateGlobalLogger rootLoggerName (setLevel log_level .
+                                              setHandlers no_handlers)
+
+  when syslog $ do
+    let min_level = INFO
+    let sl_level = if log_level < min_level then min_level else log_level
+
+    -- The syslog handle gets its own level which will cowardly refuse
+    -- to log all debug info (i.e. the entire feed) to syslog.
+    sl_handler' <- openlog rootLoggerName [] USER sl_level
+
+    -- Syslog should output the date by itself.
+    let sl_formatter = simpleLogFormatter "htsn[$pid] $prio: $msg"
+    let sl_handler = setFormatter sl_handler' sl_formatter
+
+    updateGlobalLogger rootLoggerName (addHandler sl_handler)
+
+  case log_file of
+    Nothing -> return ()
+    Just lf -> do
+      lf_handler' <- fileHandler lf log_level
+      let lf_formatter = simpleLogFormatter "$time: htsn[$pid] $prio: $msg"
+      let lf_handler = setFormatter lf_handler' lf_formatter
+      updateGlobalLogger rootLoggerName (addHandler lf_handler)