module System.Wlog.Launcher
( initLoggingFromYaml
, initLoggingFromYamlWithMapper
, parseLoggerConfig
, traverseLoggerConfig
) where
#if PatakDebugSkovorodaBARDAQ
import qualified Data.ByteString.Char8 as BS (putStrLn)
import Data.Yaml.Pretty (defConfig, encodePretty)
#endif
import Control.Error.Util ((?:))
import Control.Exception (throwIO)
import Control.Monad (join)
import Control.Monad.Extra (whenJust)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Foldable (for_)
import qualified Data.HashMap.Strict as HM hiding (HashMap)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Text (unpack)
import Data.Yaml (decodeFileEither)
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>))
import System.Log (Priority)
import System.Log.Handler (LogHandler)
import System.Log.Handler.Simple (fileHandler)
import System.Log.Logger (addHandler, updateGlobalLogger)
import System.Wlog.Formatter (setStdoutFormatter)
import System.Wlog.LoggerConfig (LoggerConfig (..), LoggerTree (..),
RotationParameters)
import System.Wlog.LoggerName (LoggerName (..))
import System.Wlog.Roller (rotationFileHandler)
import System.Wlog.Wrapper (Severity (Debug, Warning), convertSeverity,
initLogging, setSeverityMaybe)
data HandlerFabric
= forall h . LogHandler h => HandlerFabric (FilePath -> Priority -> IO h)
traverseLoggerConfig
:: MonadIO m
=> (LoggerName -> LoggerName)
-> Maybe RotationParameters
-> LoggerTree
-> Maybe FilePath
-> m ()
traverseLoggerConfig logMapper mrot tree (fromMaybe "." -> handlerPrefix) = do
liftIO $ createDirectoryIfMissing True handlerPrefix
initLogging Warning
processLoggers mempty tree
where
handlerFabric :: HandlerFabric
handlerFabric = case mrot of
Nothing -> HandlerFabric fileHandler
Just rot -> HandlerFabric $ rotationFileHandler rot
processLoggers :: MonadIO m => LoggerName -> LoggerTree -> m ()
processLoggers parent LoggerTree{..} = do
setSeverityMaybe parent ltSeverity
whenJust ltFile $ \fileName -> liftIO $ do
let filePriority = convertSeverity $ ltSeverity ?: Debug
let handlerPath = handlerPrefix </> fileName
case handlerFabric of
HandlerFabric fabric -> do
thisLoggerHandler <- setStdoutFormatter True <$> fabric handlerPath filePriority
updateGlobalLogger (loggerName parent) $ addHandler thisLoggerHandler
for_ (HM.toList ltSubloggers) $ \(name, loggerConfig) -> do
let thisLoggerName = LoggerName $ 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
initLoggingFromYamlWithMapper
:: MonadIO m
=> (LoggerName -> LoggerName)
-> FilePath
-> Maybe FilePath
-> m ()
initLoggingFromYamlWithMapper loggerMapper loggerConfigPath handlerPrefix = do
cfg@LoggerConfig{..} <- parseLoggerConfig loggerConfigPath
#if PatakDebugSkovorodaBARDAQ
liftIO $ BS.putStrLn $ encodePretty defConfig cfg
#endif
traverseLoggerConfig loggerMapper lcRotation lcTree handlerPrefix
initLoggingFromYaml :: MonadIO m => FilePath -> Maybe FilePath -> m ()
initLoggingFromYaml = initLoggingFromYamlWithMapper id