module System.Wlog.Parser
( 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.Handler.Simple (fileHandler)
import System.Log.Logger (addHandler, updateGlobalLogger)
import System.Wlog.Formatter (setStdoutFormatter)
import System.Wlog.LoggerConfig (LoggerConfig (..))
import System.Wlog.LoggerName (LoggerName (..))
import System.Wlog.Wrapper (Severity (Debug, Warning), convertSeverity,
initLogging, setSeverityMaybe)
traverseLoggerConfig
:: MonadIO m
=> (LoggerName -> LoggerName)
-> LoggerConfig
-> Maybe FilePath
-> m ()
traverseLoggerConfig logMapper config (fromMaybe "." -> handlerPrefix) = do
liftIO $ createDirectoryIfMissing True handlerPrefix
initLogging Warning
processLoggers mempty config
where
processLoggers:: MonadIO m => LoggerName -> LoggerConfig -> m ()
processLoggers parent LoggerConfig{..} = do
setSeverityMaybe parent lcSeverity
whenJust lcFile $ \fileName -> liftIO $ do
let fileSeverity = convertSeverity $ lcSeverity ?: Debug
let handlerPath = handlerPrefix </> fileName
thisLoggerHandler <- setStdoutFormatter True <$> fileHandler handlerPath fileSeverity
updateGlobalLogger (loggerName parent) $ addHandler thisLoggerHandler
for_ (HM.toList lcSubloggers) $ \(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
loggerConfig <- parseLoggerConfig loggerConfigPath
#if PatakDebugSkovorodaBARDAQ
liftIO $ BS.putStrLn $ encodePretty defConfig loggerConfig
#endif
traverseLoggerConfig loggerMapper loggerConfig handlerPrefix
initLoggingFromYaml :: MonadIO m => FilePath -> Maybe FilePath -> m ()
initLoggingFromYaml = initLoggingFromYamlWithMapper id