diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +0.10 +----------------------------------------------------------------------------- +- Introduce `Settings` module. + +0.9 +----------------------------------------------------------------------------- +- Add support for netstrings encoding. + +0.8 +----------------------------------------------------------------------------- +- Initial release. diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,52 @@ +-- This Source Code Form is subject to the terms of the Mozilla Public +-- 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 OverloadedStrings #-} + +module Main (main) where + +import Criterion.Main +import Criterion.Config +import Data.Int +import System.Logger.Message + +import qualified Data.ByteString.Lazy as L + +main :: IO () +main = defaultMainWith defaultConfig (return ()) + [ bgroup "direct" + [ bench "msg/8" (whnf (f False) 8) + , bench "msg/16" (whnf (f False) 16) + , bench "msg/32" (whnf (f False) 32) + ] + , bgroup "netstr" + [ bench "msg/8" (whnf (f True) 8) + , bench "msg/16" (whnf (f True) 16) + , bench "msg/32" (whnf (f True) 32) + ] + , bgroup "direct" + [ bench "field/8" (whnf (g False) 8) + , bench "field/16" (whnf (g False) 16) + , bench "field/32" (whnf (g False) 32) + ] + , bgroup "netstr" + [ bench "field/8" (whnf (g True) 8) + , bench "field/16" (whnf (g True) 16) + , bench "field/32" (whnf (g True) 32) + ] + ] + +f :: Bool -> Int -> Int64 +f b n = L.length + . render ", " b + . foldr1 (.) + . replicate n + $ msg (val "hello world" +++ (10000 :: Int) +++ (-42 :: Int64)) + +g :: Bool -> Int -> Int64 +g b n = L.length + . render ", " b + . foldr1 (.) + . replicate n + $ "key" .= (val "hello world" +++ (10000 :: Int) +++ (-42 :: Int64)) diff --git a/src/System/Logger.hs b/src/System/Logger.hs --- a/src/System/Logger.hs +++ b/src/System/Logger.hs @@ -7,18 +7,37 @@ -- | Small layer on top of @fast-logger@ which adds log-levels and -- timestamp support (using @date-cache@) and not much more. module System.Logger - ( Level (..) + ( Settings + , defSettings + , logLevel + , setLogLevel + , output + , setOutput + , format + , setFormat + , delimiter + , setDelimiter + , netstrings + , setNetStrings + , bufSize + , setBufSize + , name + , setName + + , Level (..) , Output (..) - , Settings (..) - , Logger + , DateFormat + , iso8601UTC + , Logger , new , create - , defSettings , level , flush , close + , clone + , settings , log , trace @@ -28,95 +47,47 @@ , err , fatal - , iso8601UTC , module M - ) -where + ) where import Prelude hiding (log) import Control.Applicative import Control.Monad import Control.Monad.IO.Class import Data.ByteString (ByteString) -import Data.ByteString.Char8 (pack) import Data.Maybe (fromMaybe) -import Data.String +import Data.Text (Text) import Data.UnixTime import System.Date.Cache import System.Environment (lookupEnv) -import System.Log.FastLogger (BufSize) import System.Logger.Message as M +import System.Logger.Settings import qualified System.Log.FastLogger as FL -data Level - = Trace - | Debug - | Info - | Warn - | Error - | Fatal - deriving (Eq, Ord, Read, Show) - data Logger = Logger - { _logger :: FL.LoggerSet - , _settings :: Settings - , _getDate :: Maybe DateCacheGetter - , _closeDate :: Maybe DateCacheCloser + { logger :: FL.LoggerSet + , settings :: Settings + , getDate :: IO (Msg -> Msg) + , closeDate :: Maybe DateCacheCloser } -data Settings = Settings - { logLevel :: Level -- ^ messages below this log level will be suppressed - , output :: Output -- ^ log sink - , format :: DateFormat -- ^ the timestamp format (use \"\" to disable timestamps) - , delimiter :: ByteString -- ^ text to intersperse between fields of a log line - , bufSize :: BufSize -- ^ how many bytes to buffer before commiting to sink - } deriving (Eq, Ord, Show) - -data Output - = StdOut - | StdErr - | Path FilePath - deriving (Eq, Ord, Show) - -newtype DateFormat = DateFormat - { template :: ByteString - } deriving (Eq, Ord, Show) - -instance IsString DateFormat where - fromString = DateFormat . pack - --- | ISO 8601 date-time format. -iso8601UTC :: DateFormat -iso8601UTC = "%Y-%0m-%0dT%0H:%0M:%0SZ" - --- | Default settings for use with 'new': --- --- * 'logLevel' = 'Debug' --- --- * 'output' = 'StdOut' --- --- * 'format' = 'iso8601UTC' --- --- * 'delimiter' = \", \" --- --- * 'bufSize' = 'FL.defaultBufSize' --- -defSettings :: Settings -defSettings = Settings Debug StdOut iso8601UTC ", " FL.defaultBufSize - -- | Create a new 'Logger' with the given 'Settings'. -- Please note that the 'logLevel' can be dynamically adjusted by setting -- the environment variable @LOG_LEVEL@ accordingly. Likewise the buffer --- size can be dynamically set via @LOG_BUFFER@. +-- size can be dynamically set via @LOG_BUFFER@ and netstrings encoding +-- can be enabled with @LOG_NETSTR=True@ new :: MonadIO m => Settings -> m Logger new s = liftIO $ do n <- fmap (readNote "Invalid LOG_BUFFER") <$> lookupEnv "LOG_BUFFER" l <- fmap (readNote "Invalid LOG_LEVEL") <$> lookupEnv "LOG_LEVEL" + e <- fmap (readNote "Invalid LOG_NETSTR") <$> lookupEnv "LOG_NETSTR" g <- fn (output s) (fromMaybe (bufSize s) n) c <- clockCache (format s) - let s' = s { logLevel = fromMaybe (logLevel s) l } - return $ Logger g s' (fst <$> c) (snd <$> c) + let s' = setLogLevel (fromMaybe (logLevel s) l) + . setNetStrings (fromMaybe (netstrings s) e) + $ s + return $ Logger g s' (maybe (return id) (liftM msg) (fst <$> c)) (snd <$> c) where fn StdOut = FL.newStdoutLoggerSet fn StdErr = FL.newStderrLoggerSet @@ -130,7 +101,7 @@ -- | Invokes 'new' with default settings and the given output as log sink. create :: MonadIO m => Output -> m Logger -create p = new defSettings { output = p } +create o = new $ setOutput o defSettings readNote :: Read a => String -> String -> a readNote m s = case reads s of @@ -158,32 +129,41 @@ {-# INLINE err #-} {-# INLINE fatal #-} +-- | Clone the given logger and optionally give it a name +-- (use @(Just \"\")@ to clear). +clone :: Maybe Text -> Logger -> Logger +clone (Just n) g = g { settings = setName n (settings g) } +clone Nothing g = g + -- | Force buffered bytes to output sink. flush :: MonadIO m => Logger -> m () -flush = liftIO . FL.flushLogStr . _logger +flush = liftIO . FL.flushLogStr . logger -- | Closes the logger. close :: MonadIO m => Logger -> m () close g = liftIO $ do - fromMaybe (return ()) (_closeDate g) - FL.rmLoggerSet (_logger g) + fromMaybe (return ()) (closeDate g) + FL.rmLoggerSet (logger g) -- | Inspect this logger's threshold. level :: Logger -> Level -level = logLevel . _settings +level = logLevel . settings {-# INLINE level #-} putMsg :: MonadIO m => Logger -> Level -> (Msg -> Msg) -> m () putMsg g l f = liftIO $ do - d <- maybe (return id) (liftM msg) (_getDate g) - let m = render (delimiter $ _settings g) (d . msg (l2b l) . f) - FL.pushLogStr (_logger g) (FL.toLogStr m) - where - l2b :: Level -> ByteString - l2b Trace = "T" - l2b Debug = "D" - l2b Info = "I" - l2b Warn = "W" - l2b Error = "E" - l2b Fatal = "F" + 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) + FL.pushLogStr (logger g) (FL.toLogStr m) +lmsg :: Level -> (Msg -> Msg) +lmsg Trace = msg (val "T") +lmsg Debug = msg (val "D") +lmsg Info = msg (val "I") +lmsg Warn = msg (val "W") +lmsg Error = msg (val "E") +lmsg Fatal = msg (val "F") +{-# INLINE lmsg #-} diff --git a/src/System/Logger/Class.hs b/src/System/Logger/Class.hs --- a/src/System/Logger/Class.hs +++ b/src/System/Logger/Class.hs @@ -4,29 +4,50 @@ {-# LANGUAGE FlexibleContexts #-} +-- | The 'MonadLogger' type-class and associated functions. module System.Logger.Class - ( MonadLogger (..) - , trace - , debug - , info - , warn - , err - , fatal + ( L.Settings + , L.defSettings + , L.logLevel + , L.setLogLevel + , L.output + , L.setOutput + , L.format + , L.setFormat + , L.delimiter + , L.setDelimiter + , L.netstrings + , L.setNetStrings + , L.bufSize + , L.setBufSize + , L.name + , L.setName , L.Level (..) , L.Output (..) - , L.Settings (..) - , L.Logger + , L.DateFormat + , L.iso8601UTC + , L.Logger , L.new , L.create - , L.defSettings - , L.iso8601UTC + , L.level + , L.flush + , L.close + , L.clone + , L.settings + , MonadLogger (..) + , trace + , debug + , info + , warn + , err + , fatal + , module M - ) -where + ) where import System.Logger (Level (..)) import System.Logger.Message as M diff --git a/src/System/Logger/Message.hs b/src/System/Logger/Message.hs --- a/src/System/Logger/Message.hs +++ b/src/System/Logger/Message.hs @@ -2,14 +2,15 @@ -- 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 FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} -- | 'Msg' and 'ToBytes' assist in constructing log messages. -- For example: -- -- @ --- > g <- new defSettings { bufSize = 1, output = StdOut } +-- > g <- new (setBufSize 1 . setOutput StdOut $ defSettings) -- > info g $ msg "some text" ~~ "key" .= "value" ~~ "okay" .= True -- 2014-04-28T21:18:20Z, I, some text, key=value, okay=True -- > @@ -17,68 +18,97 @@ module System.Logger.Message ( ToBytes (..) , Msg + , Builder , msg , field , (.=) , (+++) , (~~) , val + , eval , render ) where import Data.ByteString (ByteString) -import Data.ByteString.Lazy.Builder (Builder) +import Data.Double.Conversion.Text import Data.Int -import Data.List (intersperse) import Data.Monoid +import Data.String import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Word +import GHC.Float -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.Encoding as T +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Builder as B import qualified Data.ByteString.Lazy.Builder.Extras as B +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +data Builder = Builder !Int B.Builder + +instance Monoid Builder where + mempty = Builder 0 mempty + (Builder x a) `mappend` (Builder y b) = Builder (x + y) (a <> b) + +instance IsString Builder where + fromString = bytes + +eval :: Builder -> L.ByteString +eval (Builder n b) = B.toLazyByteStringWith (B.safeStrategy n 256) L.empty b + -- | Convert some value to a 'Builder'. class ToBytes a where bytes :: a -> Builder -instance ToBytes Builder where bytes = id -instance ToBytes L.ByteString where bytes = B.lazyByteString -instance ToBytes ByteString where bytes = B.byteString -instance ToBytes Char where bytes = B.charUtf8 -instance ToBytes Int where bytes = B.intDec -instance ToBytes Int8 where bytes = B.int8Dec -instance ToBytes Int16 where bytes = B.int16Dec -instance ToBytes Int32 where bytes = B.int32Dec -instance ToBytes Int64 where bytes = B.int64Dec -instance ToBytes Word where bytes = B.wordDec -instance ToBytes Word8 where bytes = B.word8Dec -instance ToBytes Word16 where bytes = B.word16Dec -instance ToBytes Word32 where bytes = B.word32Dec -instance ToBytes Word64 where bytes = B.word64Dec -instance ToBytes Float where bytes = B.floatDec -instance ToBytes Double where bytes = B.doubleDec -instance ToBytes Text where bytes = B.byteString . encodeUtf8 -instance ToBytes T.Text where bytes = B.lazyByteString . T.encodeUtf8 -instance ToBytes [Char] where bytes = B.stringUtf8 +instance ToBytes Builder where bytes x = x +instance ToBytes L.ByteString where bytes x = Builder (fromIntegral $ L.length x) (B.lazyByteString x) +instance ToBytes ByteString where bytes x = Builder (S.length x) (B.byteString x) +instance ToBytes Int where bytes x = Builder (len10 x) (B.intDec x) +instance ToBytes Int8 where bytes x = Builder (len10 x) (B.int8Dec x) +instance ToBytes Int16 where bytes x = Builder (len10 x) (B.int16Dec x) +instance ToBytes Int32 where bytes x = Builder (len10 x) (B.int32Dec x) +instance ToBytes Int64 where bytes x = Builder (len10 x) (B.int64Dec x) +instance ToBytes Integer where bytes x = Builder (len10 x) (B.integerDec x) +instance ToBytes Word where bytes x = Builder (len10 x) (B.wordDec x) +instance ToBytes Word8 where bytes x = Builder (len10 x) (B.word8Dec x) +instance ToBytes Word16 where bytes x = Builder (len10 x) (B.word16Dec x) +instance ToBytes Word32 where bytes x = Builder (len10 x) (B.word32Dec x) +instance ToBytes Word64 where bytes x = Builder (len10 x) (B.word64Dec x) +instance ToBytes Float where bytes x = bytes (toShortest $ float2Double x) +instance ToBytes Double where bytes x = bytes (toShortest x) +instance ToBytes Text where bytes x = bytes (encodeUtf8 x) +instance ToBytes TL.Text where bytes x = bytes (TL.encodeUtf8 x) +instance ToBytes Char where bytes x = bytes (T.singleton x) +instance ToBytes [Char] where bytes x = bytes (TL.pack x) instance ToBytes Bool where - bytes True = val "True" - bytes False = val "False" + bytes True = Builder 4 (B.byteString "True") + bytes False = Builder 5 (B.byteString "False") +{-# INLINE len10 #-} +len10 :: Integral a => a -> Int +len10 !n = if n > 0 then go n 0 else 1 + go (-n) 0 + where + go 0 !a = a + go !x !a = go (x `div` 10) (a + 1) + -- | Type representing log messages. -newtype Msg = Msg { builders :: [Builder] } +newtype Msg = Msg { elements :: [Element] } +data Element + = Bytes Builder + | Field Builder Builder + -- | Turn some value into a 'Msg'. msg :: ToBytes a => a -> Msg -> Msg -msg p (Msg m) = Msg (bytes p : m) +msg p (Msg m) = Msg $ Bytes (bytes p) : m -- | Render some field, i.e. a key-value pair delimited by \"=\". field :: ToBytes a => ByteString -> a -> Msg -> Msg -field k v (Msg m) = Msg $ bytes k <> B.byteString "=" <> bytes v : m +field k v (Msg m) = Msg $ Field (bytes k) (bytes v) : m -- | Alias of 'field'. (.=) :: ToBytes a => ByteString -> a -> Msg -> Msg @@ -103,14 +133,42 @@ -- | Intersperse parts of the log message with the given delimiter and -- render the whole builder into a 'L.ByteString'. -render :: ByteString -> (Msg -> Msg) -> L.ByteString -render s f = finish - . mconcat - . intersperse (B.byteString s) - . builders - . f - $ empty +-- +-- If the second parameter is set to @True@, netstrings encoding is used for +-- the message elements. Cf. for +-- details. +render :: ByteString -> Bool -> (Msg -> Msg) -> L.ByteString +render _ True m = finish . encAll mempty . elements . m $ empty where - finish = B.toLazyByteStringWith (B.untrimmedStrategy 128 256) "\n" - empty = Msg [] + 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 + where + encAll !acc [] = acc + encAll !acc (b:[]) = acc <> encOne b + encAll !acc (b:bb) = encAll (acc <> encOne b <> sep) bb + + encOne (Bytes (Builder _ b)) = b + encOne (Field (Builder _ k) (Builder _ v)) = k <> eq <> v + + eq = B.char8 '=' + sep = B.byteString s + +finish :: B.Builder -> L.ByteString +finish = B.toLazyByteStringWith (B.untrimmedStrategy 256 256) "\n" + +empty :: Msg +empty = Msg [] + +netstr :: Builder -> B.Builder +netstr (Builder !n b) = B.intDec n <> colon <> b <> comma + +colon, comma :: B.Builder +colon = B.char8 ':' +comma = B.char8 ',' diff --git a/src/System/Logger/Settings.hs b/src/System/Logger/Settings.hs new file mode 100644 --- /dev/null +++ b/src/System/Logger/Settings.hs @@ -0,0 +1,140 @@ +-- This Source Code Form is subject to the terms of the Mozilla Public +-- 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 OverloadedStrings #-} + +module System.Logger.Settings + ( Settings + , Level (..) + , Output (..) + , DateFormat (..) + + , defSettings + , output + , setOutput + , format + , setFormat + , bufSize + , setBufSize + , delimiter + , setDelimiter + , netstrings + , setNetStrings + , logLevel + , setLogLevel + , name + , setName + , nameMsg + , iso8601UTC + ) where + +import Data.String +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack) +import Data.Text (Text) +import System.Log.FastLogger (defaultBufSize) +import System.Logger.Message + +data Settings = Settings + { _logLevel :: !Level -- ^ messages below this log level will be suppressed + , _output :: !Output -- ^ log sink + , _format :: !DateFormat -- ^ the timestamp format (use \"\" to disable timestamps) + , _delimiter :: !ByteString -- ^ text to intersperse between fields of a log line + , _netstrings :: !Bool -- ^ use encoding (fixes delimiter to \",\") + , _bufSize :: !Int -- ^ how many bytes to buffer before commiting to sink + , _name :: !Text -- ^ logger name + , _nameMsg :: Msg -> Msg + } + +output :: Settings -> Output +output = _output + +setOutput :: Output -> Settings -> Settings +setOutput x s = s { _output = x } + +format :: Settings -> DateFormat +format = _format + +setFormat :: DateFormat -> Settings -> Settings +setFormat x s = s { _format = x } + +bufSize :: Settings -> Int +bufSize = _bufSize + +setBufSize :: Int -> Settings -> Settings +setBufSize x s = s { _bufSize = max 1 x } + +delimiter :: Settings -> ByteString +delimiter = _delimiter + +setDelimiter :: ByteString -> Settings -> Settings +setDelimiter x s = s { _delimiter = x } + +netstrings :: Settings -> Bool +netstrings = _netstrings + +setNetStrings :: Bool -> Settings -> Settings +setNetStrings x s = s { _netstrings = x } + +logLevel :: Settings -> Level +logLevel = _logLevel + +setLogLevel :: Level -> Settings -> Settings +setLogLevel x s = s { _logLevel = x } + +name :: Settings -> Text +name = _name + +setName :: Text -> Settings -> Settings +setName "" s = s { _name = "", _nameMsg = id } +setName xs s = s { _name = xs, _nameMsg = "logger" .= xs } + +nameMsg :: Settings -> (Msg -> Msg) +nameMsg = _nameMsg + +data Level + = Trace + | Debug + | Info + | Warn + | Error + | Fatal + deriving (Eq, Ord, Read, Show) + +data Output + = StdOut + | StdErr + | Path FilePath + deriving (Eq, Ord, Show) + +newtype DateFormat = DateFormat + { template :: ByteString + } deriving (Eq, Ord, Show) + +instance IsString DateFormat where + fromString = DateFormat . pack + +-- | ISO 8601 date-time format. +iso8601UTC :: DateFormat +iso8601UTC = "%Y-%0m-%0dT%0H:%0M:%0SZ" + +-- | Default settings: +-- +-- * 'logLevel' = 'Debug' +-- +-- * 'output' = 'StdOut' +-- +-- * 'format' = 'iso8601UTC' +-- +-- * 'delimiter' = \", \" +-- +-- * 'netstrings' = False +-- +-- * 'bufSize' = 'FL.defaultBufSize' +-- +-- * 'name' = \"\" +-- +defSettings :: Settings +defSettings = Settings Debug StdOut iso8601UTC ", " False defaultBufSize "" id + diff --git a/tinylog.cabal b/tinylog.cabal --- a/tinylog.cabal +++ b/tinylog.cabal @@ -1,14 +1,17 @@ name: tinylog -version: 0.8 +version: 0.10.2 synopsis: Simplistic logging using fast-logger. author: Toralf Wittner maintainer: Toralf Wittner copyright: (c) 2014 Toralf Wittner +homepage: https://github.com/twittner/tinylog/ +bug-reports: https://github.com/twittner/tinylog/issues license: OtherLicense license-file: LICENSE category: System build-type: Simple cabal-version: >= 1.10 +extra-source-files: CHANGELOG.md description: Trivial logger on top of fast-logger. @@ -24,15 +27,31 @@ ghc-prof-options: -prof -auto-all exposed-modules: - System.Logger - , System.Logger.Class - , System.Logger.Message + System.Logger + System.Logger.Class + System.Logger.Message + other-modules: + System.Logger.Settings + build-depends: - base == 4.* - , bytestring >= 0.10.4 && < 0.11 - , date-cache >= 0.3 && < 0.4 - , fast-logger >= 2.1.4 && < 2.2 - , text >= 0.11 && < 1.2 - , transformers >= 0.3 - , unix-time >= 0.1 && < 0.3 + base == 4.* + , bytestring >= 0.10.4 && < 0.11 + , date-cache == 0.3.* + , double-conversion == 0.2.* + , fast-logger >= 2.1.4 && < 2.3 + , text >= 0.11 && < 1.2 + , transformers >= 0.3 + , unix-time >= 0.1 && < 0.4 + +benchmark tinylog-bench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Bench.hs + hs-source-dirs: bench + ghc-options: -Wall -O2 -fwarn-tabs + build-depends: + base == 4.* + , bytestring + , criterion == 0.8.* + , tinylog