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,
stopLog,
scopeLog_,
scopeLog,
scoperLog
) where
import Prelude hiding (log)
import Control.Arrow
import qualified Control.Exception as E
import Control.Concurrent
import qualified Control.Concurrent.Async as A
import Control.Concurrent.MSem
import Control.DeepSeq
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.List
import qualified Data.Map as M
import Data.Maybe (catMaybes, isJust)
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 (),
logStop :: IO (),
logRules :: IO Rules }
noLog :: Log
noLog = Log post' (return ()) (return []) where
post' (EnterScope _ _) = return ()
post' (LeaveScope io) = io
post' (PostMessage _) = return ()
type RulesLoad = IO (IO Rules)
type ThreadMap = M.Map ThreadId (A.Async (), Chan (Maybe Command))
type FChan a = Chan (Maybe a)
writeFChan :: FChan a -> a -> IO ()
writeFChan ch = writeChan ch . Just
stopFChan :: FChan a -> IO ()
stopFChan ch = writeChan ch Nothing
getFChanContents :: FChan a -> IO [a]
getFChanContents = liftM (catMaybes . takeWhile isJust) . getChanContents
newLog :: RulesLoad -> [Logger] -> IO Log
newLog _ [] = return noLog
newLog rsInit ls = do
ch <- newChan :: IO (FChan (ThreadId, Command))
chOut <- newChan :: IO (FChan Command)
cts <- getFChanContents ch
msgs <- getFChanContents chOut
rs <- rsInit
r <- rs
let
process :: ThreadMap -> (ThreadId, Command) -> IO ThreadMap
process m (thId, cmd) = do
(thAsync, thChan) <- maybe newChild return $ M.lookup thId m
writeFChan thChan cmd
return $ M.insert thId (thAsync, thChan) m
stopChildren :: ThreadMap -> IO ()
stopChildren m = do
forM_ (M.elems m) $ \(thAsync, thChan) -> do
stopFChan thChan
A.wait thAsync
stopFChan chOut
newChild :: IO (A.Async (), FChan Command)
newChild = do
thChan <- newChan
thCts <- getFChanContents thChan
thAsync <- A.async $ mapM_ (writeFChan chOut) $
uncommand thCts
return (thAsync, 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
writeFChan ch (i, cmd)
p <- A.async $ void $ do
m <- foldM process M.empty cts
stopChildren m
mapM_ (forkIO . startLog) ls
return $ Log writeCommand (stopFChan ch >> A.wait p) rs
writeLog :: MonadIO m => Log -> Level -> Text -> m ()
writeLog (Log post _ _) l msg = liftIO $ do
tm <- getZonedTime
post $ PostMessage (Message tm l [] msg)
stopLog :: MonadIO m => Log -> m ()
stopLog (Log _ stop _) = liftIO stop
scopeLog_ :: (MonadIO m, MonadMask m) => Log -> Text -> m a -> m a
scopeLog_ (Log post _ getRules) s act = do
rs <- liftIO getRules
sem <- liftIO $ new (0 :: Integer)
bracket_
(liftIO $ post $ EnterScope s rs)
(liftIO $ post (LeaveScope $ signal sem) >> wait sem)
act
scopeLog :: (MonadIO m, MonadMask m) => Log -> Text -> m a -> m a
scopeLog l s act = scopeLog_ l s (catch act onError) where
onError :: (MonadIO m, MonadThrow m) => E.SomeException -> m a
onError e = do
writeLog l Error $ fromString $ "Scope leaves with exception: " ++ show e
throwM e
scoperLog :: (MonadIO m, MonadMask m) => Show a => Log -> Text -> m a -> m 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