IOLogger.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiWayIf                #-}
{-# LANGUAGE TemplateHaskell           #-}
{-# LANGUAGE TupleSections             #-}

{- |
   Module     : System.Log.Logger
   Copyright  : Copyright (C) 2004-2011 John Goerzen
   License    : BSD3

   Maintainer : John Goerzen <jgoerzen@complete.org>
   Stability  : provisional
   Portability: portable

Haskell Logging Framework, Primary Interface

Written by John Goerzen, jgoerzen\@complete.org

This module is a modification of "System.Log.Logger" of 'hslogger'
library. Unless proper description is written here, please use the
original documentation available on hackage/hslogger.
-}

module System.Wlog.IOLogger
       (
         -- * Basic Types
         Logger
         -- ** Re-Exported from System.Wlog
       , Severity(..)

         -- * Logging Messages
         -- ** Basic
       , logM
       , logMCond
         -- ** Utility Functions
       , removeAllHandlers

         -- * Logger Manipulation
         -- ** Finding ∨ Creating Loggers
       , getLogger, getRootLogger, rootLoggerName
         -- ** Modifying Loggers
       , addHandler, removeHandler, setHandlers
       , getLevel, setLevel, clearLevel
         -- ** Severity settings
       , setSeverities, setSeveritiesMaybe
         -- ** Saving Your Changes
       , saveGlobalLogger
       , updateGlobalLogger
       , retrieveLogContent
       ) where

import Universum

import Control.Concurrent.MVar (modifyMVar, modifyMVar_, withMVar)
import Control.Lens (makeLenses)
import Data.Maybe (fromJust)
import System.IO.Unsafe (unsafePerformIO)

import System.Wlog.LoggerName (LoggerName (..))
import System.Wlog.LogHandler (LogHandler (getTag), LogHandlerTag (HandlerFilelike), close,
                               readBack)
import System.Wlog.Severity (LogRecord (..), Severities, Severity (..), debugPlus, warningPlus)


import qualified Data.Map as M
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.IO as TIO

import qualified System.Wlog.LogHandler (logHandlerMessage)

---------------------------------------------------------------------------
-- Basic logger types
---------------------------------------------------------------------------

data HandlerT = forall a. LogHandler a => HandlerT a

data Logger = Logger
    { _lLevel    :: Maybe Severities
    , _lHandlers :: [HandlerT]
    , _lName     :: LoggerName
    } deriving (Generic)

makeLenses ''Logger

type LogTree = Map LoggerName Logger

newtype LogInternalState = LogInternalState
    { liTree   :: LogTree
    } deriving (Generic)

---------------------------------------------------------------------------
-- Utilities
---------------------------------------------------------------------------

-- | The name of the root logger, which is always defined and present
-- on the system.
rootLoggerName :: LoggerName
rootLoggerName = mempty

---------------------------------------------------------------------------
-- Logger Tree Storage
---------------------------------------------------------------------------

-- | The log tree. Initialize it with a default root logger.
{-# NOINLINE logInternalState #-}
logInternalState :: MVar LogInternalState
-- note: only kick up tree if handled locally
logInternalState = unsafePerformIO $ do
    let liTree = M.singleton rootLoggerName $
                 Logger { _lLevel = Just warningPlus
                        , _lName = ""
                        , _lHandlers = []}
    newMVar $ LogInternalState {..}

{- | Given a name, return all components of it, starting from the root.
Example return value:

>["", "MissingH", "System.Cmd.Utils", "System.Cmd.Utils.pOpen"]

-}
componentsOfName :: LoggerName -> [LoggerName]
componentsOfName (LoggerName name) =
    rootLoggerName : (LoggerName <$> (joinComp (T.splitOn "." name) ""))
  where
    joinComp [] _ = []
    joinComp (x:xs) "" = x : joinComp xs x
    joinComp (x:xs) accum =
        let newlevel = accum <> "." <> x
        in newlevel : joinComp xs newlevel

---------------------------------------------------------------------------
-- Logging With Location
---------------------------------------------------------------------------

-- | Log a message using the given logger at a given priority.
logM :: MonadIO m
     => LoggerName -- ^ Name of the logger to use
     -> Severity   -- ^ Severity of this message
     -> Text       -- ^ The log text itself
     -> m ()
logM logname sev msg = do
    l <- getLogger logname
    handle l (LR sev msg) (const True)

logMCond :: MonadIO m => LoggerName -> Severity -> Text -> (LogHandlerTag -> Bool) -> m ()
logMCond logname sev msg cond = do
    l <- getLogger logname
    handle l (LR sev msg) cond

---------------------------------------------------------------------------
-- Public Logger Interaction Support
---------------------------------------------------------------------------

-- | Returns the logger for the given name.  If no logger with that name
-- exists, creates new loggers and any necessary parent loggers, with
-- no connected handlers.
getLogger :: MonadIO m => LoggerName -> m Logger
getLogger lname = liftIO $ modifyMVar logInternalState $ \lt@LogInternalState{..} ->
    case M.lookup lname liTree of
      Just x ->  return (lt, x) -- A logger exists; return it and leave tree
      Nothing -> do
          -- Add logger(s).  Then call myself to retrieve it.
          let newlt = createLoggers (componentsOfName lname) liTree
          let result = fromJust $ M.lookup lname newlt
          return (LogInternalState newlt, result)
  where
    createLoggers :: [LoggerName] -> LogTree -> LogTree
    createLoggers [] lt = lt -- No names to add; return tree unmodified
    createLoggers (x:xs) lt = -- Add logger to tree
        createLoggers xs $
            if M.member x lt
               then lt
               else M.insert x (defaultLogger & lName .~ x) lt

    defaultLogger :: Logger
    defaultLogger = Logger Nothing [] (error "log-warper has some strange code") -- ???!??!

-- | Returns the root logger.
getRootLogger :: MonadIO m => m Logger
getRootLogger = getLogger rootLoggerName

-- | Handle a log request.
handle :: MonadIO m => Logger -> LogRecord -> (LogHandlerTag -> Bool) -> m ()
handle l lrecord@(LR sev _) handlerFilter = do
    lp <- getLoggerSeverities nm
    when (sev `Set.member` lp) $ do
        ph <- concatMap (view lHandlers) <$> parentLoggers nm
        forM_ ph $ callHandler lrecord nm
  where
    nm :: LoggerName
    nm = view lName l

    parentLoggers :: MonadIO m => LoggerName -> m [Logger]
    parentLoggers = mapM getLogger . componentsOfName

    -- Get the severity we should use. Find the first logger in the
    -- tree, starting here, with a set severity. If even root doesn't
    -- have one, assume "Debug".
    getLoggerSeverities :: MonadIO m => LoggerName -> m Severities
    getLoggerSeverities name = do
        pl <- parentLoggers name
        case catMaybes . map (view lLevel) $ (l : pl) of
            []    -> pure debugPlus
            (x:_) -> pure x

    callHandler :: MonadIO m => LogRecord -> LoggerName -> HandlerT -> m ()
    callHandler lr loggername (HandlerT x) =
        when (handlerFilter $ getTag x) $
            System.Wlog.LogHandler.logHandlerMessage x lr loggername

-- | Add handler to 'Logger'.  Returns a new 'Logger'.
addHandler :: LogHandler a => a -> Logger -> Logger
addHandler h = lHandlers %~ (HandlerT h:)

-- | Remove a handler from the 'Logger'.  Handlers are removed in the reverse
-- order they were added, so the following property holds for any 'LogHandler'
-- @h@:
--
-- > removeHandler . addHandler h = id
--
-- If no handlers are associated with the 'Logger', it is returned unchanged.
--
-- The root logger's default handler that writes every message to stderr can
-- be removed by using this function before any handlers have been added
-- to the root logger:
--
-- > updateGlobalLogger rootLoggerName removeHandler
removeHandler :: Logger -> Logger
removeHandler = lHandlers %~ drop 1

-- | Set the 'Logger'\'s list of handlers to the list supplied.
-- All existing handlers are removed first.
setHandlers :: LogHandler a => [a] -> Logger -> Logger
setHandlers hl = lHandlers .~ map HandlerT hl

-- | Returns the "level" of the logger.  Items beneath this
-- level will be ignored.
getLevel :: Logger -> Maybe Severities
getLevel = _lLevel

-- | Sets the "level" of the 'Logger'.  Returns a new
-- 'Logger' object with the new level.
setLevel :: Severities -> Logger -> Logger
setLevel p = lLevel .~ Just p

-- | Clears the "level" of the 'Logger'.  It will now inherit the level of
-- | its parent.
clearLevel :: Logger -> Logger
clearLevel = lLevel .~ Nothing

-- | Set severities for given logger. By default parent's severities are used.
setSeverities :: MonadIO m => LoggerName -> Severities -> m ()
setSeverities name = updateGlobalLogger name . setLevel

-- | Set or clear severities.
setSeveritiesMaybe
    :: MonadIO m
    => LoggerName -> Maybe Severities -> m ()
setSeveritiesMaybe name Nothing  = updateGlobalLogger name clearLevel
setSeveritiesMaybe n    (Just x) = setSeverities n x

-- | Updates the global record for the given logger to take into
-- account any changes you may have made.
saveGlobalLogger :: MonadIO m => Logger -> m ()
saveGlobalLogger l = liftIO $
    modifyMVar_ logInternalState $ \LogInternalState{..} ->
    pure $ LogInternalState (M.insert (view lName l) l liTree)

-- | Helps you make changes on the given logger.  Takes a function
-- that makes changes and writes those changes back to the global
-- database.  Here's an example from above (\"s\" is a 'LogHandler'):
--
-- > updateGlobalLogger "MyApp.BuggyComponent"
-- >                    (setLevel DEBUG . setHandlers [s])
updateGlobalLogger
    :: MonadIO m
    => LoggerName         -- ^ Logger name
    -> (Logger -> Logger) -- ^ Function to call
    -> m ()
updateGlobalLogger ln func = do
    l <- getLogger ln
    saveGlobalLogger (func l)

-- | Allow graceful shutdown. Release all opened files/handlers/etc.
removeAllHandlers :: MonadIO m => m ()
removeAllHandlers = liftIO $
    modifyMVar_ logInternalState $ \LogInternalState{..} -> do
        let allHandlers = M.foldr (\l r -> concat [r, view lHandlers l]) [] liTree
        mapM_ (\(HandlerT h) -> close h) allHandlers
        let newTree = map (lHandlers .~ []) liTree
        return $ LogInternalState newTree

----------------------------------------------------------------------------
-- Retrieving logs ad-hoc
----------------------------------------------------------------------------

-- | Retrieves content of log file(s) given path. Example: there's @component.log@
-- in config, but this function will return @[component.log.122,
-- component.log.123]@ if you want to. Content is file lines newest
-- first.
--
-- FYI: this function is implemented to avoid the following problem:
-- log-warper holds open handles to files, so trying to open log file
-- for read would result in 'IOException'.
retrieveLogContent :: (MonadIO m) => FilePath -> Maybe Int -> m [Text]
retrieveLogContent filePath linesNum =
    liftIO $ withMVar logInternalState $ \LogInternalState{..} -> do
        let appropriateHandlers =
                filter (\(HandlerT h) -> getTag h == HandlerFilelike filePath) $
                concatMap _lHandlers $
                M.elems liTree
        let takeMaybe = maybe identity take linesNum
        case appropriateHandlers of
            [HandlerT h] -> liftIO $ readBack h 12345 -- all of them
            []  -> takeMaybe . reverse . T.lines <$> TIO.readFile filePath
            xs  -> error $ "Found more than one (" <> show (length xs) <>
                           "handle with the same filePath tag, impossible."