{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module System.Wlog.IOLogger
(
Logger
, Severity(..)
, logM
, logMCond
, removeAllHandlers
, getLogger, getRootLogger, rootLoggerName
, addHandler, removeHandler, setHandlers
, getLevel, setLevel, clearLevel
, setSeverities, setSeveritiesMaybe
, 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)
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)
rootLoggerName :: LoggerName
rootLoggerName = mempty
{-# NOINLINE logInternalState #-}
logInternalState :: MVar LogInternalState
logInternalState = unsafePerformIO $ do
let liTree = M.singleton rootLoggerName $
Logger { _lLevel = Just warningPlus
, _lName = ""
, _lHandlers = []}
newMVar $ LogInternalState {..}
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
logM :: MonadIO m
=> LoggerName
-> Severity
-> Text
-> 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
getLogger :: MonadIO m => LoggerName -> m Logger
getLogger lname = liftIO $ modifyMVar logInternalState $ \lt@LogInternalState{..} ->
case M.lookup lname liTree of
Just x -> return (lt, x)
Nothing -> do
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
createLoggers (x:xs) lt =
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")
getRootLogger :: MonadIO m => m Logger
getRootLogger = getLogger rootLoggerName
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
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
addHandler :: LogHandler a => a -> Logger -> Logger
addHandler h = lHandlers %~ (HandlerT h:)
removeHandler :: Logger -> Logger
removeHandler = lHandlers %~ drop 1
setHandlers :: LogHandler a => [a] -> Logger -> Logger
setHandlers hl = lHandlers .~ map HandlerT hl
getLevel :: Logger -> Maybe Severities
getLevel = _lLevel
setLevel :: Severities -> Logger -> Logger
setLevel p = lLevel .~ Just p
clearLevel :: Logger -> Logger
clearLevel = lLevel .~ Nothing
setSeverities :: MonadIO m => LoggerName -> Severities -> m ()
setSeverities name = updateGlobalLogger name . setLevel
setSeveritiesMaybe
:: MonadIO m
=> LoggerName -> Maybe Severities -> m ()
setSeveritiesMaybe name Nothing = updateGlobalLogger name clearLevel
setSeveritiesMaybe n (Just x) = setSeverities n x
saveGlobalLogger :: MonadIO m => Logger -> m ()
saveGlobalLogger l = liftIO $
modifyMVar_ logInternalState $ \LogInternalState{..} ->
pure $ LogInternalState (M.insert (view lName l) l liTree)
updateGlobalLogger
:: MonadIO m
=> LoggerName
-> (Logger -> Logger)
-> m ()
updateGlobalLogger ln func = do
l <- getLogger ln
saveGlobalLogger (func l)
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
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
[] -> takeMaybe . reverse . T.lines <$> TIO.readFile filePath
xs -> error $ "Found more than one (" <> show (length xs) <>
"handle with the same filePath tag, impossible."