src/Logging.hs

   1 module Logging (
   2   init_logging,
   3   log_debug,
   4   log_error,
   5   log_info,
   6   log_warning )
   7 where
   8
   9 import Control.Monad ( when )
  10 import System.Log.Formatter ( simpleLogFormatter )
  11 import System.Log.Handler ( setFormatter )
  12 import System.Log.Handler.Simple ( GenericHandler, fileHandler )
  13 import System.Log.Handler.Syslog (
  14   Facility ( USER ),
  15   openlog )
  16 import System.Log.Logger (
  17   Priority ( INFO ),
  18   addHandler,
  19   debugM,
  20   errorM,
  21   infoM,
  22   rootLoggerName,
  23   setHandlers,
  24   setLevel,
  25   updateGlobalLogger,
  26   warningM )
  27
  28
  29 log_debug :: String -> IO ()
  30 log_debug = debugM rootLoggerName
  31
  32 log_error :: String -> IO ()
  33 log_error = errorM rootLoggerName
  34
  35 log_info :: String -> IO ()
  36 log_info = infoM rootLoggerName
  37
  38 log_warning :: String -> IO ()
  39 log_warning = warningM rootLoggerName
  40
  41
  42 -- | Why don't we take a Configuration as an argument? Because it
  43 --   would create circular imports!
  44 init_logging :: Maybe FilePath -> Priority -> Bool -> IO ()
  45 init_logging log_file log_level syslog = do
  46   -- First set the global log level and clear the default handler.
  47   let no_handlers = [] :: [GenericHandler a]
  48   updateGlobalLogger rootLoggerName (setLevel log_level .
  49                                               setHandlers no_handlers)
  50
  51   when syslog $ do
  52     let min_level = INFO
  53     let sl_level = if log_level < min_level then min_level else log_level
  54
  55     -- The syslog handle gets its own level which will cowardly refuse
  56     -- to log all debug info (i.e. the entire feed) to syslog.
  57     sl_handler' <- openlog rootLoggerName [] USER sl_level
  58
  59     -- Syslog should output the date by itself.
  60     let sl_formatter = simpleLogFormatter "htsn[$pid] $prio: $msg"
  61     let sl_handler = setFormatter sl_handler' sl_formatter
  62
  63     updateGlobalLogger rootLoggerName (addHandler sl_handler)
  64
  65   case log_file of
  66     Nothing -> return ()
  67     Just lf -> do
  68       lf_handler' <- fileHandler lf log_level
  69       let lf_formatter = simpleLogFormatter "$time: htsn[$pid] $prio: $msg"
  70       let lf_handler = setFormatter lf_handler' lf_formatter
  71       updateGlobalLogger rootLoggerName (addHandler lf_handler)