Merge branch 'custom-format' into 'develop' (a0bd8eb2) · Commits · Yuanle Song / tinylog

bench/Bench.hs

+47 −20

Original line number	Original line	Diff line number	Diff line
	@@ -2,6 +2,7 @@
	-- License, v. 2.0. If a copy of the MPL was not distributed with this		-- License, v. 2.0. If a copy of the MPL was not distributed with this
	-- file, You can obtain one at http://mozilla.org/MPL/2.0/.		-- file, You can obtain one at http://mozilla.org/MPL/2.0/.

			{-# LANGUAGE BangPatterns #-}
	{-# LANGUAGE OverloadedStrings #-}		{-# LANGUAGE OverloadedStrings #-}

	module Main (main) where		module Main (main) where
	@@ -9,44 +10,70 @@ module Main (main) where
	import Criterion		import Criterion
	import Criterion.Main		import Criterion.Main
	import Data.Int		import Data.Int
	import System.Logger.Message		import System.Logger

			import qualified Data.ByteString.Builder as B
	import qualified Data.ByteString.Lazy as L		import qualified Data.ByteString.Lazy as L

	main :: IO ()		main :: IO ()
	main = defaultMain		main = defaultMain
	[ bgroup "direct"		[ bgroup "direct"
	[ bench "msg/8" (whnf (f False) 8)		[ bench "msg/8" (whnf (f renderDefault) 8)
	, bench "msg/16" (whnf (f False) 16)		, bench "msg/16" (whnf (f renderDefault) 16)
	, bench "msg/32" (whnf (f False) 32)		, bench "msg/32" (whnf (f renderDefault) 32)
	]		]
	, bgroup "netstr"		, bgroup "netstr"
	[ bench "msg/8" (whnf (f True) 8)		[ bench "msg/8" (whnf (f renderNetstr) 8)
	, bench "msg/16" (whnf (f True) 16)		, bench "msg/16" (whnf (f renderNetstr) 16)
	, bench "msg/32" (whnf (f True) 32)		, bench "msg/32" (whnf (f renderNetstr) 32)
			]
			, bgroup "custom"
			[ bench "msg/8" (whnf (f renderCustom) 8)
			, bench "msg/16" (whnf (f renderCustom) 16)
			, bench "msg/32" (whnf (f renderCustom) 32)
	]		]
	, bgroup "direct"		, bgroup "direct"
	[ bench "field/8" (whnf (g False) 8)		[ bench "field/8" (whnf (g renderDefault) 8)
	, bench "field/16" (whnf (g False) 16)		, bench "field/16" (whnf (g renderDefault) 16)
	, bench "field/32" (whnf (g False) 32)		, bench "field/32" (whnf (g renderDefault) 32)
	]		]
	, bgroup "netstr"		, bgroup "netstr"
	[ bench "field/8" (whnf (g True) 8)		[ bench "field/8" (whnf (g renderNetstr) 8)
	, bench "field/16" (whnf (g True) 16)		, bench "field/16" (whnf (g renderNetstr) 16)
	, bench "field/32" (whnf (g True) 32)		, bench "field/32" (whnf (g renderNetstr) 32)
			]
			, bgroup "custom"
			[ bench "field/8" (whnf (g renderCustom) 8)
			, bench "field/16" (whnf (g renderCustom) 16)
			, bench "field/32" (whnf (g renderCustom) 32)
	]		]
	]		]

	f :: Bool -> Int -> Int64		f :: Renderer -> Int -> Int64
	f b n = L.length		f r n = L.length
	. render ", " b		. render (r ", " iso8601UTC Trace)
	. foldr1 (.)		. foldr1 (.)
	. replicate n		. replicate n
	$ msg (val "hello world" +++ (10000 :: Int) +++ (-42 :: Int64))		$ msg (val "hello world" +++ (10000 :: Int) +++ (-42 :: Int64))

	g :: Bool -> Int -> Int64		g :: Renderer -> Int -> Int64
	g b n = L.length		g r n = L.length
	. render ", " b		. render (r ", " iso8601UTC Trace)
	. foldr1 (.)		. foldr1 (.)
	. replicate n		. replicate n
	$ "key" .= (val "hello world" +++ (10000 :: Int) +++ (-42 :: Int64))		$ "key" .= (val "hello world" +++ (10000 :: Int) +++ (-42 :: Int64))


			renderCustom :: Renderer
			renderCustom s _ _ = encAll mempty
			where
			encAll !acc [] = acc
			encAll !acc (b:[]) = acc <> encOne b
			encAll !acc (b:bb) = encAll (acc <> encOne b <> sep) bb

			encOne (Bytes b) = builderBytes b
			encOne (Field k v) = builderBytes k <> eq <> quo <> builderBytes v <> quo

			eq = B.char8 '='
			quo = B.char8 '"'
			sep = B.byteString s

src/System/Logger.hs

+15 −7

Original line number	Original line	Diff line number	Diff line
	@@ -21,18 +21,24 @@ module System.Logger
	, setFormat		, setFormat
	, delimiter		, delimiter
	, setDelimiter		, setDelimiter
	, netstrings
	, setNetStrings		, setNetStrings
			, setRendererDefault
			, setRendererNetstr
			, renderDefault
			, renderNetstr
	, bufSize		, bufSize
	, setBufSize		, setBufSize
	, name		, name
	, setName		, setName
			, setRenderer
			, renderer

	-- * Type definitions		-- * Type definitions
	, Logger		, Logger
	, Level (..)		, Level (..)
	, Output (..)		, Output (..)
	, DateFormat (..)		, DateFormat (..)
			, Renderer
	, iso8601UTC		, iso8601UTC

	-- * Core API		-- * Core API
	@@ -63,7 +69,7 @@ import Data.Maybe (fromMaybe)
	import Data.Text (Text)		import Data.Text (Text)
	import Data.UnixTime		import Data.UnixTime
	import System.Environment (lookupEnv)		import System.Environment (lookupEnv)
	import System.Logger.Message as M		import System.Logger.Message as M hiding (renderDefault_, renderNetstr_)
	import System.Logger.Settings		import System.Logger.Settings
	import Prelude hiding (log)		import Prelude hiding (log)

	@@ -109,7 +115,7 @@ new s = liftIO $ do
	!m <- fromMaybe "[]" <$> lookupEnv "LOG_LEVEL_MAP"		!m <- fromMaybe "[]" <$> lookupEnv "LOG_LEVEL_MAP"
	let !k = logLevelMap s `mergeWith` m		let !k = logLevelMap s `mergeWith` m
	let !s' = setLogLevel (fromMaybe (logLevel s) l)		let !s' = setLogLevel (fromMaybe (logLevel s) l)
	. setNetStrings (fromMaybe (netstrings s) e)		. setNetStrings (fromMaybe False e)
	. setLogLevelMap k		. setLogLevelMap k
	$ s		$ s
	g <- fn (output s) (fromMaybe (bufSize s) n)		g <- fn (output s) (fromMaybe (bufSize s) n)
	@@ -182,10 +188,12 @@ level = logLevel . settings
	putMsg :: MonadIO m => Logger -> Level -> (Msg -> Msg) -> m ()		putMsg :: MonadIO m => Logger -> Level -> (Msg -> Msg) -> m ()
	putMsg g l f = liftIO $ do		putMsg g l f = liftIO $ do
	d <- getDate g		d <- getDate g
	let n = netstrings $ settings g		let r = renderer $ settings g
	let x = delimiter $ settings g		let x = delimiter $ settings g
	let s = nameMsg $ settings g		let s = nameMsg $ settings g
	let m = render x n (d . lmsg l . s . f)		let df = fromMaybe iso8601UTC . format $ settings g
			let ll = logLevel $ settings g
			let m = render (r x df ll) (d . lmsg l . s . f)
	FL.pushLogStr (logger g) (FL.toLogStr m)		FL.pushLogStr (logger g) (FL.toLogStr m)

	lmsg :: Level -> (Msg -> Msg)		lmsg :: Level -> (Msg -> Msg)

src/System/Logger/Class.hs

+2 −1

Original line number	Original line	Diff line number	Diff line
	@@ -16,12 +16,13 @@ module System.Logger.Class
	, L.setFormat		, L.setFormat
	, L.delimiter		, L.delimiter
	, L.setDelimiter		, L.setDelimiter
	, L.netstrings
	, L.setNetStrings		, L.setNetStrings
	, L.bufSize		, L.bufSize
	, L.setBufSize		, L.setBufSize
	, L.name		, L.name
	, L.setName		, L.setName
			, L.setRenderer
			, L.renderer

	, L.Level (..)		, L.Level (..)
	, L.Output (..)		, L.Output (..)

src/System/Logger/Message.hs

+30 −17

Original line number	Original line	Diff line number	Diff line
	@@ -20,6 +20,7 @@ module System.Logger.Message
	( ToBytes (..)		( ToBytes (..)
	, Msg		, Msg
	, Builder		, Builder
			, Element (..)
	, msg		, msg
	, field		, field
	, (.=)		, (.=)
	@@ -27,7 +28,11 @@ module System.Logger.Message
	, (~~)		, (~~)
	, val		, val
	, eval		, eval
			, builderSize
			, builderBytes
	, render		, render
			, renderDefault_
			, renderNetstr_
	) where		) where

	#if MIN_VERSION_base(4,9,0)		#if MIN_VERSION_base(4,9,0)
	@@ -81,6 +86,12 @@ instance Monoid Builder where
	eval :: Builder -> L.ByteString		eval :: Builder -> L.ByteString
	eval (Builder n b) = B.toLazyByteStringWith (B.safeStrategy n 256) L.empty b		eval (Builder n b) = B.toLazyByteStringWith (B.safeStrategy n 256) L.empty b

			builderSize :: Builder -> Int
			builderSize (Builder n _) = n

			builderBytes :: Builder -> B.Builder
			builderBytes (Builder _ b) = b

	-- \| Convert some value to a 'Builder'.		-- \| Convert some value to a 'Builder'.
	class ToBytes a where		class ToBytes a where
	bytes :: a -> Builder		bytes :: a -> Builder
	@@ -153,24 +164,14 @@ infixr 6 +++
	val :: ByteString -> Builder		val :: ByteString -> Builder
	val = bytes		val = bytes

	-- \| Intersperse parts of the log message with the given delimiter and		-- \| Construct elements, call a renderer, and run the whole builder
	-- render the whole builder into a 'L.ByteString'.		-- into a 'L.ByteString'.
	--		render :: ([Element] -> B.Builder) -> (Msg -> Msg) -> L.ByteString
	-- If the second parameter is set to @True@, netstrings encoding is used for		render f m = finish . f . elements . m $ empty
	-- the message elements. Cf. <http://cr.yp.to/proto/netstrings.txt> for
	-- details.
	render :: ByteString -> Bool -> (Msg -> Msg) -> L.ByteString
	render _ True m = finish . encAll mempty . elements . m $ empty
	where
	encAll !acc [] = acc
	encAll !acc (b:bb) = encAll (acc <> encOne b) bb

	encOne (Bytes e) = netstr e
	encOne (Field k v) = netstr k <> eq <> netstr v

	eq = B.byteString "1:=,"

	render s False m = finish . encAll mempty . elements . m $ empty		-- \| See 'renderDefault'.
			renderDefault_ :: ByteString -> [Element] -> B.Builder
			renderDefault_ s = encAll mempty
	where		where
	encAll !acc [] = acc		encAll !acc [] = acc
	encAll !acc (b:[]) = acc <> encOne b		encAll !acc (b:[]) = acc <> encOne b
	@@ -182,6 +183,18 @@ render s False m = finish . encAll mempty . elements . m $ empty
	eq = B.char8 '='		eq = B.char8 '='
	sep = B.byteString s		sep = B.byteString s

			-- \| See 'renderNetstr'.
			renderNetstr_ :: [Element] -> B.Builder
			renderNetstr_ = encAll mempty
			where
			encAll !acc [] = acc
			encAll !acc (b:bb) = encAll (acc <> encOne b) bb

			encOne (Bytes e) = netstr e
			encOne (Field k v) = netstr k <> eq <> netstr v

			eq = B.byteString "1:=,"

	finish :: B.Builder -> L.ByteString		finish :: B.Builder -> L.ByteString
	finish = B.toLazyByteStringWith (B.untrimmedStrategy 256 256) "\n"		finish = B.toLazyByteStringWith (B.untrimmedStrategy 256 256) "\n"

src/System/Logger/Settings.hs

+50 −8

Original line number	Original line	Diff line number	Diff line
	@@ -9,6 +9,7 @@ module System.Logger.Settings
	, Level (..)		, Level (..)
	, Output (..)		, Output (..)
	, DateFormat (..)		, DateFormat (..)
			, Renderer

	, defSettings		, defSettings
	, output		, output
	@@ -19,8 +20,11 @@ module System.Logger.Settings
	, setBufSize		, setBufSize
	, delimiter		, delimiter
	, setDelimiter		, setDelimiter
	, netstrings
	, setNetStrings		, setNetStrings
			, setRendererDefault
			, setRendererNetstr
			, renderDefault
			, renderNetstr
	, logLevel		, logLevel
	, logLevelMap		, logLevelMap
	, logLevelOf		, logLevelOf
	@@ -30,6 +34,8 @@ module System.Logger.Settings
	, name		, name
	, setName		, setName
	, nameMsg		, nameMsg
			, renderer
			, setRenderer
	, iso8601UTC		, iso8601UTC
	) where		) where

	@@ -42,16 +48,18 @@ import Data.UnixTime
	import System.Log.FastLogger (defaultBufSize)		import System.Log.FastLogger (defaultBufSize)
	import System.Logger.Message		import System.Logger.Message

			import qualified Data.ByteString.Lazy.Builder as B

	data Settings = Settings		data Settings = Settings
	{ _logLevel :: !Level -- ^ messages below this log level will be suppressed		{ _logLevel :: !Level -- ^ messages below this log level will be suppressed
	, _levelMap :: !(Map Text Level) -- ^ log level per named logger		, _levelMap :: !(Map Text Level) -- ^ log level per named logger
	, _output :: !Output -- ^ log sink		, _output :: !Output -- ^ log sink
	, _format :: !(Maybe DateFormat) -- ^ the timestamp format (use 'Nothing' to disable timestamps)		, _format :: !(Maybe DateFormat) -- ^ the timestamp format (use 'Nothing' to disable timestamps)
	, _delimiter :: !ByteString -- ^ text to intersperse between fields of a log line		, _delimiter :: !ByteString -- ^ text to intersperse between fields of a log line
	, _netstrings :: !Bool -- ^ use <http://cr.yp.to/proto/netstrings.txt netstrings> encoding (fixes delimiter to \",\")
	, _bufSize :: !Int -- ^ how many bytes to buffer before commiting to sink		, _bufSize :: !Int -- ^ how many bytes to buffer before commiting to sink
	, _name :: !(Maybe Text) -- ^ logger name		, _name :: !(Maybe Text) -- ^ logger name
	, _nameMsg :: !(Msg -> Msg)		, _nameMsg :: !(Msg -> Msg)
			, _renderer :: !Renderer
	}		}

	output :: Settings -> Output		output :: Settings -> Output
	@@ -81,12 +89,30 @@ setDelimiter :: ByteString -> Settings -> Settings
	setDelimiter x s = s { _delimiter = x }		setDelimiter x s = s { _delimiter = x }

	-- \| Whether to use <http://cr.yp.to/proto/netstrings.txt netstring>		-- \| Whether to use <http://cr.yp.to/proto/netstrings.txt netstring>
	-- encoding for log lines.		-- encoding for log lines. Loads 'renderDefault' if given 'False'.
	netstrings :: Settings -> Bool		--
	netstrings = _netstrings		-- {#- DEPRECATED setNetStrings "Use setRendererNetstr or setRendererDefault instead" #-}

	setNetStrings :: Bool -> Settings -> Settings		setNetStrings :: Bool -> Settings -> Settings
	setNetStrings x s = s { _netstrings = x }		setNetStrings True = setRendererNetstr
			setNetStrings False = setRendererDefault

			-- \| Shortcut for calling 'setRenderer' with 'renderDefault'.
			setRendererDefault :: Settings -> Settings
			setRendererDefault = setRenderer renderDefault

			-- \| Shortcut for calling 'setRenderer' with 'renderNetstr'.
			setRendererNetstr :: Settings -> Settings
			setRendererNetstr = setRenderer renderNetstr

			-- \| Simple 'Renderer' with '=' between field names and values and a custom
			-- separator.
			renderDefault :: Renderer
			renderDefault s _ _ = renderDefault_ s

			-- \| 'Renderer' that uses <http://cr.yp.to/proto/netstrings.txt netstring>
			-- encoding for log lines.
			renderNetstr :: Renderer
			renderNetstr _ _ _ = renderNetstr_

	logLevel :: Settings -> Level		logLevel :: Settings -> Level
	logLevel = _logLevel		logLevel = _logLevel
	@@ -120,6 +146,16 @@ setName (Just xs) s = s { _name = Just xs, _nameMsg = "logger" .= xs }
	nameMsg :: Settings -> (Msg -> Msg)		nameMsg :: Settings -> (Msg -> Msg)
	nameMsg = _nameMsg		nameMsg = _nameMsg

			-- \| Output format
			renderer :: Settings -> Renderer
			renderer = _renderer

			-- \| Set a custom renderer. See 'setRendererDefault', 'setRendererNetstr' for
			-- two common special cases. Look at the code of 'renderDefault',
			-- 'renderNetstr' for examples how to write custom renderers.
			setRenderer :: Renderer -> Settings -> Settings
			setRenderer f s = s { _renderer = f }

	data Level		data Level
	= Trace		= Trace
	\| Debug		\| Debug
	@@ -146,6 +182,12 @@ instance IsString DateFormat where
	iso8601UTC :: DateFormat		iso8601UTC :: DateFormat
	iso8601UTC = "%Y-%0m-%0dT%0H:%0M:%0SZ"		iso8601UTC = "%Y-%0m-%0dT%0H:%0M:%0SZ"

			-- \| Take a custom separator, date format, log level of the event, and render
			-- a list of log fields or messages into a builder.
			--
			-- See also: 'renderDefault', 'renderNetstr'.
			type Renderer = ByteString -> DateFormat -> Level -> [Element] -> B.Builder

	-- \| Default settings:		-- \| Default settings:
	--		--
	-- * 'logLevel' = 'Debug'		-- * 'logLevel' = 'Debug'
	@@ -169,7 +211,7 @@ defSettings = Settings
	StdOut		StdOut
	(Just iso8601UTC)		(Just iso8601UTC)
	", "		", "
	False
	defaultBufSize		defaultBufSize
	Nothing		Nothing
	id		id
			renderDefault