Launcher.hs

{-# LANGUAGE CPP                       #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NoImplicitPrelude         #-}

-- |
-- Module      : System.Wlog.Parser
-- Copyright   : (c) Serokell, 2016
-- License     : GPL-3 (see the file LICENSE)
-- Maintainer  : Serokell <hi@serokell.io>
-- Stability   : experimental
-- Portability : POSIX, GHC
--
-- Parser for configuring and initializing logger from YAML file.
-- Logger configuration should look like this:
--
-- > rotation:                # [optional] parameters for logging rotation
-- >     logLimit: 1024       # max size of log file in bytes
-- >     keepFiles: 3         # number of files with logs to keep including current one
-- > node:                    # logger named «node»
-- >     severity: Warning    # severity for logger «node»
-- >     comm:                # logger named «node.comm»
-- >         severity: Info   # severity for logger «node.comm»
-- >         file: patak.jpg  # messages will be also printed to patak.jpg
--
-- And this configuration corresponds two loggers with 'LoggerName'`s
-- @node@ and @node.comm@.

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)

-- | This function traverses 'LoggerConfig' initializing all subloggers
-- with 'Severity' and redirecting output in file handlers.
-- See 'LoggerConfig' for more details.
setupLogging :: MonadIO m => LoggerConfig -> m ()
setupLogging LoggerConfig{..} = do
    liftIO $ createDirectoryIfMissing True handlerPrefix
    when consoleOutput $ initTerminalLogging isShowTime _lcTermSeverity
    -- TODO: use lifted version here
    whenJust _lcMemModeLimit $ \limit -> do
        putText "Initializing logs"
        let cpj = const . pure . Just -- just for lulz
        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
        -- This prevents logger output to appear in terminal
        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

-- | Parses logger config from given file path.
parseLoggerConfig :: MonadIO m => FilePath -> m LoggerConfig
parseLoggerConfig loggerConfigPath =
    liftIO $ join $ either throwIO return <$> decodeFileEither loggerConfigPath

-- | Applies given builder to parsed logger config and initializes logging.
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

-- | Initialize logger hierarchy from configuration file.
-- See this module description.
initLoggingFromYaml :: MonadIO m => FilePath -> m ()
initLoggingFromYaml = buildAndSetupYamlLogging mempty