yet-another-logger 0.4.0 → 0.4.1
raw patch · 6 files changed
+43/−31 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +8/−0
- example/Example.hs +3/−3
- src/System/Logger/Internal/Queue.hs +2/−3
- src/System/Logger/Logger/Internal.hs +17/−14
- test/NoBackend.hs +3/−3
- yet-another-logger.cabal +10/−8
CHANGELOG.md view
@@ -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
example/Example.hs view
@@ -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"
src/System/Logger/Internal/Queue.hs view
@@ -21,18 +21,17 @@ -- Module: System.Logger.Internal.Queue -- Description: Queues for Usage with Yet Another Logger -- Copyright:--- Copyright © 2016-2020 Lars Kuhtz <lakuhtz@gmail.com>+-- Copyright © 2016-2022 Lars Kuhtz <lakuhtz@gmail.com> -- Copyright © 2015 PivotCloud, Inc. -- License: Apache-2.0 -- Maintainer: Lars Kuhtz <lakuhtz@gmail.com> -- Stability: experimental -- +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnicodeSyntax #-}
src/System/Logger/Logger/Internal.hs view
@@ -21,7 +21,7 @@ -- Module: System.Logger.Logger.Internal -- Description: Yet Another Logger Implementation -- Copyright:--- Copyright (c) 2016-2020 Lars Kuhtz <lakuhtz@gmail.com>+-- Copyright (c) 2016-2022 Lars Kuhtz <lakuhtz@gmail.com> -- Copyright (c) 2014-2015 PivotCloud, Inc. -- License: Apache License, Version 2.0 -- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>@@ -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 #-}
test/NoBackend.hs view
@@ -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) -- -------------------------------------------------------------------------- --
yet-another-logger.cabal view
@@ -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 <lakuhtz@gmail.com> Maintainer: Lars Kuhtz <lakuhtz@gmail.com> Copyright:- Copyright (c) 2016-2020 Lars Kuhtz <lakuhtz@gmail.com>+ Copyright (c) 2016-2022 Lars Kuhtz <lakuhtz@gmail.com> 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