module System.Log.Simple.Config (
parseRule, parseRules,
parseRule_, parseRules_,
constant, mvar, fileCfg
) where
import Control.Arrow
import Control.Concurrent
import Control.Exception
import Control.Monad.Except
import Control.Monad.Writer
import Data.Either
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.Log.Simple.Base
parseRule :: Text -> Writer [Text] Rule
parseRule txt = do
r' <- parseUses . T.strip . T.drop 1 $ r
return $ T.strip p %= r'
where
(p, r) = T.break (== ':') txt
parseUses uses = do
tell $ map T.pack fails
return $ foldr (.) id oks
where
(fails, oks) = (lefts &&& rights) . map (parseUse . T.strip) . T.split (== ',') $ uses
parseUse u = case map T.strip . T.words $ u of
["low", v] -> low <$> value v
["high", v] -> high <$> value v
["set", l, h] -> politics <$> value l <*> value h
["use", v] -> use <$> predefined v
_ -> throwError $ concat ["Unable to parse: ", T.unpack u]
value v = maybe noValue return $ lookup v values where
noValue = throwError $ concat ["Invalid value: ", T.unpack v]
predefined v = maybe noPredefined return $ lookup v predefineds where
noPredefined = throwError $ concat ["Invalid predefined: ", T.unpack v]
parseRules :: Text -> Writer [Text] Rules
parseRules = mapM parseRule . filter (not . T.null . T.strip) . T.lines
parseRule_ :: Text -> Rule
parseRule_ = fst . runWriter . parseRule
parseRules_ :: Text -> Rules
parseRules_ = fst . runWriter . parseRules
values :: [(Text, Level)]
values = [
("trace", Trace),
("debug", Debug),
("info", Info),
("warning", Warning),
("error", Error),
("fatal", Fatal)]
predefineds :: [(Text, Politics)]
predefineds = [
("default", defaultPolitics),
("debug", debugPolitics),
("trace", tracePolitics),
("silent", silentPolitics),
("supress", supressPolitics)]
constant :: Rules -> IO (IO Rules)
constant = return . return
mvar :: MVar Rules -> IO (IO Rules)
mvar = return . readMVar
fileCfg :: FilePath -> Int -> IO (IO Rules)
fileCfg f seconds = do
rs <- readRules
var <- newMVar rs
when (seconds /= 0) $ void $ forkIO $ forever $ handle ignoreIO $ do
threadDelay (seconds * 1000000)
rs' <- readRules
void $ swapMVar var rs'
mvar var
where
readRules = do
cts <- T.readFile f
return . parseRules_ $ cts
ignoreIO :: IOException -> IO ()
ignoreIO _ = return ()