module System.Wlog.Wrapper
( LoggingFormat (..)
, Severity (..)
, convertSeverity
, initLogging
, initLoggingWith
, releaseAllHandlers
, setSeverity
, setSeverityMaybe
) where
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
import Control.Monad.Trans (MonadIO (liftIO))
import Data.Default (Default (def))
import System.IO (Handle, stderr, stdout)
import System.Log.Handler.Simple (GenericHandler (..), streamHandler)
import System.Log.Logger (Priority (DEBUG, ERROR), clearLevel,
removeAllHandlers, rootLoggerName,
setHandlers, setLevel, updateGlobalLogger)
import System.Wlog.Formatter (setStderrFormatter, setStdoutFormatter)
import System.Wlog.LoggerName (LoggerName (..))
import System.Wlog.Severity (Severity (..), convertSeverity)
data LoggingFormat = LoggingFormat
{
lfShowTime :: !Bool
} deriving (Show)
instance Default LoggingFormat where
def = LoggingFormat {lfShowTime = True}
streamHandlerWithLock :: MVar () -> Handle -> Priority -> IO (GenericHandler Handle)
streamHandlerWithLock lock h p = do
GenericHandler{..} <- streamHandler h p
return GenericHandler
{ priority = priority
, formatter = formatter
, privData = privData
, writeFunc = \a s -> withMVar lock $ const $ writeFunc a s
, closeFunc = closeFunc
}
initLoggingWith
:: MonadIO m
=> LoggingFormat -> Severity -> m ()
initLoggingWith LoggingFormat {..} defaultSeverity = liftIO $ do
lock <- liftIO $ newMVar ()
stdoutHandler <- setStdoutFormatter lfShowTime <$>
streamHandlerWithLock lock stdout DEBUG
stderrHandler <- setStderrFormatter <$>
streamHandlerWithLock lock stderr ERROR
updateGlobalLogger rootLoggerName $
setHandlers [stderrHandler, stdoutHandler]
updateGlobalLogger rootLoggerName $
setLevel (convertSeverity defaultSeverity)
initLogging :: MonadIO m => Severity -> m ()
initLogging = initLoggingWith def
setSeverity :: MonadIO m => LoggerName -> Severity -> m ()
setSeverity (LoggerName name) =
liftIO . updateGlobalLogger name . setLevel . convertSeverity
setSeverityMaybe
:: MonadIO m
=> LoggerName -> Maybe Severity -> m ()
setSeverityMaybe (LoggerName name) Nothing =
liftIO $ updateGlobalLogger name clearLevel
setSeverityMaybe n (Just x) = setSeverity n x
releaseAllHandlers :: MonadIO m => m ()
releaseAllHandlers = liftIO removeAllHandlers