{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
module System.Wlog.Launcher
( buildAndSetupYamlLogging
, defaultConfig
, launchFromFile
, launchSimpleLogging
, parseLoggerConfig
, setupLogging
) where
import Universum
import Control.Error.Util ((?:))
import Control.Exception (throwIO)
import Control.Lens (zoom, (.=), (?=))
import Data.Time (UTCTime)
import Data.Yaml (decodeFileEither)
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>))
import System.Wlog.Formatter (centiUtcTimeF, stdoutFormatter, stdoutFormatterTimeRounded)
import System.Wlog.IOLogger (addHandler, removeAllHandlers, setPrefix, setSeveritiesMaybe,
updateGlobalLogger)
import System.Wlog.LoggerConfig (HandlerWrap (..), LoggerConfig (..), LoggerTree (..), fromScratch,
lcConsoleAction, lcShowTime, lcTree, ltSeverity, productionB,
zoomLogger)
import System.Wlog.LoggerName (LoggerName (..))
import System.Wlog.LoggerNameBox (LoggerNameBox, usingLoggerName)
import System.Wlog.LogHandler (LogHandler (setFormatter))
import System.Wlog.LogHandler.Roller (rotationFileHandler)
import System.Wlog.LogHandler.Simple (defaultHandleAction, fileHandler)
import System.Wlog.Severity (Severities, debugPlus, warningPlus)
import System.Wlog.Terminal (initTerminalLogging)
import qualified Data.HashMap.Strict as HM hiding (HashMap)
data HandlerFabric
= forall h . LogHandler h => HandlerFabric (FilePath -> Severities -> IO h)
setupLogging :: MonadIO m => Maybe (UTCTime -> Text) -> LoggerConfig -> m ()
setupLogging mTimeFunction LoggerConfig{..} = do
liftIO $ createDirectoryIfMissing True handlerPrefix
whenJust consoleAction $ \customTerminalAction ->
initTerminalLogging timeF
customTerminalAction
isShowTime
isShowTid
_lcTermSeverityOut
_lcTermSeverityErr
liftIO $ setPrefix _lcFilePrefix
processLoggers mempty _lcTree
where
handlerPrefix = _lcFilePrefix ?: "."
logMapper = appEndo _lcMapper
timeF = fromMaybe centiUtcTimeF mTimeFunction
isShowTime = getAny _lcShowTime
isShowTid = getAny _lcShowTid
consoleAction = getLast _lcConsoleAction
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 && isNothing consoleAction) $
setSeveritiesMaybe parent (_ltSeverity)
forM_ _ltFiles $ \HandlerWrap{..} -> liftIO $ do
let fileSeverities = (_ltSeverity) ?: debugPlus
let handlerPath = handlerPrefix </> _hwFilePath
case handlerFabric of
HandlerFabric fabric -> do
let handlerCreator = fabric handlerPath fileSeverities
let defFmt = (`setFormatter` stdoutFormatter timeF isShowTime isShowTid)
let roundFmt r = (`setFormatter` stdoutFormatterTimeRounded timeF r)
let fmt = maybe defFmt roundFmt _hwRounding
thisLoggerHandler <- fmt <$> handlerCreator
updateGlobalLogger parent $ addHandler thisLoggerHandler
for_ (HM.toList _ltSubloggers) $ \(name, loggerConfig) -> do
let thisLoggerName = LoggerName 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 Nothing builtConfig
launchFromFile :: (MonadIO m, MonadMask m)
=> FilePath
-> LoggerName
-> LoggerNameBox m a
-> m a
launchFromFile filename loggerName action =
bracket_
(buildAndSetupYamlLogging productionB filename)
removeAllHandlers
(usingLoggerName loggerName action)
defaultConfig :: LoggerName -> LoggerConfig
defaultConfig loggerName = fromScratch $ do
lcShowTime .= Any True
lcConsoleAction .= Last (Just defaultHandleAction)
zoom lcTree $ do
ltSeverity ?= warningPlus
zoomLogger (getLoggerName loggerName) $ do
ltSeverity ?= debugPlus
launchSimpleLogging :: (MonadIO m, MonadMask m)
=> LoggerName
-> LoggerNameBox m a
-> m a
launchSimpleLogging loggerName action =
bracket_
(setupLogging Nothing $ defaultConfig loggerName)
removeAllHandlers
(usingLoggerName loggerName action)