module System.Wlog.Launcher
( buildAndSetupYamlLogging
, initLoggingFromYaml
, parseLoggerConfig
, setupLogging
) where
import Control.Error.Util ((?:))
import Control.Exception (throwIO)
import qualified Data.HashMap.Strict as HM hiding (HashMap)
import qualified Data.Text as T
import Data.Yaml (decodeFileEither)
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>))
import Universum
import System.Wlog.Formatter (stdoutFormatter, stdoutFormatterTimeRounded)
import System.Wlog.Handler (LogHandler (setFormatter))
import System.Wlog.Handler.Roller (rotationFileHandler)
import System.Wlog.Handler.Simple (fileHandler)
import System.Wlog.Logger (addHandler, setPrefix, updateGlobalLogger)
import System.Wlog.LoggerConfig (HandlerWrap (..), LoggerConfig (..),
LoggerTree (..))
import System.Wlog.LoggerName (LoggerName (..))
import System.Wlog.Wrapper (Severity (Debug), initTerminalLogging,
setSeverityMaybe)
data HandlerFabric
= forall h . LogHandler h => HandlerFabric (FilePath -> Severity -> IO h)
setupLogging :: MonadIO m => LoggerConfig -> m ()
setupLogging LoggerConfig{..} = do
liftIO $ createDirectoryIfMissing True handlerPrefix
when consoleOutput $
initTerminalLogging isShowTime isShowTid _lcTermSeverity
liftIO $ setPrefix _lcFilePrefix
processLoggers mempty _lcTree
where
handlerPrefix = _lcFilePrefix ?: "."
logMapper = appEndo _lcMapper
isShowTime = getAny _lcShowTime
isShowTid = getAny _lcShowTid
consoleOutput = getAny _lcConsoleOutput
handlerFabric :: HandlerFabric
handlerFabric = case _lcRotation of
Nothing -> HandlerFabric fileHandler
Just rot -> HandlerFabric $ rotationFileHandler rot
processLoggers :: MonadIO m => LoggerName -> LoggerTree -> m ()
processLoggers parent LoggerTree{..} = do
unless (parent == mempty && not consoleOutput) $
setSeverityMaybe parent _ltSeverity
forM_ _ltFiles $ \HandlerWrap{..} -> liftIO $ do
let fileSeverity = _ltSeverity ?: Debug
let handlerPath = handlerPrefix </> _hwFilePath
case handlerFabric of
HandlerFabric fabric -> do
let handlerCreator = fabric handlerPath fileSeverity
let defFmt = (`setFormatter` stdoutFormatter isShowTime isShowTid)
let roundFmt r = (`setFormatter` stdoutFormatterTimeRounded r)
let fmt = maybe defFmt roundFmt _hwRounding
thisLoggerHandler <- fmt <$> handlerCreator
updateGlobalLogger (loggerName parent) $ addHandler thisLoggerHandler
for_ (HM.toList _ltSubloggers) $ \(name, loggerConfig) -> do
let thisLoggerName = LoggerName $ T.unpack name
let thisLogger = parent <> logMapper thisLoggerName
processLoggers thisLogger loggerConfig
parseLoggerConfig :: MonadIO m => FilePath -> m LoggerConfig
parseLoggerConfig loggerConfigPath =
liftIO $ join $ either throwIO return <$> decodeFileEither loggerConfigPath
buildAndSetupYamlLogging :: MonadIO m => LoggerConfig -> FilePath -> m ()
buildAndSetupYamlLogging configBuilder loggerConfigPath = do
cfg@LoggerConfig{..} <- parseLoggerConfig loggerConfigPath
let builtConfig = cfg <> configBuilder
setupLogging builtConfig
initLoggingFromYaml :: MonadIO m => FilePath -> m ()
initLoggingFromYaml = buildAndSetupYamlLogging mempty