module System.Wlog.Launcher
( buildAndSetupYamlLogging
, initLoggingFromYaml
, parseLoggerConfig
, setupLogging
) where
import Universum
#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, when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import qualified Data.HashMap.Strict as HM hiding (HashMap)
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.CanLog (memoryLogs)
import System.Wlog.Formatter (setStdoutFormatter)
import System.Wlog.LoggerConfig (LoggerConfig (..), LoggerTree (..))
import System.Wlog.LoggerName (LoggerName (..))
import System.Wlog.MemoryQueue (newMemoryQueue)
import System.Wlog.Roller (rotationFileHandler)
import System.Wlog.Wrapper (Severity (Debug), convertSeverity,
initTerminalLogging, setSeverityMaybe)
data HandlerFabric
= forall h . LogHandler h => HandlerFabric (FilePath -> Priority -> IO h)
setupLogging :: MonadIO m => LoggerConfig -> m ()
setupLogging LoggerConfig{..} = do
liftIO $ createDirectoryIfMissing True handlerPrefix
when consoleOutput $ initTerminalLogging isShowTime _lcTermSeverity
whenJust _lcMemModeLimit $ \limit -> do
putText "Initializing logs"
let cpj = const . pure . Just
liftIO $ modifyMVar_ memoryLogs $ cpj $ newMemoryQueue limit
processLoggers mempty _lcTree
where
handlerPrefix = _lcFilePrefix ?: "."
logMapper = appEndo _lcMapper
isShowTime = getAny _lcShowTime
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
whenJust _ltFile $ \fileName -> liftIO $ do
let filePriority = convertSeverity $ _ltSeverity ?: Debug
let handlerPath = handlerPrefix </> fileName
case handlerFabric of
HandlerFabric fabric -> do
let handlerCreator = fabric handlerPath filePriority
thisLoggerHandler <- setStdoutFormatter isShowTime <$> handlerCreator
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
buildAndSetupYamlLogging :: MonadIO m => LoggerConfig -> FilePath -> m ()
buildAndSetupYamlLogging configBuilder loggerConfigPath = do
cfg@LoggerConfig{..} <- parseLoggerConfig loggerConfigPath
let builtConfig = cfg <> configBuilder
#if PatakDebugSkovorodaBARDAQ
liftIO $ BS.putStrLn $ encodePretty defConfig builtConfig
#endif
setupLogging builtConfig
initLoggingFromYaml :: MonadIO m => FilePath -> m ()
initLoggingFromYaml = buildAndSetupYamlLogging mempty