{-# 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
, setPrefix
, retrieveLogContent
) where
import Universum
import Control.Concurrent.MVar (modifyMVar, modifyMVar_, withMVar)
import Data.Maybe (fromJust)
import Lens.Micro.Platform (makeLenses)
import System.FilePath ((</>))
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
data LogInternalState = LogInternalState
{ liTree :: LogTree
, liPrefix :: Maybe FilePath
} 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 = []}
liPrefix = Nothing
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 liPrefix, result)
where
createLoggers :: [LoggerName] -> LogTree -> LogTree
createLoggers xs lt = flipfoldl' addLoggerToTree lt xs
addLoggerToTree :: LoggerName -> LogTree ->LogTree
addLoggerToTree x lt =
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 mapMaybe (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
setPrefix :: MonadIO m => Maybe FilePath -> m ()
setPrefix p = liftIO
$ modifyMVar_ logInternalState
$ \li -> pure $ li { liPrefix = p }
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) liPrefix
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 -> r ++ view lHandlers l) [] liTree
mapM_ (\(HandlerT h) -> close h) allHandlers
let newTree = map (lHandlers .~ []) liTree
return $ LogInternalState newTree liPrefix
retrieveLogContent :: (MonadIO m) => FilePath -> Maybe Int -> m [Text]
retrieveLogContent filePath linesNum =
liftIO $ withMVar logInternalState $ \LogInternalState{..} -> do
let filePathFull = fromMaybe "" liPrefix </> filePath
let appropriateHandlers =
filter (\(HandlerT h) -> getTag h == HandlerFilelike filePathFull) $
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 filePathFull
xs -> error $ "Found more than one (" <> show (length xs) <>
"handle with the same filePath tag, impossible."