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
) where
import Data.List (isPrefixOf)
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import System.IO.Unsafe (unsafePerformIO)
import System.Wlog.Handler (LogHandler (getTag), close)
import qualified System.Wlog.Handler (handle)
import System.Wlog.Handler.Simple (streamHandler)
import System.Wlog.Severity (LogRecord, Severity (..))
import Universum
data HandlerT = forall a. LogHandler a => HandlerT a
data Logger = Logger
{ level :: Maybe Severity
, handlers :: [HandlerT]
, name :: String
}
type LogTree = Map.Map String Logger
rootLoggerName :: String
rootLoggerName = ""
logTree :: MVar LogTree
logTree = unsafePerformIO $ do
h <- streamHandler stderr Debug
newMVar $
Map.singleton rootLoggerName $
Logger {level = Just Warning, name = "", handlers = [HandlerT h]}
componentsOfName :: String -> [String]
componentsOfName name =
let joinComp [] _ = []
joinComp (x:xs) [] = x : joinComp xs x
joinComp (x:xs) accum =
let newlevel = accum ++ "." ++ x
in newlevel : joinComp xs newlevel
in rootLoggerName : joinComp (split "." name) []
logM :: String
-> Severity
-> Text
-> IO ()
logM logname pri msg = do
l <- getLogger logname
logL l pri msg
logMCond :: String -> Severity -> Text -> (String -> 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 logTree $ \lt -> case Map.lookup lname lt of
Just x -> return (lt, x)
Nothing -> do
let newlt = createLoggers (componentsOfName lname) lt
let result = fromJust $ Map.lookup lname newlt
return (newlt, result)
where
createLoggers :: [String] -> LogTree -> LogTree
createLoggers [] lt = lt
createLoggers (x:xs) lt =
if Map.member x lt
then createLoggers xs lt
else createLoggers xs
(Map.insert x (defaultLogger {name=x}) lt)
defaultLogger = Logger Nothing [] undefined
getRootLogger :: IO Logger
getRootLogger = getLogger rootLoggerName
logL :: Logger -> Severity -> Text -> IO ()
logL l pri msg = handle l (pri, msg) (const True)
logLCond :: Logger -> Severity -> Text -> (String -> Bool) -> IO ()
logLCond l pri msg = handle l (pri, msg)
handle :: Logger -> LogRecord -> (String -> Bool) -> IO ()
handle l lrecord@(sev, _) handlerFilter = do
lp <- getLoggerSeverity (name l)
if sev >= lp then do
ph <- parentHandlers (name l)
forM_ ph $ callHandler lrecord (name l)
else return ()
where
parentLoggers :: String -> IO [Logger]
parentLoggers [] = return []
parentLoggers name =
let pname0 = (head . drop 1 . reverse . componentsOfName) name
pname = fromMaybe (panic "Logger.handle.parentLoggers: pname head failed") pname0
in do parent <- getLogger pname
next <- parentLoggers pname
return (parent : next)
parentHandlers :: String -> IO [HandlerT]
parentHandlers name = do
parentLoggers name >>= (return . concatMap handlers)
getLoggerSeverity :: String -> IO Severity
getLoggerSeverity name = do
pl <- parentLoggers name
case catMaybes . map level $ (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
addHandler :: LogHandler a => a -> Logger -> Logger
addHandler h l= l{handlers = (HandlerT h) : (handlers l)}
removeHandler :: Logger -> Logger
removeHandler l = l { handlers = drop 1 $ handlers l }
setHandlers :: LogHandler a => [a] -> Logger -> Logger
setHandlers hl l =
l{handlers = map (\h -> HandlerT h) hl}
getLevel :: Logger -> Maybe Severity
getLevel = level
setLevel :: Severity -> Logger -> Logger
setLevel p l = l {level = Just p}
clearLevel :: Logger -> Logger
clearLevel l = l {level = Nothing}
saveGlobalLogger :: Logger -> IO ()
saveGlobalLogger l = modifyMVar_ logTree
(\lt -> return $ Map.insert (name l) l lt)
updateGlobalLogger
:: String
-> (Logger -> Logger)
-> IO ()
updateGlobalLogger ln func =
do l <- getLogger ln
saveGlobalLogger (func l)
removeAllHandlers :: IO ()
removeAllHandlers =
modifyMVar_ logTree $ \lt -> do
let allHandlers = Map.fold (\l r -> concat [r, handlers l]) [] lt
mapM_ (\(HandlerT h) -> close h) allHandlers
return $ Map.map (\l -> l {handlers = []}) lt
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
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)