Add 'System.Logger.Message'. (38e684f1) · Commits · Yuanle Song / tinylog

src/System/Logger.hs

+47 −41

Original line number	Diff line number	Diff line
		@@ -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"

src/System/Logger/Message.hs

0 → 100644

+32 −0

Original line number	Diff line number	Diff line
		{-# 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

src/System/LoggerT.hs

+20 −9

Original line number	Diff line number	Diff line
		@@ -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

tinylog.cabal

+2 −1

Original line number	Diff line number	Diff line
		@@ -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