module System.Wlog.Logger
(
Logger
, Severity(..)
, logM
, logMCond
, debugM, infoM, noticeM, warningM, errorM
, removeAllHandlers
, traplogging
, logL
, logLCond
, getLogger, getRootLogger, rootLoggerName
, addHandler, removeHandler, setHandlers
, getLevel, setLevel, clearLevel
, saveGlobalLogger
, updateGlobalLogger
, setPrefix
, retrieveLogContent
) where
import Control.Concurrent.MVar (modifyMVar, modifyMVar_, withMVar)
import Control.Lens (makeLenses)
import Data.List (isPrefixOf)
import qualified Data.Map as M
import Data.Maybe (fromJust)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import System.FilePath ((</>))
import System.IO.Unsafe (unsafePerformIO)
import Universum
import System.Wlog.Handler (LogHandler (getTag),
LogHandlerTag (HandlerFilelike), close,
readBack)
import qualified System.Wlog.Handler (handle)
import System.Wlog.Severity (LogRecord (..), Severity (..))
data HandlerT = forall a. LogHandler a => HandlerT a
data Logger = Logger
{ _lLevel :: Maybe Severity
, _lHandlers :: [HandlerT]
, _lName :: String
} deriving (Generic)
makeLenses ''Logger
type LogTree = Map String Logger
data LogInternalState = LogInternalState
{ liTree :: Map String Logger
, liPrefix :: Maybe FilePath
} deriving (Generic)
rootLoggerName :: String
rootLoggerName = ""
logInternalState :: MVar LogInternalState
logInternalState = unsafePerformIO $ do
let liTree = M.singleton rootLoggerName $
Logger { _lLevel = Just Warning
, _lName = ""
, _lHandlers = []}
liPrefix = Nothing
newMVar $ LogInternalState {..}
componentsOfName :: String -> [String]
componentsOfName name =
rootLoggerName : joinComp (split "." name) []
where
joinComp [] _ = []
joinComp (x:xs) [] = x : joinComp xs x
joinComp (x:xs) accum =
let newlevel = accum ++ "." ++ x
in newlevel : joinComp xs newlevel
logM :: String
-> Severity
-> Text
-> IO ()
logM logname pri msg = do
l <- getLogger logname
logL l pri msg
logMCond :: String -> Severity -> Text -> (LogHandlerTag -> Bool) -> IO ()
logMCond logname sev msg cond = do
l <- getLogger logname
logLCond l sev msg cond
debugM :: String
-> Text
-> IO ()
debugM s = logM s Debug
infoM :: String
-> Text
-> IO ()
infoM s = logM s Info
noticeM :: String
-> Text
-> IO ()
noticeM s = logM s Notice
warningM :: String
-> Text
-> IO ()
warningM s = logM s Warning
errorM :: String
-> Text
-> IO ()
errorM s = logM s Error
getLogger :: String -> IO Logger
getLogger lname = 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 :: [String] -> 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 Nothing [] (error "log-warper has some strange code")
getRootLogger :: IO Logger
getRootLogger = getLogger rootLoggerName
logL :: Logger -> Severity -> Text -> IO ()
logL l pri msg = handle l (LR pri msg) (const True)
logLCond :: Logger -> Severity -> Text -> (LogHandlerTag -> Bool) -> IO ()
logLCond l pri msg = handle l (LR pri msg)
handle :: Logger -> LogRecord -> (LogHandlerTag -> Bool) -> IO ()
handle l lrecord@(LR sev _) handlerFilter = do
lp <- getLoggerSeverity nm
if sev >= lp then do
ph <- concatMap (view lHandlers) <$> parentLoggers nm
forM_ ph $ callHandler lrecord nm
else return ()
where
nm = view lName l
parentLoggers :: String -> IO [Logger]
parentLoggers = mapM getLogger . componentsOfName
getLoggerSeverity :: String -> IO Severity
getLoggerSeverity name = do
pl <- parentLoggers name
case catMaybes . map (view lLevel) $ (l : pl) of
[] -> pure Debug
(x:_) -> pure x
callHandler :: LogRecord -> String -> HandlerT -> IO ()
callHandler lr loggername (HandlerT x) =
when (handlerFilter $ getTag x) $
System.Wlog.Handler.handle x lr loggername
setPrefix :: Maybe FilePath -> IO ()
setPrefix p = 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 Severity
getLevel = _lLevel
setLevel :: Severity -> Logger -> Logger
setLevel p = lLevel .~ Just p
clearLevel :: Logger -> Logger
clearLevel = lLevel .~ Nothing
saveGlobalLogger :: Logger -> IO ()
saveGlobalLogger l =
modifyMVar_ logInternalState $ \LogInternalState{..} ->
pure $ LogInternalState (M.insert (view lName l) l liTree) liPrefix
updateGlobalLogger
:: String
-> (Logger -> Logger)
-> IO ()
updateGlobalLogger ln func =
do l <- getLogger ln
saveGlobalLogger (func l)
removeAllHandlers :: IO ()
removeAllHandlers =
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 liPrefix
traplogging :: String
-> Severity
-> Text
-> IO a
-> IO a
traplogging logger priority desc action = action `catch` handler
where
realdesc =
case desc of
"" -> ""
x -> x <> ": "
handler :: SomeException -> IO a
handler e = do
logM logger priority (realdesc <> show e)
throwM e
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."
split :: Eq a => [a] -> [a] -> [[a]]
split _ [] = []
split delim str =
let (firstline, remainder) = breakList (isPrefixOf delim) str
in firstline :
case remainder of
[] -> []
x | x == delim -> [] : []
| otherwise -> split delim (drop (length delim) x)
breakList :: ([a] -> Bool) -> [a] -> ([a], [a])
breakList func = spanList (not . func)
spanList :: ([a] -> Bool) -> [a] -> ([a], [a])
spanList _ [] = ([],[])
spanList func l@(x:xs) =
let (ys, zs) = spanList func xs
in if func l
then (x : ys, zs)
else ([], l)