module System.Log.Simple.Base (
Level(..),
Politics(..), Rule(..), Rules,
defaultPolitics, debugPolitics, tracePolitics, silentPolitics, supressPolitics,
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.Concurrent.MSem
import Control.DeepSeq
import Control.Monad
import Data.List
import qualified Data.Map as M
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
supressPolitics :: Politics
supressPolitics = Politics Fatal 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
type Converter a = Message -> a
data Consumer a = Consumer {
withConsumer :: ((a -> IO ()) -> IO ()) -> IO () }
type Logger = Consumer Message
logger :: Converter a -> Consumer a -> Consumer Message
logger conv (Consumer withCons) = Consumer withCons' where
withCons' f = withCons $ \logMsg -> f (logMsg . conv)
data Log = Log {
logPost :: Command -> IO (),
logRules :: IO Rules }
noLog :: Log
noLog = Log (const (return ())) (return [])
type RulesLoad = IO (IO Rules)
newLog :: RulesLoad -> [Logger] -> IO Log
newLog _ [] = return noLog
newLog rsInit ls = do
ch <- newChan :: IO (Chan (ThreadId, Command))
chOut <- newChan :: IO (Chan Command)
cts <- getChanContents ch
msgs <- getChanContents chOut
rs <- rsInit
r <- rs
let
process :: M.Map ThreadId (Chan Command) -> (ThreadId, Command) -> IO (M.Map ThreadId (Chan Command))
process m (thId, cmd) = do
thChan <- maybe newThreadChan return $ M.lookup thId m
writeChan thChan cmd
return $ M.insert thId thChan m
newThreadChan :: IO (Chan Command)
newThreadChan = do
thChan <- newChan
thCts <- getChanContents thChan
_ <- forkIO $ mapM_ (writeChan chOut) $ uncommand thCts
return thChan
uncommand :: [Command] -> [Command]
uncommand = flatten . rules r [] . entries
tryLog :: (Message -> IO ()) -> Command -> IO ()
tryLog _ (EnterScope _ _) = return ()
tryLog logMsg (PostMessage m) = E.handle onError (m `deepseq` logMsg m) where
onError :: E.SomeException -> IO ()
onError e = E.handle ignoreError $ do
tm <- getZonedTime
logMsg $ Message tm Error ["*"] $ fromString $ "Exception during logging message: " ++ show e
ignoreError :: E.SomeException -> IO ()
ignoreError _ = return ()
tryLog _ (LeaveScope io) = io
startLog :: Logger -> IO ()
startLog (Consumer withCons) = withCons $ \logMsg -> do
mapM_ (tryLog logMsg) msgs
writeCommand :: Command -> IO ()
writeCommand cmd = do
i <- myThreadId
writeChan ch (i, cmd)
void $ forkIO $ void $ foldM process M.empty cts
mapM_ (forkIO . startLog) ls
return $ Log writeCommand 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
sem <- new (0 :: Integer)
E.bracket_ (post $ EnterScope s rs) (post (LeaveScope $ signal sem) >> wait sem) 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 (IO ()) [Entry]
foldEntry :: (Message -> a) -> (Text -> Rules -> IO () -> [a] -> a) -> Entry -> a
foldEntry r _ (Entry m) = r m
foldEntry r s (Scope t rs io es) = s t rs io (map (foldEntry r s) es)
data Command =
EnterScope Text Rules |
LeaveScope (IO ()) |
PostMessage Message
entries :: [Command] -> [Entry]
entries = fst . fst . entries' where
entries' :: [Command] -> (([Entry], IO ()), [Command])
entries' [] = (([], return ()), [])
entries' (EnterScope s scopeRules : cs) = first (first (Scope s scopeRules io rs :)) $ entries' cs' where
((rs, io), cs') = entries' cs
entries' (LeaveScope io : cs) = (([], io), cs)
entries' (PostMessage m : cs) = first (first (Entry m :)) $ entries' cs
flatten :: [Entry] -> [Command]
flatten = concatMap $ foldEntry postMessage flatScope where
postMessage :: Message -> [Command]
postMessage m = [PostMessage m]
flatScope :: Text -> Rules -> IO () -> [[Command]] -> [Command]
flatScope s rs io cs = EnterScope s rs : (map (addScope s) (concat cs) ++ [LeaveScope io])
addScope :: Text -> Command -> Command
addScope s (PostMessage (Message tm l p str)) = PostMessage $ Message tm l (s : p) str
addScope _ m = m
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 io es) = Scope t scopeRules io $ 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