From 38e684f19045cce239da80fb4743eb67cf68302d Mon Sep 17 00:00:00 2001 From: Toralf Wittner Date: Thu, 9 Jan 2014 18:46:35 +0100 Subject: [PATCH] Add 'System.Logger.Message'. Instead of using plain 'ByteString's use combinators. --- src/System/Logger.hs | 88 +++++++++++++++++++----------------- src/System/Logger/Message.hs | 32 +++++++++++++ src/System/LoggerT.hs | 29 ++++++++---- tinylog.cabal | 3 +- 4 files changed, 101 insertions(+), 51 deletions(-) create mode 100644 src/System/Logger/Message.hs diff --git a/src/System/Logger.hs b/src/System/Logger.hs index 1dfc1eb..bc8d5e5 100644 --- a/src/System/Logger.hs +++ b/src/System/Logger.hs @@ -9,7 +9,7 @@ module System.Logger , Output (..) , Settings (..) , Logger - , Format + , DateFormat , new , create @@ -35,6 +35,7 @@ module System.Logger , fatalM , iso8601UTC + , module M ) where @@ -47,9 +48,10 @@ import Data.ByteString.Char8 (pack) import Data.Maybe (fromMaybe) import Data.Monoid import Data.String -import Data.UnixTime hiding (Format) +import Data.UnixTime import System.Date.Cache import System.Environment (lookupEnv) +import System.Logger.Message as M import qualified System.Log.FastLogger as FL @@ -62,27 +64,18 @@ data Level | Fatal deriving (Eq, Ord, Read, Show) -l2b :: Level -> ByteString -l2b Trace = "TRACE" -l2b Debug = "DEBUG" -l2b Info = "INFO" -l2b Warn = "WARN" -l2b Error = "ERROR" -l2b Fatal = "FATAL" -{-# INLINE l2b #-} - data Logger = Logger - { _logger :: !FL.LoggerSet - , _getDate :: !DateCacheGetter - , _closeDate :: !DateCacheCloser - , _settings :: !Settings + { _logger :: FL.LoggerSet + , _settings :: Settings + , _getDate :: Maybe DateCacheGetter + , _closeDate :: Maybe DateCacheCloser } data Settings = Settings - { logLevel :: !Level - , output :: !Output - , format :: !Format - , delimiter :: !ByteString + { logLevel :: Level + , output :: Output + , format :: DateFormat + , delimiter :: ByteString } deriving (Eq, Ord, Show) data Output @@ -90,14 +83,14 @@ data Output | Path FilePath deriving (Eq, Ord, Show) -newtype Format = Format +newtype DateFormat = DateFormat { template :: ByteString } deriving (Eq, Ord, Show) -instance IsString Format where - fromString = Format . pack +instance IsString DateFormat where + fromString = DateFormat . pack -iso8601UTC :: Format +iso8601UTC :: DateFormat iso8601UTC = "%Y-%0m-%0dT%0H:%0M:%0SZ" defSettings :: Settings @@ -105,36 +98,39 @@ defSettings = Settings Debug StdOut iso8601UTC ", " new :: MonadIO m => Settings -> m Logger new s = liftIO $ do - n <- fmap (readNote "Invalid LOG_BUFFER.") <$> lookupEnv "LOG_BUFFER" + n <- fmap (readNote "Invalid LOG_BUFFER") <$> lookupEnv "LOG_BUFFER" + l <- fmap (readNote "Invalid LOG_LEVEL") <$> lookupEnv "LOG_LEVEL" g <- FL.newLoggerSet (fromMaybe FL.defaultBufSize n) (mapOut $ output s) - (x, y) <- clockDateCacher $ DateCacheConf getUnixTime fmt - return $ Logger g x y s + c <- clockCache (format s) + let s' = s { logLevel = fromMaybe (logLevel s) l } + return $ Logger g s' (fst <$> c) (snd <$> c) where mapOut StdOut = Nothing mapOut (Path p) = Just p - fmt :: UnixTime -> IO ByteString - fmt = return . formatUnixTimeGMT (template $ format s) + 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 p = liftIO $ do - ll <- fmap (readNote "Invalid LOG_LEVEL.") <$> lookupEnv "LOG_LEVEL" - new defSettings { logLevel = fromMaybe Debug ll, output = p } +create p = new defSettings { output = p } readNote :: Read a => String -> String -> a readNote m s = case reads s of [(a, "")] -> a _ -> error m -log :: MonadIO m => Logger -> Level -> ByteString -> m () +log :: MonadIO m => Logger -> Level -> Builder -> m () log g l m = unless (level g > l) . liftIO $ putMsg g l m {-# INLINE log #-} -logM :: MonadIO m => Logger -> Level -> m ByteString -> m () +logM :: MonadIO m => Logger -> Level -> m Builder -> m () logM g l m = unless (level g > l) $ m >>= putMsg g l {-# INLINE logM #-} -trace, debug, info, warn, err, fatal :: MonadIO m => Logger -> ByteString -> m () +trace, debug, info, warn, err, fatal :: MonadIO m => Logger -> Builder -> m () trace g = log g Trace debug g = log g Debug info g = log g Info @@ -148,7 +144,7 @@ fatal g = log g Fatal {-# INLINE err #-} {-# INLINE fatal #-} -traceM, debugM, infoM, warnM, errM, fatalM :: MonadIO m => Logger -> m ByteString -> m () +traceM, debugM, infoM, warnM, errM, fatalM :: MonadIO m => Logger -> m Builder -> m () traceM g = logM g Trace debugM g = logM g Debug infoM g = logM g Info @@ -167,16 +163,26 @@ flush = liftIO . FL.flushLogStr . _logger close :: MonadIO m => Logger -> m () close g = liftIO $ do - _closeDate g + fromMaybe (return ()) (_closeDate g) FL.rmLoggerSet (_logger g) level :: Logger -> Level level = logLevel . _settings {-# INLINE level #-} -putMsg :: MonadIO m => Logger -> Level -> ByteString -> m () -putMsg g l m = liftIO $ do - let x = delimiter $ _settings g - d <- _getDate g - FL.pushLogStr (_logger g) . FL.toLogStr $ mconcat [d, x, l2b l, x, m, "\n"] {-# INLINE putMsg #-} +putMsg :: MonadIO m => Logger -> Level -> Builder -> m () +putMsg g l f = liftIO $ do + let x = delimiter $ _settings g + let m = render x (msg (l2b l) . f) + d <- maybe (return "") (fmap (<> x)) (_getDate g) + FL.pushLogStr (_logger g) $ FL.toLogStr (d <> m <> "\n") + where + l2b :: Level -> ByteString + l2b Trace = "T" + l2b Debug = "D" + l2b Info = "I" + l2b Warn = "W" + l2b Error = "E" + l2b Fatal = "F" + diff --git a/src/System/Logger/Message.hs b/src/System/Logger/Message.hs new file mode 100644 index 0000000..6e6f82c --- /dev/null +++ b/src/System/Logger/Message.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Logger.Message where + +import Data.ByteString (ByteString) +import Data.List (intersperse) +import Data.Monoid + +type Builder = Msg -> Msg + +newtype Msg = Msg + { parts :: [ByteString] + } deriving (Eq, Ord, Show) + +empty :: Msg +empty = Msg [] + +set :: ByteString -> Builder +set b = const $ Msg [b] + +msg :: ByteString -> Builder +msg p (Msg m) = Msg (p:m) + +msg' :: ByteString -> Builder +msg' "" m = m +msg' p (Msg m) = Msg (p:m) + +field :: ByteString -> ByteString -> Builder +field k v (Msg m) = Msg (k <> "=" <> v : m) + +render :: ByteString -> Builder -> ByteString +render s f = mconcat . intersperse s . parts $ f empty diff --git a/src/System/LoggerT.hs b/src/System/LoggerT.hs index c97aa1c..3c1f5b8 100644 --- a/src/System/LoggerT.hs +++ b/src/System/LoggerT.hs @@ -8,9 +8,20 @@ module System.LoggerT ( LoggerT , MonadLogger (..) - , L.Logger - , L.Level (..) , runLoggerT + + , L.Level (..) + , L.Output (..) + , L.Settings (..) + , L.Logger + , L.DateFormat + + , L.new + , L.create + , L.defSettings + , L.iso8601UTC + + , module M ) where @@ -19,8 +30,8 @@ import Control.Applicative import Control.Monad.Reader import Control.Monad.Catch import Data.ByteString (ByteString) -import Data.Monoid import System.Logger (Logger, Level (..)) +import System.Logger.Message as M import qualified Data.ByteString as BS import qualified System.Logger as L @@ -42,19 +53,19 @@ class MonadIO m => MonadLogger m where prefix :: m ByteString prefix = return BS.empty - log :: Level -> ByteString -> m () + log :: Level -> Builder -> m () log l m = do g <- logger p <- prefix - L.log g l (p <> m) + L.log g l (msg' p . m) - logM :: Level -> m ByteString -> m () + logM :: Level -> m Builder -> m () logM l m = do g <- logger p <- prefix - L.logM g l ((<> p) `liftM` m) + L.logM g l ((msg' p .) `liftM` m) - trace, debug, info, warn, err, fatal :: ByteString -> m () + trace, debug, info, warn, err, fatal :: Builder -> m () trace = log Trace debug = log Debug info = log Info @@ -62,7 +73,7 @@ class MonadIO m => MonadLogger m where err = log Error fatal = log Fatal - traceM, debugM, infoM, warnM, errM, fatalM :: m ByteString -> m () + traceM, debugM, infoM, warnM, errM, fatalM :: m Builder -> m () traceM = logM Trace debugM = logM Debug infoM = logM Info diff --git a/tinylog.cabal b/tinylog.cabal index 039fd41..eaf642a 100644 --- a/tinylog.cabal +++ b/tinylog.cabal @@ -25,6 +25,7 @@ library exposed-modules: System.Logger + , System.Logger.Message , System.LoggerT build-depends: @@ -32,7 +33,7 @@ library , bytestring >= 0.10 , date-cache >= 0.3 , exceptions >= 0.3 - , fast-logger == 2.1.* + , fast-logger >= 2.1.2 && < 2.2 , mtl >= 2.1 , transformers >= 0.3 , unix-time >= 0.1 -- GitLab