diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # yet-another-logger +## 0.4.1 (2022-07-07) + +* Add a build flag for using `TBMQueue` instead of `TBMChan` as log message + queue. (#54) + +* Performance improvements under high load when many messages are dropped. + (#53) + ## 0.4.0 (2020-04-07) #### Changed diff --git a/example/Example.hs b/example/Example.hs --- a/example/Example.hs +++ b/example/Example.hs @@ -26,10 +26,10 @@ withConsoleLogger Info $ withLabel ("logger", "console") run -- log to a file - withTempFile "." "logfile.log" $ \f h → do + withTempFile "." "logfile.log" $ \file h → do hClose h - withFileLogger f Info $ withLabel ("logger", "file") run - readFile f >>= putStrLn + withFileLogger file Info $ withLabel ("logger", "file") run + readFile file >>= putStrLn where f = withLevel Debug $ logg Debug "debug f" diff --git a/src/System/Logger/Internal/Queue.hs b/src/System/Logger/Internal/Queue.hs --- a/src/System/Logger/Internal/Queue.hs +++ b/src/System/Logger/Internal/Queue.hs @@ -21,18 +21,17 @@ -- Module: System.Logger.Internal.Queue -- Description: Queues for Usage with Yet Another Logger -- Copyright: --- Copyright © 2016-2020 Lars Kuhtz +-- Copyright © 2016-2022 Lars Kuhtz -- Copyright © 2015 PivotCloud, Inc. -- License: Apache-2.0 -- Maintainer: Lars Kuhtz -- Stability: experimental -- +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnicodeSyntax #-} diff --git a/src/System/Logger/Logger/Internal.hs b/src/System/Logger/Logger/Internal.hs --- a/src/System/Logger/Logger/Internal.hs +++ b/src/System/Logger/Logger/Internal.hs @@ -21,7 +21,7 @@ -- Module: System.Logger.Logger.Internal -- Description: Yet Another Logger Implementation -- Copyright: --- Copyright (c) 2016-2020 Lars Kuhtz +-- Copyright (c) 2016-2022 Lars Kuhtz -- Copyright (c) 2014-2015 PivotCloud, Inc. -- License: Apache License, Version 2.0 -- Maintainer: Lars Kuhtz @@ -34,6 +34,7 @@ -- module as an example and starting point. -- +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} @@ -86,16 +87,14 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.Async --- FIXME: use a better data structure with non-amortized complexity bounds -import Control.Concurrent.STM.TVar import Control.DeepSeq import Control.Exception.Enclosed import Control.Exception.Lifted import Control.Monad.Except -import Control.Monad.STM import Control.Monad.Trans.Control import Control.Monad.Unicode +import Data.IORef import Data.Monoid.Unicode import qualified Data.Text as T import qualified Data.Text.IO as T (hPutStrLn) @@ -103,6 +102,7 @@ import Data.Void import GHC.Generics +import GHC.IORef import Lens.Micro @@ -271,8 +271,11 @@ -- are enqueued and processed asynchronously by a background worker that takes -- the message from queue and calls the backend function for each log message. -- +#ifdef USE_TBMQUEUE +type LoggerQueue a = TBMQueue (LogMessage a) +#else type LoggerQueue a = TBMChan (LogMessage a) --- type LoggerQueue a = TBMQueue (LogMessage a) +#endif -- type LoggerQueue a = FairTBMQueue (LogMessage a) data Logger a = Logger @@ -281,7 +284,7 @@ , _loggerThreshold ∷ !LogLevel , _loggerScope ∷ !LogScope , _loggerPolicy ∷ !LogPolicy - , _loggerMissed ∷ !(TVar Natural) + , _loggerMissed ∷ !(IORef Natural) , _loggerExitTimeout ∷ !(Maybe Natural) , _loggerErrLogFunction ∷ !(T.Text → IO ()) } @@ -363,7 +366,7 @@ → μ (Logger a) createLogger_ errLogFun LoggerConfig{..} backend = liftIO $ do queue ← newQueue (fromIntegral _loggerConfigQueueSize) - missed ← newTVarIO 0 + missed ← newIORef 0 worker ← backendWorker errLogFun _loggerConfigExceptionLimit _loggerConfigExceptionWait backend queue missed -- we link the worker to the calling thread. This way all exception from -- the logger are rethrown. This includes asynchronous exceptions, but @@ -383,15 +386,15 @@ -- | A backend worker. -- --- The only way for this function to exist without an exception is when --- the interal logger queue is closed through a call to 'releaseLogger'. +-- The only way for this function to exit without an exception is when +-- the internal logger queue is closed through a call to 'releaseLogger'. -- backendWorker ∷ (T.Text → IO ()) -- ^ alternate sink for logging exceptions in the logger itself. → Maybe Natural -- ^ number of consecutive backend exception that can occur before the logger - -- to raises an 'BackendTooManyExceptions' exception. If this is 'Nothing' + -- raises an 'BackendTooManyExceptions' exception. If this is 'Nothing' -- the logger will discard all exceptions. For instance a value of @1@ -- means that an exception is raised when the second exception occurs. -- A value of @0@ means that an exception is raised for each exception. @@ -400,7 +403,7 @@ -- If this is 'Nothing' the logger won't wait at all after an exception. → LoggerBackend a → LoggerQueue a - → TVar Natural + → IORef Natural → IO (Async ()) backendWorker errLogFun errLimit errWait backend queue missed = mask_ $ asyncWithUnmask $ \umask → umask (go []) `catch` \(_ ∷ LoggerKilled) → return () @@ -451,7 +454,7 @@ -- a new message arrives -- readMsg t = do - n ← atomically $ swapTVar missed 0 + n ← atomicSwapIORef missed 0 if n > 0 then do return ∘ Just ∘ Left $ discardMsg t n @@ -605,7 +608,7 @@ } | otherwise → return () where - writeWithLogPolicy lmsg + writeWithLogPolicy !lmsg | _loggerPolicy ≡ LogPolicyBlock = void $ writeQueue _loggerQueue lmsg | otherwise = tryWriteQueue _loggerQueue lmsg ≫= \case -- Success @@ -614,7 +617,7 @@ Just False → return () -- Queue is full Nothing - | _loggerPolicy ≡ LogPolicyDiscard → atomically $ modifyTVar' _loggerMissed succ + | _loggerPolicy ≡ LogPolicyDiscard → atomicModifyIORef' _loggerMissed (\x → (x + 1, ())) | _loggerPolicy ≡ LogPolicyRaise → throwIO $ QueueFullException lmsg | otherwise → return () -- won't happen, covered above. {-# INLINEABLE loggCtx #-} diff --git a/test/NoBackend.hs b/test/NoBackend.hs --- a/test/NoBackend.hs +++ b/test/NoBackend.hs @@ -219,14 +219,14 @@ → Natural -- ^ minimal delay before returning in microseconds → LoggerBackend msg -testBackend _logLog delayMicro (Right LogMessage{..}) = +testBackend _logLog delayMicro (Right _) = -- simulate deliver by applying the delay threadDelay (fromIntegral delayMicro) ≫ return () -testBackend logLog delayMicro (Left LogMessage{..}) = do +testBackend logLog delayMicro (Left l) = do -- assume that the message comes from the logging system itself. -- simulate delivery by applying the delay. - logLog $ "[" ⊕ logLevelText _logMsgLevel ⊕ "] " ⊕ sshow _logMsg + logLog $ "[" ⊕ logLevelText (_logMsgLevel l) ⊕ "] " ⊕ sshow (_logMsg l) threadDelay (fromIntegral delayMicro) -- -------------------------------------------------------------------------- -- diff --git a/yet-another-logger.cabal b/yet-another-logger.cabal --- a/yet-another-logger.cabal +++ b/yet-another-logger.cabal @@ -1,6 +1,6 @@ -Cabal-version: 2.2 +Cabal-version: 2.4 Name: yet-another-logger -Version: 0.4.0 +Version: 0.4.1 Synopsis: Yet Another Logger Description: A logging framework written with flexibility and performance @@ -54,7 +54,7 @@ Author: Lars Kuhtz Maintainer: Lars Kuhtz Copyright: - Copyright (c) 2016-2020 Lars Kuhtz + Copyright (c) 2016-2022 Lars Kuhtz Copyright (c) 2014-2015 PivotCloud, Inc. Category: Logging, System Build-type: Simple @@ -68,11 +68,10 @@ type: git location: https://github.com/alephcloud/hs-yet-another-logger -source-repository this - type: git - location: https://github.com/alephcloud/hs-yet-another-logger - branch: master - tag: 0.3.1 +flag tbmqueue + description: Use TBMQueue as logger queue. The default is to use TBMChan. + default: False + manual: True Library default-language: Haskell2010 @@ -114,6 +113,9 @@ void >= 0.7 ghc-options: -Wall + + if flag(tbmqueue) + cpp-options: -DUSE_TBMQUEUE test-suite tests type: exitcode-stdio-1.0