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

Allow to customise the rendered output

parent 3a7bc8e1

bench/Bench.hs

+47 −19
Original line number Diff line number Diff line
@@ -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.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

src/System/Logger.hs

+5 −6
Original line number Diff line number Diff line
@@ -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 r = renderer  $ settings g

    let x = delimiter $ settings g

    let s = nameMsg   $ settings g

    let m = render x n (d . lmsg l . s . f)

    let m = render x r (d . lmsg l . s . f)

    FL.pushLogStr (logger g) (FL.toLogStr m)



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

src/System/Logger/Class.hs

+0 −1
Original line number Diff line number Diff line
@@ -16,7 +16,6 @@ module System.Logger.Class 
    , L.setFormat

    , L.delimiter

    , L.setDelimiter

    , L.netstrings

    , L.setNetStrings

    , L.bufSize

    , L.setBufSize

src/System/Logger/Message.hs

+29 −15
Original line number Diff line number Diff line
@@ -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 @True@, 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"

src/System/Logger/Settings.hs

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