module System.Log.Base (
Level(..),
Politics(..), Rule(..), Rules,
defaultPolitics, debugPolitics, tracePolitics, silentPolitics,
rule, absolute, relative, child, root, path,
(%=),
politics, use, low, high,
Message(..),
Converter(..), Consumer(..),
Entry(..), Command(..),
entries, flatten, rules,
Logger(..), logger,
RulesLoad,
Log(..), noLog,
newLog,
writeLog,
scopeLog_,
scopeLog,
scoperLog
) where
import Prelude hiding (log)
import Control.Arrow
import qualified Control.Exception as E
import Control.Concurrent
import Control.DeepSeq
import Control.Monad
import Data.List
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time
import Data.String
data Level = Trace | Debug | Info | Warning | Error | Fatal
deriving (Eq, Ord, Read, Show, Enum, Bounded)
data Politics = Politics {
politicsLow :: Level,
politicsHigh :: Level }
deriving (Eq, Ord, Read, Show)
defaultPolitics :: Politics
defaultPolitics = Politics Info Warning
debugPolitics :: Politics
debugPolitics = Politics Debug Info
tracePolitics :: Politics
tracePolitics = Politics Trace Info
silentPolitics :: Politics
silentPolitics = Politics Info Fatal
data Rule = Rule {
rulePath :: [Text] -> Bool,
rulePolitics :: Politics -> Politics }
type Rules = [Rule]
rule :: ([Text] -> Bool) -> (Politics -> Politics) -> Rule
rule = Rule
absolute :: [Text] -> [Text] -> Bool
absolute p = (== p)
relative :: [Text] -> [Text] -> Bool
relative p = (p `isSuffixOf`)
child :: ([Text] -> Bool) -> [Text] -> Bool
child _ [] = False
child r (_:ps) = r ps
root :: [Text] -> Bool
root = null
path :: Text -> ([Text] -> Bool)
path "/" = root
path p = path' $ T.split (== '/') p where
path' ps
| null ps = const False
| T.null (head ps) && T.null (last ps) = child . absolute . init . tail $ ps
| T.null (head ps) = absolute . tail $ ps
| T.null (last ps) = child . relative . init $ ps
| otherwise = relative ps
(%=) :: Text -> (Politics -> Politics) -> Rule
p %= r = rule (path p) r
politics :: Level -> Level -> Politics -> Politics
politics l h _ = Politics l h
use :: Politics -> Politics -> Politics
use p _ = p
low :: Level -> Politics -> Politics
low l (Politics _ h) = Politics l h
high :: Level -> Politics -> Politics
high h (Politics l _) = Politics l h
data Message = Message {
messageTime :: ZonedTime,
messageLevel :: Level,
messagePath :: [Text],
messageText :: Text }
deriving (Read, Show)
instance NFData Message where
rnf (Message t l p m) = t `seq` l `seq` rnf p `seq` rnf m
data Converter a = Converter {
initial :: a,
convert :: Message -> a }
data Consumer a = Consumer {
consumerNew :: Bool,
consume :: a -> IO (),
consumerClose :: IO () }
data Logger = Logger {
loggerLog :: Message -> IO (),
loggerClose :: IO () }
logger :: Converter a -> IO (Consumer a) -> IO Logger
logger converter consumer = do
c <- consumer
when (consumerNew c) $ consume c (initial converter)
return $ Logger (consume c . convert converter) (consumerClose c)
data Log = Log {
logPost :: Command -> IO (),
logRules :: IO Rules }
noLog :: Log
noLog = Log (const (return ())) (return [])
type RulesLoad = IO (IO Rules)
newLog :: RulesLoad -> [IO Logger] -> IO Log
newLog _ [] = return noLog
newLog rsInit ls = do
ch <- newChan
cts <- getChanContents ch
rs <- rsInit
r <- rs
let
msgs = flatten . rules r [] . entries $ cts
loggerLog' l m = E.handle onError (m `deepseq` loggerLog l m) where
onError :: E.SomeException -> IO ()
onError e = E.handle ignoreError $ do
tm <- getZonedTime
loggerLog l $ Message tm Error ["*"] $ fromString $ "Exception during logging message: " ++ show e
ignoreError :: E.SomeException -> IO ()
ignoreError _ = return ()
startLog l = forkIO $ E.bracket l loggerClose rootScope where
rootScope l' = mapM_ (loggerLog' l') msgs
mapM_ startLog ls
return $ Log (writeChan ch) rs
writeLog :: Log -> Level -> Text -> IO ()
writeLog (Log post _) l msg = do
tm <- getZonedTime
post $ PostMessage (Message tm l [] msg)
scopeLog_ :: Log -> Text -> IO a -> IO a
scopeLog_ (Log post getRules) s act = do
rs <- getRules
E.bracket_ (post $ EnterScope s rs) (post LeaveScope) act
scopeLog :: Log -> Text -> IO a -> IO a
scopeLog l s act = scopeLog_ l s (E.catch act onError) where
onError :: E.SomeException -> IO a
onError e = do
writeLog l Error $ fromString $ "Scope leaves with exception: " ++ show e
E.throwIO e
scoperLog :: Show a => Log -> Text -> IO a -> IO a
scoperLog l s act = do
r <- scopeLog l s act
writeLog l Trace $ T.concat ["Scope ", s, " leaves with result: ", fromString $ show r]
return r
data Entry =
Entry Message |
Scope Text Rules [Entry]
foldEntry :: (Message -> a) -> (Text -> Rules -> [a] -> a) -> Entry -> a
foldEntry r _ (Entry m) = r m
foldEntry r s (Scope t rs es) = s t rs (map (foldEntry r s) es)
data Command =
EnterScope Text Rules |
LeaveScope |
PostMessage Message
entries :: [Command] -> [Entry]
entries = fst . entries' where
entries' [] = ([], [])
entries' (EnterScope s scopeRules : cs) = first (Scope s scopeRules rs :) $ entries' cs' where
(rs, cs') = entries' cs
entries' (LeaveScope : cs) = ([], cs)
entries' (PostMessage m : cs) = first (Entry m :) $ entries' cs
flatten :: [Entry] -> [Message]
flatten = concatMap $ foldEntry return (\s _ ms -> map (addScope s) (concat ms)) where
addScope s (Message tm l p str) = Message tm l (s : p) str
rules :: Rules -> [Text] -> [Entry] -> [Entry]
rules rs rpath = map untraceScope . concatEntries . first (partition isNotTrace) . break isError where
untraceScope (Entry msg) = Entry msg
untraceScope (Scope t scopeRules es) = Scope t scopeRules $ rules scopeRules (t : rpath) es
ps = apply rs (reverse rpath) defaultPolitics
concatEntries ((x, y), z) = x ++ if null z then [] else y ++ z
isError = onLevel False (> politicsHigh ps)
isNotTrace = onLevel True (>= politicsLow ps)
onLevel :: a -> (Level -> a) -> Entry -> a
onLevel v _ (Scope _ _ _) = v
onLevel _ f (Entry (Message _ l _ _)) = f l
apply :: Rules -> [Text] -> Politics -> Politics
apply rs = foldr (.) id . map applier . reverse . inits where
applier :: [Text] -> Politics -> Politics
applier spath = foldr (.) id . map rulePolitics . filter (`rulePath` spath) $ rs