{-# LANGUAGE CPP, ExistentialQuantification #-}
module System.Log.Logger(
Logger,
Priority(..),
logM,
debugM, infoM, noticeM, warningM, errorM,
criticalM, alertM, emergencyM,
removeAllHandlers,
traplogging,
logL,
getLogger, getRootLogger, rootLoggerName,
addHandler, removeHandler, setHandlers,
getLevel, setLevel, clearLevel,
saveGlobalLogger,
updateGlobalLogger
) where
import System.Log
import System.Log.Handler(LogHandler, close)
import System.Log.Formatter(LogFormatter)
import qualified System.Log.Handler(handle)
import System.Log.Handler.Simple
import System.IO
import System.IO.Unsafe
import Control.Concurrent.MVar
import Data.List(map, isPrefixOf)
import Data.Maybe
import qualified Data.Map as Map
import qualified Control.Exception
data HandlerT = forall a. LogHandler a => HandlerT a
data Logger = Logger { Logger -> Maybe Priority
level :: Maybe Priority,
Logger -> [HandlerT]
handlers :: [HandlerT],
Logger -> String
name :: String}
type LogTree = Map.Map String Logger
rootLoggerName :: String
rootLoggerName :: String
rootLoggerName = ""
{-# NOINLINE logTree #-}
logTree :: MVar LogTree
logTree :: MVar LogTree
logTree =
IO (MVar LogTree) -> MVar LogTree
forall a. IO a -> a
unsafePerformIO (IO (MVar LogTree) -> MVar LogTree)
-> IO (MVar LogTree) -> MVar LogTree
forall a b. (a -> b) -> a -> b
$ do
GenericHandler Handle
h <- Handle -> Priority -> IO (GenericHandler Handle)
streamHandler Handle
stderr Priority
DEBUG
LogTree -> IO (MVar LogTree)
forall a. a -> IO (MVar a)
newMVar (String -> Logger -> LogTree
forall k a. k -> a -> Map k a
Map.singleton String
rootLoggerName (Logger :: Maybe Priority -> [HandlerT] -> String -> Logger
Logger
{level :: Maybe Priority
level = Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
WARNING,
name :: String
name = "",
handlers :: [HandlerT]
handlers = [GenericHandler Handle -> HandlerT
forall a. LogHandler a => a -> HandlerT
HandlerT GenericHandler Handle
h]}))
componentsOfName :: String -> [String]
componentsOfName :: String -> [String]
componentsOfName name' :: String
name' =
let joinComp :: [String] -> String -> [String]
joinComp [] _ = []
joinComp (x :: String
x:xs :: [String]
xs) [] = String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> String -> [String]
joinComp [String]
xs String
x
joinComp (x :: String
x:xs :: [String]
xs) accum :: String
accum =
let newlevel :: String
newlevel = String
accum String -> String -> String
forall a. [a] -> [a] -> [a]
++ "." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x in
String
newlevel String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> String -> [String]
joinComp [String]
xs String
newlevel
in
String
rootLoggerName String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> String -> [String]
joinComp (String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
split "." String
name') []
logM :: String
-> Priority
-> String
-> IO ()
logM :: String -> Priority -> String -> IO ()
logM logname :: String
logname pri :: Priority
pri msg :: String
msg = do
Logger
l <- String -> IO Logger
getLogger String
logname
Logger -> Priority -> String -> IO ()
logL Logger
l Priority
pri String
msg
debugM :: String
-> String
-> IO ()
debugM :: String -> String -> IO ()
debugM s :: String
s = String -> Priority -> String -> IO ()
logM String
s Priority
DEBUG
infoM :: String
-> String
-> IO ()
infoM :: String -> String -> IO ()
infoM s :: String
s = String -> Priority -> String -> IO ()
logM String
s Priority
INFO
noticeM :: String
-> String
-> IO ()
noticeM :: String -> String -> IO ()
noticeM s :: String
s = String -> Priority -> String -> IO ()
logM String
s Priority
NOTICE
warningM :: String
-> String
-> IO ()
warningM :: String -> String -> IO ()
warningM s :: String
s = String -> Priority -> String -> IO ()
logM String
s Priority
WARNING
errorM :: String
-> String
-> IO ()
errorM :: String -> String -> IO ()
errorM s :: String
s = String -> Priority -> String -> IO ()
logM String
s Priority
ERROR
criticalM :: String
-> String
-> IO ()
criticalM :: String -> String -> IO ()
criticalM s :: String
s = String -> Priority -> String -> IO ()
logM String
s Priority
CRITICAL
alertM :: String
-> String
-> IO ()
alertM :: String -> String -> IO ()
alertM s :: String
s = String -> Priority -> String -> IO ()
logM String
s Priority
ALERT
emergencyM :: String
-> String
-> IO ()
emergencyM :: String -> String -> IO ()
emergencyM s :: String
s = String -> Priority -> String -> IO ()
logM String
s Priority
EMERGENCY
getLogger :: String -> IO Logger
getLogger :: String -> IO Logger
getLogger lname :: String
lname = MVar LogTree -> (LogTree -> IO (LogTree, Logger)) -> IO Logger
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar LogTree
logTree ((LogTree -> IO (LogTree, Logger)) -> IO Logger)
-> (LogTree -> IO (LogTree, Logger)) -> IO Logger
forall a b. (a -> b) -> a -> b
$ \lt :: LogTree
lt ->
case String -> LogTree -> Maybe Logger
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
lname LogTree
lt of
Just x :: Logger
x -> (LogTree, Logger) -> IO (LogTree, Logger)
forall (m :: * -> *) a. Monad m => a -> m a
return (LogTree
lt, Logger
x)
Nothing -> do
let newlt :: LogTree
newlt = [String] -> LogTree -> LogTree
createLoggers (String -> [String]
componentsOfName String
lname) LogTree
lt
let result :: Logger
result = Maybe Logger -> Logger
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Logger -> Logger) -> Maybe Logger -> Logger
forall a b. (a -> b) -> a -> b
$ String -> LogTree -> Maybe Logger
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
lname LogTree
newlt
(LogTree, Logger) -> IO (LogTree, Logger)
forall (m :: * -> *) a. Monad m => a -> m a
return (LogTree
newlt, Logger
result)
where createLoggers :: [String] -> LogTree -> LogTree
createLoggers :: [String] -> LogTree -> LogTree
createLoggers [] lt :: LogTree
lt = LogTree
lt
createLoggers (x :: String
x:xs :: [String]
xs) lt :: LogTree
lt =
if String -> LogTree -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member String
x LogTree
lt
then [String] -> LogTree -> LogTree
createLoggers [String]
xs LogTree
lt
else [String] -> LogTree -> LogTree
createLoggers [String]
xs
(String -> Logger -> LogTree -> LogTree
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
x (Logger
defaultLogger {name :: String
name=String
x}) LogTree
lt)
defaultLogger :: Logger
defaultLogger = Maybe Priority -> [HandlerT] -> String -> Logger
Logger Maybe Priority
forall a. Maybe a
Nothing [] String
forall a. HasCallStack => a
undefined
getRootLogger :: IO Logger
getRootLogger :: IO Logger
getRootLogger = String -> IO Logger
getLogger String
rootLoggerName
logL :: Logger -> Priority -> String -> IO ()
logL :: Logger -> Priority -> String -> IO ()
logL l :: Logger
l pri :: Priority
pri msg :: String
msg = Logger -> LogRecord -> IO ()
handle Logger
l (Priority
pri, String
msg)
handle :: Logger -> LogRecord -> IO ()
handle :: Logger -> LogRecord -> IO ()
handle l :: Logger
l (pri :: Priority
pri, msg :: String
msg) =
let parentLoggers :: String -> IO [Logger]
parentLoggers :: String -> IO [Logger]
parentLoggers [] = [Logger] -> IO [Logger]
forall (m :: * -> *) a. Monad m => a -> m a
return []
parentLoggers name' :: String
name' =
let pname :: String
pname = ([String] -> String
forall a. [a] -> a
head ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop 1 ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
componentsOfName) String
name'
in
do Logger
parent <- String -> IO Logger
getLogger String
pname
[Logger]
next <- String -> IO [Logger]
parentLoggers String
pname
[Logger] -> IO [Logger]
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger
parent Logger -> [Logger] -> [Logger]
forall a. a -> [a] -> [a]
: [Logger]
next)
parentHandlers :: String -> IO [HandlerT]
parentHandlers :: String -> IO [HandlerT]
parentHandlers name' :: String
name' = String -> IO [Logger]
parentLoggers String
name' IO [Logger] -> ([Logger] -> IO [HandlerT]) -> IO [HandlerT]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([HandlerT] -> IO [HandlerT]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HandlerT] -> IO [HandlerT])
-> ([Logger] -> [HandlerT]) -> [Logger] -> IO [HandlerT]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Logger -> [HandlerT]) -> [Logger] -> [HandlerT]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Logger -> [HandlerT]
handlers)
getLoggerPriority :: String -> IO Priority
getLoggerPriority :: String -> IO Priority
getLoggerPriority name' :: String
name' =
do [Logger]
pl <- String -> IO [Logger]
parentLoggers String
name'
case [Maybe Priority] -> [Priority]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Priority] -> [Priority])
-> ([Logger] -> [Maybe Priority]) -> [Logger] -> [Priority]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Logger -> Maybe Priority) -> [Logger] -> [Maybe Priority]
forall a b. (a -> b) -> [a] -> [b]
map Logger -> Maybe Priority
level ([Logger] -> [Priority]) -> [Logger] -> [Priority]
forall a b. (a -> b) -> a -> b
$ (Logger
l Logger -> [Logger] -> [Logger]
forall a. a -> [a] -> [a]
: [Logger]
pl) of
[] -> Priority -> IO Priority
forall (m :: * -> *) a. Monad m => a -> m a
return Priority
DEBUG
(x :: Priority
x:_) -> Priority -> IO Priority
forall (m :: * -> *) a. Monad m => a -> m a
return Priority
x
in
do Priority
lp <- String -> IO Priority
getLoggerPriority (Logger -> String
name Logger
l)
if Priority
pri Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
>= Priority
lp
then do
[HandlerT]
ph <- String -> IO [HandlerT]
parentHandlers (Logger -> String
name Logger
l)
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([HandlerT] -> LogRecord -> String -> [IO ()]
handlerActions ([HandlerT]
ph [HandlerT] -> [HandlerT] -> [HandlerT]
forall a. [a] -> [a] -> [a]
++ (Logger -> [HandlerT]
handlers Logger
l)) (Priority
pri, String
msg)
(Logger -> String
name Logger
l))
else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
callHandler :: LogRecord -> String -> HandlerT -> IO ()
callHandler :: LogRecord -> String -> HandlerT -> IO ()
callHandler lr :: LogRecord
lr loggername :: String
loggername ht :: HandlerT
ht =
case HandlerT
ht of
HandlerT x :: a
x -> a -> LogRecord -> String -> IO ()
forall a. LogHandler a => a -> LogRecord -> String -> IO ()
System.Log.Handler.handle a
x LogRecord
lr String
loggername
handlerActions :: [HandlerT] -> LogRecord -> String -> [IO ()]
handlerActions :: [HandlerT] -> LogRecord -> String -> [IO ()]
handlerActions h :: [HandlerT]
h lr :: LogRecord
lr loggername :: String
loggername = (HandlerT -> IO ()) -> [HandlerT] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (LogRecord -> String -> HandlerT -> IO ()
callHandler LogRecord
lr String
loggername ) [HandlerT]
h
addHandler :: LogHandler a => a -> Logger -> Logger
addHandler :: a -> Logger -> Logger
addHandler h :: a
h l :: Logger
l= Logger
l{handlers :: [HandlerT]
handlers = (a -> HandlerT
forall a. LogHandler a => a -> HandlerT
HandlerT a
h) HandlerT -> [HandlerT] -> [HandlerT]
forall a. a -> [a] -> [a]
: (Logger -> [HandlerT]
handlers Logger
l)}
removeHandler :: Logger -> Logger
removeHandler :: Logger -> Logger
removeHandler l :: Logger
l =
case [HandlerT]
hs of [] -> Logger
l
_ -> Logger
l{handlers :: [HandlerT]
handlers = [HandlerT] -> [HandlerT]
forall a. [a] -> [a]
tail [HandlerT]
hs}
where
hs :: [HandlerT]
hs = Logger -> [HandlerT]
handlers Logger
l
setHandlers :: LogHandler a => [a] -> Logger -> Logger
setHandlers :: [a] -> Logger -> Logger
setHandlers hl :: [a]
hl l :: Logger
l =
Logger
l{handlers :: [HandlerT]
handlers = (a -> HandlerT) -> [a] -> [HandlerT]
forall a b. (a -> b) -> [a] -> [b]
map (\h :: a
h -> a -> HandlerT
forall a. LogHandler a => a -> HandlerT
HandlerT a
h) [a]
hl}
getLevel :: Logger -> Maybe Priority
getLevel :: Logger -> Maybe Priority
getLevel l :: Logger
l = Logger -> Maybe Priority
level Logger
l
setLevel :: Priority -> Logger -> Logger
setLevel :: Priority -> Logger -> Logger
setLevel p :: Priority
p l :: Logger
l = Logger
l{level :: Maybe Priority
level = Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
p}
clearLevel :: Logger -> Logger
clearLevel :: Logger -> Logger
clearLevel l :: Logger
l = Logger
l {level :: Maybe Priority
level = Maybe Priority
forall a. Maybe a
Nothing}
saveGlobalLogger :: Logger -> IO ()
saveGlobalLogger :: Logger -> IO ()
saveGlobalLogger l :: Logger
l = MVar LogTree -> (LogTree -> IO LogTree) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar LogTree
logTree
(\lt :: LogTree
lt -> LogTree -> IO LogTree
forall (m :: * -> *) a. Monad m => a -> m a
return (LogTree -> IO LogTree) -> LogTree -> IO LogTree
forall a b. (a -> b) -> a -> b
$ String -> Logger -> LogTree -> LogTree
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Logger -> String
name Logger
l) Logger
l LogTree
lt)
updateGlobalLogger :: String
-> (Logger -> Logger)
-> IO ()
updateGlobalLogger :: String -> (Logger -> Logger) -> IO ()
updateGlobalLogger ln :: String
ln func :: Logger -> Logger
func =
do Logger
l <- String -> IO Logger
getLogger String
ln
Logger -> IO ()
saveGlobalLogger (Logger -> Logger
func Logger
l)
removeAllHandlers :: IO ()
removeAllHandlers :: IO ()
removeAllHandlers =
MVar LogTree -> (LogTree -> IO LogTree) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar LogTree
logTree ((LogTree -> IO LogTree) -> IO ())
-> (LogTree -> IO LogTree) -> IO ()
forall a b. (a -> b) -> a -> b
$ \lt :: LogTree
lt -> do
let allHandlers :: [HandlerT]
allHandlers = (Logger -> [HandlerT] -> [HandlerT])
-> [HandlerT] -> LogTree -> [HandlerT]
forall a b k. (a -> b -> b) -> b -> Map k a -> b
mapFoldr (\l :: Logger
l r :: [HandlerT]
r -> [[HandlerT]] -> [HandlerT]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[HandlerT]
r, Logger -> [HandlerT]
handlers Logger
l]) [] LogTree
lt
(HandlerT -> IO ()) -> [HandlerT] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(HandlerT h :: a
h) -> a -> IO ()
forall a. LogHandler a => a -> IO ()
close a
h) [HandlerT]
allHandlers
LogTree -> IO LogTree
forall (m :: * -> *) a. Monad m => a -> m a
return (LogTree -> IO LogTree) -> LogTree -> IO LogTree
forall a b. (a -> b) -> a -> b
$ (Logger -> Logger) -> LogTree -> LogTree
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\l :: Logger
l -> Logger
l {handlers :: [HandlerT]
handlers = []}) LogTree
lt
mapFoldr :: (a -> b -> b) -> b -> Map.Map k a -> b
#if MIN_VERSION_containers(0,4,2)
mapFoldr :: (a -> b -> b) -> b -> Map k a -> b
mapFoldr = (a -> b -> b) -> b -> Map k a -> b
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr
#else
mapFoldr f z = foldr f z . Map.elems
#endif
traplogging :: String
-> Priority
-> String
-> IO a
-> IO a
traplogging :: String -> Priority -> String -> IO a -> IO a
traplogging logger :: String
logger priority' :: Priority
priority' desc :: String
desc action :: IO a
action =
let realdesc :: String
realdesc = case String
desc of
"" -> ""
x :: String
x -> String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": "
handler :: Control.Exception.SomeException -> IO a
handler :: SomeException -> IO a
handler e :: SomeException
e = do
String -> Priority -> String -> IO ()
logM String
logger Priority
priority' (String
realdesc String -> String -> String
forall a. [a] -> [a] -> [a]
++ (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))
SomeException -> IO a
forall a e. Exception e => e -> a
Control.Exception.throw SomeException
e
in
IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch IO a
action SomeException -> IO a
forall a. SomeException -> IO a
handler
split :: Eq a => [a] -> [a] -> [[a]]
split :: [a] -> [a] -> [[a]]
split _ [] = []
split delim :: [a]
delim str :: [a]
str =
let (firstline :: [a]
firstline, remainder :: [a]
remainder) = ([a] -> Bool) -> [a] -> ([a], [a])
forall a. ([a] -> Bool) -> [a] -> ([a], [a])
breakList ([a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
delim) [a]
str
in
[a]
firstline [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: case [a]
remainder of
[] -> []
x :: [a]
x -> if [a]
x [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
delim
then [] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: []
else [a] -> [a] -> [[a]]
forall a. Eq a => [a] -> [a] -> [[a]]
split [a]
delim
(Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
delim) [a]
x)
breakList :: ([a] -> Bool) -> [a] -> ([a], [a])
breakList :: ([a] -> Bool) -> [a] -> ([a], [a])
breakList func :: [a] -> Bool
func = ([a] -> Bool) -> [a] -> ([a], [a])
forall a. ([a] -> Bool) -> [a] -> ([a], [a])
spanList (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
func)
spanList :: ([a] -> Bool) -> [a] -> ([a], [a])
spanList :: ([a] -> Bool) -> [a] -> ([a], [a])
spanList _ [] = ([],[])
spanList func :: [a] -> Bool
func list :: [a]
list@(x :: a
x:xs :: [a]
xs) =
if [a] -> Bool
func [a]
list
then (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys,[a]
zs)
else ([],[a]
list)
where (ys :: [a]
ys,zs :: [a]
zs) = ([a] -> Bool) -> [a] -> ([a], [a])
forall a. ([a] -> Bool) -> [a] -> ([a], [a])
spanList [a] -> Bool
func [a]
xs