Commit a0bd8eb2 authored by Toralf Wittner's avatar Toralf Wittner
Browse files

Merge branch 'custom-format' into 'develop' 

Custom format

See merge request twittner/tinylog!3
parents 434aed67 bf45f229

bench/Bench.hs

+47 −20
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,70 @@ module Main (main) where 
import Criterion

import Criterion.Main

import Data.Int

import System.Logger.Message

import System.Logger



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 ", " iso8601UTC Trace)

      . 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 ", " iso8601UTC Trace)

      . 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

+15 −7
Original line number Diff line number Diff line
@@ -21,18 +21,24 @@ module System.Logger 
    , setFormat

    , delimiter

    , setDelimiter

    , netstrings

    , setNetStrings

    , setRendererDefault

    , setRendererNetstr

    , renderDefault

    , renderNetstr

    , bufSize

    , setBufSize

    , name

    , setName

    , setRenderer

    , renderer



      -- * Type definitions

    , Logger

    , Level      (..)

    , Output     (..)

    , DateFormat (..)

    , Renderer

    , iso8601UTC



      -- * Core API
@@ -63,7 +69,7 @@ import Data.Maybe (fromMaybe) 
import Data.Text (Text)

import Data.UnixTime

import System.Environment (lookupEnv)

import System.Logger.Message as M

import System.Logger.Message as M hiding (renderDefault_, renderNetstr_)

import System.Logger.Settings

import Prelude hiding (log)
@@ -109,7 +115,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 +188,12 @@ 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 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)



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

src/System/Logger/Class.hs

+2 −1
Original line number Diff line number Diff line
@@ -16,12 +16,13 @@ module System.Logger.Class 
    , L.setFormat

    , L.delimiter

    , L.setDelimiter

    , L.netstrings

    , L.setNetStrings

    , L.bufSize

    , L.setBufSize

    , L.name

    , L.setName

    , L.setRenderer

    , L.renderer



    , L.Level    (..)

    , L.Output   (..)

src/System/Logger/Message.hs

+30 −17
Original line number Diff line number Diff line
@@ -20,6 +20,7 @@ module System.Logger.Message 
    ( ToBytes (..)

    , Msg

    , Builder

    , Element (..)

    , msg

    , field

    , (.=)
@@ -27,7 +28,11 @@ module System.Logger.Message 
    , (~~)

    , val

    , eval

    , builderSize

    , builderBytes

    , render

    , renderDefault_

    , renderNetstr_

    ) where



#if MIN_VERSION_base(4,9,0)
@@ -81,6 +86,12 @@ instance Monoid Builder where 
eval :: Builder -> L.ByteString

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'.

class ToBytes a where

    bytes :: a -> Builder
@@ -153,24 +164,14 @@ infixr 6 +++ 
val :: ByteString -> Builder

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



    encOne (Bytes   e) = netstr e

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



    eq = B.byteString "1:=,"

-- | Construct elements, call a renderer, and run the whole builder

-- into a 'L.ByteString'.

render :: ([Element] -> B.Builder) -> (Msg -> Msg) -> L.ByteString

render f m = finish . f . elements . m $ empty



render s False m = finish . encAll mempty . elements . m $ empty

-- | See 'renderDefault'.

renderDefault_ :: ByteString -> [Element] -> B.Builder

renderDefault_ s = encAll mempty

  where

    encAll !acc    []  = acc

    encAll !acc (b:[]) = acc <> encOne b
@@ -182,6 +183,18 @@ render s False m = finish . encAll mempty . elements . m $ empty 
    eq  = B.char8 '='

    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.toLazyByteStringWith (B.untrimmedStrategy 256 256) "\n"

src/System/Logger/Settings.hs

+50 −8
Original line number Diff line number Diff line
@@ -9,6 +9,7 @@ module System.Logger.Settings 
    , Level      (..)

    , Output     (..)

    , DateFormat (..)

    , Renderer



    , defSettings

    , output
@@ -19,8 +20,11 @@ module System.Logger.Settings 
    , setBufSize

    , delimiter

    , setDelimiter

    , netstrings

    , setNetStrings

    , setRendererDefault

    , setRendererNetstr

    , renderDefault

    , renderNetstr

    , logLevel

    , logLevelMap

    , logLevelOf
@@ -30,6 +34,8 @@ module System.Logger.Settings 
    , name

    , setName

    , nameMsg

    , renderer

    , setRenderer

    , iso8601UTC

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

import System.Logger.Message



import qualified Data.ByteString.Lazy.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   :: !Renderer

    }



output :: Settings -> Output
@@ -81,12 +89,30 @@ setDelimiter :: ByteString -> Settings -> Settings 
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



-- encoding for log lines.  Loads 'renderDefault' if given 'False'.

--

-- {#- DEPRECATED setNetStrings "Use setRendererNetstr or setRendererDefault instead" #-}

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 = _logLevel
@@ -120,6 +146,16 @@ setName (Just xs) s = s { _name = Just xs, _nameMsg = "logger" .= xs } 
nameMsg :: Settings -> (Msg -> Msg)

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

    = Trace

    | Debug
@@ -146,6 +182,12 @@ instance IsString DateFormat where 
iso8601UTC :: DateFormat

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:

--

--   * 'logLevel'   = 'Debug'
@@ -169,7 +211,7 @@ defSettings = Settings 
    StdOut

    (Just iso8601UTC)

    ", "

    False

    defaultBufSize

    Nothing

    id

    renderDefault