module System.Wlog.Wrapper
( Severity (..)
, initTerminalLogging
, releaseAllHandlers
, setSeverity
, setSeverityMaybe
) where
import Universum
import Control.Concurrent.MVar (withMVar)
import System.IO (Handle, stderr, stdout)
import System.Wlog.Formatter (stderrFormatter, stdoutFormatter)
import System.Wlog.Handler (LogHandler (setFormatter))
import System.Wlog.Handler.Simple (GenericHandler (..), streamHandler)
import System.Wlog.Logger (clearLevel, removeAllHandlers,
rootLoggerName, setHandlers, setLevel,
updateGlobalLogger)
import System.Wlog.LoggerName (LoggerName (..))
import System.Wlog.Severity (Severity (..))
streamHandlerWithLock :: MVar () -> Handle -> Severity -> IO (GenericHandler Handle)
streamHandlerWithLock lock h sev = do
GenericHandler{..} <- streamHandler h sev
return GenericHandler
{ severity = severity
, formatter = formatter
, privData = privData
, writeFunc = \a s -> withMVar lock $ const $ writeFunc a s
, closeFunc = closeFunc
, ghTag = ghTag
}
initTerminalLogging :: MonadIO m => Bool -> Maybe Severity -> m ()
initTerminalLogging isShowTime (fromMaybe Warning -> defaultSeverity) = liftIO $ do
lock <- liftIO $ newMVar ()
stdoutHandler <- setStdoutFormatter <$>
streamHandlerWithLock lock stdout Debug
stderrHandler <- setStderrFormatter <$>
streamHandlerWithLock lock stderr Error
updateGlobalLogger rootLoggerName $
setHandlers [stderrHandler, stdoutHandler]
updateGlobalLogger rootLoggerName $
setLevel defaultSeverity
where
setStdoutFormatter = (`setFormatter` stdoutFormatter isShowTime)
setStderrFormatter = (`setFormatter` stderrFormatter)
setSeverity :: MonadIO m => LoggerName -> Severity -> m ()
setSeverity (LoggerName name) =
liftIO . updateGlobalLogger name . setLevel
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