Commit 17f12e65 authored by Kim Altintop's avatar Kim Altintop

Allow to customise the rendered output

parent 3a7bc8e1
......@@ -2,6 +2,7 @@
-- 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/.
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
......@@ -9,44 +10,71 @@ module Main (main) where
import Criterion
import Criterion.Main
import Data.Int
import Data.Monoid
import System.Logger.Message
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as L
main :: IO ()
main = defaultMain
[ bgroup "direct"
[ bench "msg/8" (whnf (f False) 8)
, bench "msg/16" (whnf (f False) 16)
, bench "msg/32" (whnf (f False) 32)
[ bench "msg/8" (whnf (f renderDefault) 8)
, bench "msg/16" (whnf (f renderDefault) 16)
, bench "msg/32" (whnf (f renderDefault) 32)
]
, bgroup "netstr"
[ bench "msg/8" (whnf (f True) 8)
, bench "msg/16" (whnf (f True) 16)
, bench "msg/32" (whnf (f True) 32)
[ bench "msg/8" (whnf (f renderNetstr) 8)
, bench "msg/16" (whnf (f renderNetstr) 16)
, 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"
[ bench "field/8" (whnf (g False) 8)
, bench "field/16" (whnf (g False) 16)
, bench "field/32" (whnf (g False) 32)
[ bench "field/8" (whnf (g renderDefault) 8)
, bench "field/16" (whnf (g renderDefault) 16)
, bench "field/32" (whnf (g renderDefault) 32)
]
, bgroup "netstr"
[ bench "field/8" (whnf (g True) 8)
, bench "field/16" (whnf (g True) 16)
, bench "field/32" (whnf (g True) 32)
[ bench "field/8" (whnf (g renderNetstr) 8)
, bench "field/16" (whnf (g renderNetstr) 16)
, 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 b n = L.length
. render ", " b
f :: Renderer -> Int -> Int64
f r n = L.length
. render ", " r
. foldr1 (.)
. replicate n
$ msg (val "hello world" +++ (10000 :: Int) +++ (-42 :: Int64))
g :: Bool -> Int -> Int64
g b n = L.length
. render ", " b
g :: Renderer -> Int -> Int64
g r n = L.length
. render ", " r
. foldr1 (.)
. replicate n
$ "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
......@@ -21,7 +21,6 @@ module System.Logger
, setFormat
, delimiter
, setDelimiter
, netstrings
, setNetStrings
, bufSize
, setBufSize
......@@ -109,7 +108,7 @@ new s = liftIO $ do
!m <- fromMaybe "[]" <$> lookupEnv "LOG_LEVEL_MAP"
let !k = logLevelMap s `mergeWith` m
let !s' = setLogLevel (fromMaybe (logLevel s) l)
. setNetStrings (fromMaybe (netstrings s) e)
. setNetStrings (fromMaybe False e)
. setLogLevelMap k
$ s
g <- fn (output s) (fromMaybe (bufSize s) n)
......@@ -182,10 +181,10 @@ 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)
let r = renderer $ settings g
let x = delimiter $ settings g
let s = nameMsg $ settings g
let m = render x r (d . lmsg l . s . f)
FL.pushLogStr (logger g) (FL.toLogStr m)
lmsg :: Level -> (Msg -> Msg)
......
......@@ -16,7 +16,6 @@ module System.Logger.Class
, L.setFormat
, L.delimiter
, L.setDelimiter
, L.netstrings
, L.setNetStrings
, L.bufSize
, L.setBufSize
......
......@@ -19,6 +19,8 @@ module System.Logger.Message
( ToBytes (..)
, Msg
, Builder
, Element (..)
, Renderer
, msg
, field
, (.=)
......@@ -26,7 +28,11 @@ module System.Logger.Message
, (~~)
, val
, eval
, builderSiz
, builderBytes
, render
, renderDefault
, renderNetstr
) where
import Data.ByteString (ByteString)
......@@ -59,6 +65,12 @@ instance IsString Builder where
eval :: Builder -> L.ByteString
eval (Builder n b) = B.toLazyByteStringWith (B.safeStrategy n 256) L.empty b
builderSiz :: Builder -> Int
builderSiz (Builder n _) = n
builderBytes :: Builder -> B.Builder
builderBytes (Builder _ b) = b
-- | Convert some value to a 'Builder'.
class ToBytes a where
bytes :: a -> Builder
......@@ -98,6 +110,8 @@ len10 !n = if n > 0 then go n 0 else 1 + go (-n) 0
-- | Type representing log messages.
newtype Msg = Msg { elements :: [Element] }
type Renderer = ByteString -> [Element] -> B.Builder
data Element
= Bytes Builder
| Field Builder Builder
......@@ -133,22 +147,11 @@ val = bytes
-- | Intersperse parts of the log message with the given delimiter and
-- render the whole builder into a 'L.ByteString'.
--
-- If the second parameter is set to @[email protected], netstrings encoding is used for
-- 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
render :: ByteString -> Renderer -> (Msg -> Msg) -> L.ByteString
render s f m = finish . f s . elements . m $ empty
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
renderDefault :: Renderer
renderDefault s = encAll mempty
where
encAll !acc [] = acc
encAll !acc (b:[]) = acc <> encOne b
......@@ -160,6 +163,17 @@ render s False m = finish . encAll mempty . elements . m $ empty
eq = B.char8 '='
sep = B.byteString s
renderNetstr :: Renderer
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.toLazyByteStringWith (B.untrimmedStrategy 256 256) "\n"
......
......@@ -19,7 +19,6 @@ module System.Logger.Settings
, setBufSize
, delimiter
, setDelimiter
, netstrings
, setNetStrings
, logLevel
, logLevelMap
......@@ -30,6 +29,8 @@ module System.Logger.Settings
, name
, setName
, nameMsg
, renderer
, setRenderer
, iso8601UTC
) where
......@@ -42,16 +43,18 @@ import Data.UnixTime
import System.Log.FastLogger (defaultBufSize)
import System.Logger.Message
import qualified Data.ByteString.Builder as B
data Settings = Settings
{ _logLevel :: !Level -- ^ messages below this log level will be suppressed
, _levelMap :: !(Map Text Level) -- ^ log level per named logger
, _output :: !Output -- ^ log sink
, _format :: !(Maybe DateFormat) -- ^ the timestamp format (use 'Nothing' to disable timestamps)
, _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
, _name :: !(Maybe Text) -- ^ logger name
, _nameMsg :: !(Msg -> Msg)
, _renderer :: !(ByteString -> [Element] -> B.Builder)
}
output :: Settings -> Output
......@@ -82,11 +85,9 @@ setDelimiter x s = s { _delimiter = x }
-- | Whether to use <http://cr.yp.to/proto/netstrings.txt netstring>
-- encoding for log lines.
netstrings :: Settings -> Bool
netstrings = _netstrings
setNetStrings :: Bool -> Settings -> Settings
setNetStrings x s = s { _netstrings = x }
setNetStrings True = setRenderer renderNetstr
setNetStrings False = setRenderer renderDefault
logLevel :: Settings -> Level
logLevel = _logLevel
......@@ -120,6 +121,13 @@ setName (Just xs) s = s { _name = Just xs, _nameMsg = "logger" .= xs }
nameMsg :: Settings -> (Msg -> Msg)
nameMsg = _nameMsg
-- | Output format
renderer :: Settings -> (ByteString -> [Element] -> B.Builder)
renderer = _renderer
setRenderer :: (ByteString -> [Element] -> B.Builder) -> Settings -> Settings
setRenderer f s = s { _renderer = f }
data Level
= Trace
| Debug
......@@ -169,7 +177,7 @@ defSettings = Settings
StdOut
(Just iso8601UTC)
", "
False
defaultBufSize
Nothing
id
renderDefault
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment