module System.Logger
( Settings
, defSettings
, logLevel
, setLogLevel
, output
, setOutput
, format
, setFormat
, delimiter
, setDelimiter
, netstrings
, setNetStrings
, bufSize
, setBufSize
, name
, setName
, Level (..)
, Output (..)
, DateFormat
, iso8601UTC
, Logger
, new
, create
, level
, flush
, close
, clone
, settings
, log
, trace
, debug
, info
, warn
, err
, fatal
, module M
) where
import Prelude hiding (log)
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.UnixTime
import System.Date.Cache
import System.Environment (lookupEnv)
import System.Logger.Message as M
import System.Logger.Settings
import qualified System.Log.FastLogger as FL
data Logger = Logger
{ logger :: FL.LoggerSet
, settings :: Settings
, getDate :: IO (Msg -> Msg)
, closeDate :: Maybe DateCacheCloser
}
new :: MonadIO m => Settings -> m Logger
new s = liftIO $ do
n <- fmap (readNote "Invalid LOG_BUFFER") <$> lookupEnv "LOG_BUFFER"
l <- fmap (readNote "Invalid LOG_LEVEL") <$> lookupEnv "LOG_LEVEL"
e <- fmap (readNote "Invalid LOG_NETSTR") <$> lookupEnv "LOG_NETSTR"
g <- fn (output s) (fromMaybe (bufSize s) n)
c <- clockCache (format s)
let s' = setLogLevel (fromMaybe (logLevel s) l)
. setNetStrings (fromMaybe (netstrings s) e)
$ s
return $ Logger g s' (maybe (return id) (liftM msg) (fst <$> c)) (snd <$> c)
where
fn StdOut = FL.newStdoutLoggerSet
fn StdErr = FL.newStderrLoggerSet
fn (Path p) = flip FL.newFileLoggerSet p
clockCache "" = return Nothing
clockCache f = Just <$> clockDateCacher (DateCacheConf getUnixTime (fmt f))
fmt :: DateFormat -> UnixTime -> IO ByteString
fmt d = return . formatUnixTimeGMT (template d)
create :: MonadIO m => Output -> m Logger
create o = new $ setOutput o defSettings
readNote :: Read a => String -> String -> a
readNote m s = case reads s of
[(a, "")] -> a
_ -> error m
log :: MonadIO m => Logger -> Level -> (Msg -> Msg) -> m ()
log g l m = unless (level g > l) . liftIO $ putMsg g l m
trace, debug, info, warn, err, fatal :: MonadIO m => Logger -> (Msg -> Msg) -> m ()
trace g = log g Trace
debug g = log g Debug
info g = log g Info
warn g = log g Warn
err g = log g Error
fatal g = log g Fatal
clone :: Maybe Text -> Logger -> Logger
clone (Just n) g = g { settings = setName n (settings g) }
clone Nothing g = g
flush :: MonadIO m => Logger -> m ()
flush = liftIO . FL.flushLogStr . logger
close :: MonadIO m => Logger -> m ()
close g = liftIO $ do
fromMaybe (return ()) (closeDate g)
FL.rmLoggerSet (logger g)
level :: Logger -> Level
level = logLevel . settings
putMsg :: MonadIO m => Logger -> Level -> (Msg -> Msg) -> m ()
putMsg g l f = liftIO $ do
d <- getDate g
let n = netstrings $ settings g
let x = delimiter $ settings g
let s = nameMsg $ settings g
let m = render x n (d . lmsg l . s . f)
FL.pushLogStr (logger g) (FL.toLogStr m)
lmsg :: Level -> (Msg -> Msg)
lmsg Trace = msg (val "T")
lmsg Debug = msg (val "D")
lmsg Info = msg (val "I")
lmsg Warn = msg (val "W")
lmsg Error = msg (val "E")
lmsg Fatal = msg (val "F")