yet-another-logger 0.1.1.1 → 0.2
raw patch · 15 files changed
+1445/−279 lines, 15 filesdep +Cabaldep +clockdep +natsdep ~configuration-toolsdep ~lensdep ~lifted-basenew-component:exe:example
Dependencies added: Cabal, clock, nats, tagged, tasty, tasty-hunit, time, void, yet-another-logger
Dependency ranges changed: configuration-tools, lens, lifted-base, trace
Files
- CHANGELOG.md +54/−3
- constraints +73/−72
- example/Example.hs +42/−0
- src/System/Logger.hs +9/−3
- src/System/Logger/Backend/ColorOption.hs +17/−2
- src/System/Logger/Backend/Handle.hs +21/−6
- src/System/Logger/Internal.hs +55/−0
- src/System/Logger/Internal/Queue.hs +146/−0
- src/System/Logger/Logger.hs +7/−0
- src/System/Logger/Logger/Internal.hs +322/−56
- src/System/Logger/Types.hs +135/−134
- test/Main.hs +39/−0
- test/NoBackend.hs +333/−0
- test/TastyTools.hs +139/−0
- yet-another-logger.cabal +53/−3
CHANGELOG.md view
@@ -1,7 +1,58 @@-0.1.1.1-=======+0.2+=== -* Add `NFData` instance for `LogPolicy`.+* Removed `MonadLogIO`; `MonadBaseControl` should be used instead.++* Issue #16: add an argument to all command-line options parsers that+ adds a prefix to the command-line options.++* Issue #9: more robust logger backend++ * new functions that take an function of type `Text -> IO ()` as+ an alternate backend to log issues in the logging system itself.++ * `withLogger_`+ * `withLogFunction_`+ * `createLogger_`++ * new parameters+ * `loggerConfigExceptionLimit`:+ Number of consecutive backend exception that can occur before the logger+ raises an `BackendToManyExceptions` exception. If this is `Nothing`+ the logger will discard all exceptions.++ * `loggerConfigExceptionWait`:+ Number of microseconds to wait after an exception from the backend.+ If this is 'Nothing' the logger won't wait at all after an exception.++ * `loggerConfigExitTimeout`:+ Timeout in microseconds for the logger to flush the queue and+ deliver all remaining log messages on termination. If this is `Nothing`+ termination of the logger blogs until all mesages are delivered.++ * new `LoggerException` type+ * `QueueFullException` is thrown when the queue is full and the logger+ policy is to throw exceptions on a full queue.++ * `BackendTerminatedException` can be thrown by a backend to force the+ logger immediately.++ * `BackendToManyExceptions` is thrown when the backend is throwing some+ unexpected exception more than list `loggerConfigExceptionLimit` times.++* Issue #12: a test-suite got added to the package. Note that this test-suite takes+ a relatively long time to run all tests. In particular this an cause timeouts+ with travis-ci.++* Issue #14: the command line option for setting the log-level got fixed to be+ spelled `--log-level` (instead of `--loglevel`).++* Issue #22: added timestamp to log messages.++* Replaced usage of `Int` by `Natural` where adequate.++* Issue #6: use `TBMChan` as internal queue implementation until a new version of+ stm is released with a [fix for `TQueue`](https://ghc.haskell.org/trac/ghc/ticket/9539). 0.1.1 =====
constraints view
@@ -1,40 +1,42 @@-constraints: Cabal ==1.22.0.0,- MonadRandom ==0.3,+constraints: Cabal ==1.22.2.0,+ MonadRandom ==0.3.0.1,+ StateVar ==1.1.0.0, adjunctions ==4.2, aeson ==0.8.0.2, ansi-terminal ==0.6.2.1,- ansi-wl-pprint ==0.6.7.1,- array ==0.5.0.0,+ ansi-wl-pprint ==0.6.7.2,+ array ==0.5.1.0, asn1-encoding ==0.9.0, asn1-parse ==0.9.0, asn1-types ==0.3.0,- async ==2.0.1.6,- attoparsec ==0.12.1.2,- base ==4.7.0.1,+ async ==2.0.2,+ attoparsec ==0.12.1.5,+ base ==4.8.0.0, base-unicode-symbols ==0.2.2.4, base64-bytestring ==1.0.0.1,- bifunctors ==4.1.1.1,- binary ==0.7.1.0,- blaze-builder ==0.3.3.4,+ bifunctors ==4.2.1,+ binary ==0.7.3.0,+ blaze-builder ==0.4.0.1, byteable ==0.1.1,- bytestring ==0.10.4.0,- case-insensitive ==1.2.0.3,- cereal ==0.4.0.1,- cipher-aes ==0.2.8,+ bytestring ==0.10.6.0,+ case-insensitive ==1.2.0.4,+ cereal ==0.4.1.1,+ cipher-aes ==0.2.10, cipher-des ==0.0.6, cipher-rc4 ==0.1.4,- comonad ==4.2.2,- conduit ==1.2.3.1,- configuration-tools ==0.2.10,+ clock ==0.4.1.3,+ comonad ==4.2.5,+ conduit ==1.2.4,+ configuration-tools ==0.2.12, connection ==0.2.4,- containers ==0.5.5.1,- contravariant ==1.2.0.1,+ containers ==0.5.6.2,+ contravariant ==1.3.1, cookie ==0.4.1.4, crypto-cipher-types ==0.0.9,- crypto-numbers ==0.2.3,+ crypto-numbers ==0.2.7, crypto-pubkey ==0.2.8, crypto-pubkey-types ==0.4.3,- crypto-random ==0.0.7,+ crypto-random ==0.0.9, cryptohash ==0.11.6, data-default ==0.5.3, data-default-class ==0.0.1,@@ -42,76 +44,75 @@ data-default-instances-containers ==0.0.1, data-default-instances-dlist ==0.0.1, data-default-instances-old-locale ==0.0.1,- deepseq ==1.3.0.2,- directory ==1.2.1.0,+ deepseq ==1.4.1.1,+ directory ==1.2.2.0, distributive ==0.4.4,- dlist ==0.7.1,- either ==4.3.2.1,- enclosed-exceptions ==1.0.1,+ dlist ==0.7.1.1,+ either ==4.3.3.2,+ enclosed-exceptions ==1.0.1.1, errors ==1.4.7,- exceptions ==0.6.1,- filepath ==1.3.0.2,- free ==4.10.0.1,- ghc-prim ==0.3.1.0,- hashable ==1.2.3.1,+ exceptions ==0.8.0.2,+ filepath ==1.4.0.0,+ free ==4.11,+ ghc-prim ==0.4.0.0,+ hashable ==1.2.3.2, hourglass ==0.2.8,- http-client ==0.4.7,+ http-client ==0.4.9, http-client-tls ==0.2.2,- http-types ==0.8.5,- integer-gmp ==0.5.1.0,- kan-extensions ==4.2,- lens ==4.7,- lifted-base ==0.2.3.3,- mime-types ==0.1.0.5,+ http-types ==0.8.6,+ integer-gmp ==1.0.0.0,+ kan-extensions ==4.2.1,+ lens ==4.8,+ lifted-base ==0.2.3.6,+ mime-types ==0.1.0.6, mmorph ==1.0.4,- monad-control ==1.0.0.1,+ monad-control ==1.0.0.4, mtl ==2.2.1, nats ==1, network ==2.6.0.2, network-uri ==2.6.0.1,- old-locale ==1.0.0.6,- optparse-applicative ==0.11.0.1,- parallel ==3.2.0.4,- parsec ==3.1.7,+ old-locale ==1.0.0.7,+ optparse-applicative ==0.11.0.2,+ parallel ==3.2.0.6,+ parsec ==3.1.9, pem ==0.2.2, prelude-extras ==0.4,- pretty ==1.1.1.1,- primitive ==0.5.3.0,- process ==1.2.0.0,- profunctors ==4.3.2,+ pretty ==1.1.2.0,+ primitive ==0.5.4.0,+ process ==1.2.3.0,+ profunctors ==4.4.1, publicsuffixlist ==0.1,- random ==1.0.1.1,- reflection ==1.4,- resourcet ==1.1.3.3,+ random ==1.1,+ reflection ==1.5.1.2,+ resourcet ==1.1.4.1, rts ==1.0,- safe ==0.3.6,- scientific ==0.3.3.5,- securemem ==0.1.3,- semigroupoids ==4.2,- semigroups ==0.16.0.1,+ safe ==0.3.8,+ scientific ==0.3.3.8,+ securemem ==0.1.7,+ semigroupoids ==4.3,+ semigroups ==0.16.2.2, socks ==0.5.4,- split ==0.2.2,- stm ==2.4.3,- stm-chans ==3.0.0.2,- streaming-commons ==0.1.8,- syb ==0.4.2,- tagged ==0.7.2,- template-haskell ==2.9.0.0,- text ==1.2.0.3,- time ==1.4.2,+ stm ==2.4.4,+ stm-chans ==3.0.0.3,+ streaming-commons ==0.1.10.0,+ syb ==0.4.4,+ tagged ==0.7.3,+ template-haskell ==2.10.0.0,+ text ==1.2.0.4,+ time ==1.5.0.1, tls ==1.2.16,- trace ==0.1.0.4,- transformers ==0.4.1.0,- transformers-base ==0.4.3,- transformers-compat ==0.3.3.4,- unix ==2.7.0.1,+ trace ==0.1.0.5,+ transformers ==0.4.2.0,+ transformers-base ==0.4.4,+ transformers-compat ==0.4.0.4,+ unix ==2.7.1.0, unordered-containers ==0.2.5.1,- utf8-string ==0.3.8,- vector ==0.10.11.0,+ utf8-string ==1,+ vector ==0.10.12.3, void ==0.7, x509 ==1.5.0.1, x509-store ==1.5.0, x509-system ==1.5.0, x509-validation ==1.5.1, yaml ==0.8.10.1,- zlib ==0.5.4.1+ zlib ==0.5.4.2
+ example/Example.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++-- |+-- Module: Example+-- Copyright: Copyright © 2015 PivotCloud, Inc.+-- License: Apache-2.0+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+module Main+( main+) where++import Distribution.Simple.Utils (withTempFile)++import System.IO+import System.Logger++main ∷ IO ()+main = do++ -- log to console+ withConsoleLogger Info $ withLabel ("logger", "console") run++ -- log to a file+ withTempFile "." "logfile.log" $ \f h → do+ hClose h+ withFileLogger f Info $ withLabel ("logger", "file") run+ readFile f >>= putStrLn++ where+ f = withLevel Debug $ logg Debug "debug f"++ run = do+ logg Info "moin"+ withLabel ("function", "f") f+ logg Debug "don't show this"+ logg Info "tschüss"+
src/System/Logger.hs view
@@ -59,6 +59,7 @@ , defaultLogConfig , validateLogConfig , pLogConfig+, pLogConfig_ ) where import Configuration.Utils hiding (Lens')@@ -159,7 +160,12 @@ <*< logConfigBackend %.: "backend" × o pLogConfig ∷ MParser LogConfig-pLogConfig = id- <$< logConfigLogger %:: pLoggerConfig- <*< logConfigBackend %:: pHandleBackendConfig+pLogConfig = pLogConfig_ "" +pLogConfig_+ ∷ T.Text+ -- ^ prefix for this and all subordinate command line options.+ → MParser LogConfig+pLogConfig_ prefix = id+ <$< logConfigLogger %:: pLoggerConfig_ prefix+ <*< logConfigBackend %:: pHandleBackendConfig_ prefix
src/System/Logger/Backend/ColorOption.hs view
@@ -26,6 +26,7 @@ -- An option that indicates whether ANSI color escapes shall -- be used in textual output. +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-}@@ -39,18 +40,26 @@ , colorOptionText , defaultColorOption , pColorOption+, pColorOption_ , useColor ) where +#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif+ import Configuration.Utils import Control.DeepSeq import Control.Monad.Except import qualified Data.CaseInsensitive as CI+#if ! MIN_VERSION_base(4,8,0) import Data.Monoid+#endif import Data.Monoid.Unicode import Data.String+import qualified Data.Text as T import Data.Typeable import GHC.Generics@@ -105,8 +114,14 @@ parseJSON = withText "ColorOption" $ either fail return ∘ readColorOption pColorOption ∷ O.Parser ColorOption-pColorOption = option (eitherReader readColorOption)- × long "color"+pColorOption = pColorOption_ ""++pColorOption_+ ∷ T.Text+ -- ^ prefix for the command line options.+ → O.Parser ColorOption+pColorOption_ prefix = option (eitherReader readColorOption)+ × long (T.unpack prefix ⊕ "color") ⊕ short 'c' ⊕ help "whether to use ANSI terminal colors in the output"
src/System/Logger/Backend/Handle.hs view
@@ -43,6 +43,7 @@ , readLoggerHandleConfig , validateLoggerHandleConfig , pLoggerHandleConfig+, pLoggerHandleConfig_ -- * Backend Configuration , HandleBackendConfig(..)@@ -51,6 +52,7 @@ , defaultHandleBackendConfig , validateHandleBackendConfig , pHandleBackendConfig+, pHandleBackendConfig_ -- * Backend Implementation , withHandleBackend@@ -134,8 +136,14 @@ parseJSON = withText "LoggerHandleConfig" $ either fail return ∘ readLoggerHandleConfig pLoggerHandleConfig ∷ O.Parser LoggerHandleConfig-pLoggerHandleConfig = option (eitherReader readLoggerHandleConfig)- × long "logger-backend-handle"+pLoggerHandleConfig = pLoggerHandleConfig_ ""++pLoggerHandleConfig_+ ∷ T.Text+ -- ^ prefix for the command line options.+ → O.Parser LoggerHandleConfig+pLoggerHandleConfig_ prefix = option (eitherReader readLoggerHandleConfig)+ × long (T.unpack prefix ⊕ "logger-backend-handle") ⊕ metavar "stdout|stderr|file:<FILENAME>" ⊕ help "handle where the logs are written" @@ -184,10 +192,16 @@ <*< handleBackendConfigHandle ..: "handle" × o pHandleBackendConfig ∷ MParser HandleBackendConfig-pHandleBackendConfig = id- <$< handleBackendConfigColor .:: pColorOption- <*< handleBackendConfigHandle .:: pLoggerHandleConfig+pHandleBackendConfig = pHandleBackendConfig_ "" +pHandleBackendConfig_+ ∷ T.Text+ -- ^ prefix for this and all subordinate command line options.+ → MParser HandleBackendConfig+pHandleBackendConfig_ prefix = id+ <$< handleBackendConfigColor .:: pColorOption_ prefix+ <*< handleBackendConfigHandle .:: pLoggerHandleConfig_ prefix+ -- -------------------------------------------------------------------------- -- -- Backend Implementation @@ -213,7 +227,8 @@ → LoggerBackend T.Text handleBackend h colored eitherMsg = do T.hPutStrLn h- $ inLevelColor colored ("[" ⊕ sshow level ⊕ "] ")+ $ formatIso8601Milli (msg ^. logMsgTime) ⊕ " "+ ⊕ inLevelColor colored ("[" ⊕ sshow level ⊕ "] ") ⊕ inScopeColor colored ("[" ⊕ formatedScope ⊕ "] ") ⊕ (msg ^. logMsg) where
src/System/Logger/Internal.hs view
@@ -28,16 +28,71 @@ module System.Logger.Internal ( sshow+, formatIso8601+, formatIso8601Milli+, formatIso8601Micro+, timeSpecToUtc ) where +import Data.Monoid.Unicode+import Data.Time.Clock+import Data.Time.Clock.POSIX+import Data.Time.Format import Data.String +import Numeric.Natural+ import Prelude.Unicode +import System.Clock+ sshow ∷ (Show a, IsString b) ⇒ a → b sshow = fromString ∘ show {-# INLINE sshow #-}++-- | Format 'TimeSpec' as ISO8601 date-time string with+-- microseconds precision.+--+formatIso8601Micro+ ∷ IsString a+ ⇒ TimeSpec+ → a+formatIso8601Micro = formatIso8601 6++-- | Format 'TimeSpec' as ISO8601 date-time string with+-- milliseconds precision.+--+formatIso8601Milli+ ∷ IsString a+ ⇒ TimeSpec+ → a+formatIso8601Milli = formatIso8601 3++-- | Format 'TimeSpec' as ISO8601 date-time string with+-- the given sub-second precision.+--+formatIso8601+ ∷ IsString a+ ⇒ Natural+ -- ^ precision, a value between 0 (seconds) and 6 (microseconds)+ → TimeSpec+ → a+formatIso8601 precision+ = fromString+ ∘ (⊕ "Z")+ ∘ take (fromIntegral $ 21 + precision)+ ∘ (⊕ replicate (fromIntegral precision) '0')+ ∘ formatTime defaultTimeLocale ("%Y-%m-%dT%H:%M:%S%Q")+ ∘ timeSpecToUtc++-- | Convert a 'TimeSpec' value into 'UTCTime'+--+timeSpecToUtc+ ∷ TimeSpec+ → UTCTime+timeSpecToUtc (TimeSpec s ns) =+ posixSecondsToUTCTime (realToFrac s + realToFrac ns * 1e-9)
+ src/System/Logger/Internal/Queue.hs view
@@ -0,0 +1,146 @@+-- Copyright (c) 2014-2015 PivotCloud, Inc.+--+-- System.Logger+--+-- Please feel free to contact us at licensing@pivotmail.com with any+-- contributions, additions, or other feedback; we would love to hear from+-- you.+--+-- Licensed under the Apache License, Version 2.0 (the "License"); you may+-- not use this file except in compliance with the License. You may obtain a+-- copy of the License at http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT+-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the+-- License for the specific language governing permissions and limitations+-- under the License.++-- |+-- Module: System.Logger.Internal.Queue+-- Description: Queues for Usage with Yet Another Logger+-- Copyright: Copyright © 2015 PivotCloud, Inc.+-- License: Apache-2.0+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++module System.Logger.Internal.Queue+( BoundedCloseableQueue(..)+, FairTBMQueue+, TBMQueue+, TBMChan+) where++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) = 1+#endif++#if ! MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TBMChan+import Control.Concurrent.STM.TBMQueue+import Control.Monad.Unicode++import Numeric.Natural++import Prelude.Unicode+++-- -------------------------------------------------------------------------- --+-- Queue Abstraction++class BoundedCloseableQueue q a | q → a where+ newQueue ∷ Natural → IO q+ closeQueue ∷ q → IO ()++ -- | Returns 'False' if and only if the queue+ -- is closed. If the queue is full this function blocks.+ --+ writeQueue ∷ q → a → IO Bool++ -- | Non-blocking version of 'writeQueue'. Returns 'Nothing' if the+ -- queue was full. Otherwise it returns 'Just True' if the value+ -- was successfully written and 'Just False' if the queue was closed.+ --+ tryWriteQueue ∷ q → a → IO (Maybe Bool)++ -- | Returns 'Nothing' if and only if the queue is+ -- closed. If this queue is empty this function blocks.+ --+ readQueue ∷ q → IO (Maybe a)++ {-+ -- | Non-blocking version of 'readQueue'. Returns 'Nothing' if the+ -- queue is empty. Returns 'Just Nothing' if the queue is closed+ -- and and 'Just (Just a)' otherwise.+ --+ tryReadQueue ∷ q → IO (Maybe (Maybe a))+ -}++-- -------------------------------------------------------------------------- --+-- TBMQueue++instance BoundedCloseableQueue (TBMQueue a) a where+ newQueue = newTBMQueueIO ∘ fromIntegral+ closeQueue = atomically ∘ closeTBMQueue+ writeQueue q a = atomically $ isClosedTBMQueue q ≫= \case+ True → return False+ False → do+ writeTBMQueue q a+ return True+ tryWriteQueue q a = atomically $ tryWriteTBMQueue q a ≫= \case+ Nothing → return $ Just False+ Just False → return Nothing+ Just True → return $ Just True+ readQueue q = atomically $ readTBMQueue q++-- -------------------------------------------------------------------------- --+-- TBMChan++instance BoundedCloseableQueue (TBMChan a) a where+ newQueue = newTBMChanIO ∘ fromIntegral+ closeQueue = atomically ∘ closeTBMChan+ writeQueue q a = atomically $ isClosedTBMChan q ≫= \case+ True → return False+ False → do+ writeTBMChan q a+ return True+ tryWriteQueue q a = atomically $ tryWriteTBMChan q a ≫= \case+ Nothing → return $ Just False+ Just False → return Nothing+ Just True → return $ Just True+ readQueue q = atomically $ readTBMChan q++-- -------------------------------------------------------------------------- --+-- FairTBMQueue++data FairTBMQueue α = FairTBMQueue+ { fairTBMQueueQueue ∷ !(TBMQueue α)+ , fairTBMQueueLock ∷ !(MVar ())+ }++instance BoundedCloseableQueue (FairTBMQueue a) a where+ newQueue i = FairTBMQueue <$> newTBMQueueIO (fromIntegral i) <*> newMVar ()+ closeQueue = closeQueue ∘ fairTBMQueueQueue+ readQueue = readQueue ∘ fairTBMQueueQueue+ writeQueue FairTBMQueue{..} a = do+ withMVar fairTBMQueueLock $ \_ → do+ writeQueue fairTBMQueueQueue a+ tryWriteQueue FairTBMQueue{..} a = do+ withMVar fairTBMQueueLock $ \_ → do+ tryWriteQueue fairTBMQueueQueue a+
src/System/Logger/Logger.hs view
@@ -42,7 +42,9 @@ -- * Logger , Logger , withLogger+, withLogger_ , withLogFunction+, withLogFunction_ -- * LoggerT Monad Transformer , LoggerT@@ -56,9 +58,14 @@ , loggerConfigQueueSize , loggerConfigThreshold , loggerConfigScope+, loggerConfigPolicy+, loggerConfigExceptionLimit+, loggerConfigExceptionWait+, loggerConfigExitTimeout , defaultLoggerConfig , validateLoggerConfig , pLoggerConfig+, pLoggerConfig_ ) where
src/System/Logger/Logger/Internal.hs view
@@ -31,6 +31,7 @@ -- module as an example and starting point. -- +{-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}@@ -49,19 +50,27 @@ , loggerConfigQueueSize , loggerConfigThreshold , loggerConfigScope+, loggerConfigPolicy+, loggerConfigExceptionLimit+, loggerConfigExceptionWait+, loggerConfigExitTimeout , defaultLoggerConfig , validateLoggerConfig , pLoggerConfig+, pLoggerConfig_ -- * Logger , Logger , loggerScope , loggerThreshold , createLogger+, createLogger_ , releaseLogger , withLogger+, withLogger_ , loggCtx , withLogFunction+, withLogFunction_ -- * LoggerT Monad Transformer , LoggerT@@ -71,10 +80,10 @@ import Configuration.Utils hiding (Lens', Error) +import Control.Concurrent (threadDelay) import Control.Concurrent.Async -- FIXME: use a better data structure with non-amortized complexity bounds import Control.Monad.STM-import Control.Concurrent.STM.TBMQueue import Control.Concurrent.STM.TVar import Control.DeepSeq import Control.Exception.Lifted@@ -85,34 +94,73 @@ import Control.Monad.Unicode import Data.Monoid.Unicode+import qualified Data.Text as T import Data.Typeable+import qualified Data.Text.IO as T (hPutStrLn)+import Data.Void import GHC.Generics +import Numeric.Natural+ import Prelude.Unicode +import System.Clock+import System.IO (stderr)+import System.Timeout+ -- internal modules import System.Logger.Internal+import System.Logger.Internal.Queue import System.Logger.Types -- -------------------------------------------------------------------------- --+-- Orphans++-- Submitted pull request to aeson <https://github.com/bos/aeson/pull/243>+instance ToJSON Natural where+ toJSON = Number ∘ fromIntegral++-- Submitted pull request to aeson <https://github.com/bos/aeson/pull/243>+instance FromJSON Natural where+ parseJSON = withScientific "Natural" $ \n →+ if n < 0+ then fail $ "expected a natural number but got " ⊕ show n+ else pure $ floor n+ -- this seems a little odd but corresponds to all other aeson+ -- instances for integral types++-- -------------------------------------------------------------------------- -- -- Logger Configuration -- | Logger Configuration -- data LoggerConfig = LoggerConfig- { _loggerConfigQueueSize ∷ !Int+ { _loggerConfigQueueSize ∷ !Natural , _loggerConfigThreshold ∷ !LogLevel -- ^ initial log threshold, can be changed later on , _loggerConfigScope ∷ !LogScope -- ^ initial stack of log labels, can be extended later on , _loggerConfigPolicy ∷ !LogPolicy -- ^ how to deal with a congested logging pipeline+ , _loggerConfigExceptionLimit ∷ !(Maybe Natural)+ -- ^ number of consecutive backend exception that can occur before the logger+ -- 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.+ , _loggerConfigExceptionWait ∷ !(Maybe Natural)+ -- ^ number of microseconds to wait after an exception from the backend.+ -- If this is 'Nothing' the logger won't wait at all after an exception.+ , _loggerConfigExitTimeout ∷ !(Maybe Natural)+ -- ^ timeout in microseconds for the logger to flush the queue and+ -- deliver all remaining log messages on termination. If this is 'Nothing'+ -- termination of the logger blogs until all mesages are delivered. } deriving (Show, Read, Eq, Ord, Typeable, Generic) -loggerConfigQueueSize ∷ Lens' LoggerConfig Int+loggerConfigQueueSize ∷ Lens' LoggerConfig Natural loggerConfigQueueSize = lens _loggerConfigQueueSize $ \a b → a { _loggerConfigQueueSize = b } loggerConfigThreshold ∷ Lens' LoggerConfig LogLevel@@ -124,14 +172,34 @@ loggerConfigPolicy ∷ Lens' LoggerConfig LogPolicy loggerConfigPolicy = lens _loggerConfigPolicy $ \a b → a { _loggerConfigPolicy = b } +loggerConfigExceptionLimit ∷ Lens' LoggerConfig (Maybe Natural)+loggerConfigExceptionLimit = lens _loggerConfigExceptionLimit $ \a b → a { _loggerConfigExceptionLimit = b }++loggerConfigExceptionWait ∷ Lens' LoggerConfig (Maybe Natural)+loggerConfigExceptionWait = lens _loggerConfigExceptionWait $ \a b → a { _loggerConfigExceptionWait = b }++loggerConfigExitTimeout ∷ Lens' LoggerConfig (Maybe Natural)+loggerConfigExitTimeout = lens _loggerConfigExitTimeout $ \a b → a { _loggerConfigExitTimeout = b }+ instance NFData LoggerConfig +-- | Default Logger configuration+--+-- The exception limit for backend exceptions is 10 and the wait time between+-- exceptions is 1000. This means that in case of a defunctioned backend the+-- logger will exist by throwing an exception after at least one second.+-- When the logger is terminated it is granted 1 second to flush the queue+-- and deliver all remaining log messages.+-- defaultLoggerConfig ∷ LoggerConfig defaultLoggerConfig = LoggerConfig { _loggerConfigQueueSize = 1000 , _loggerConfigThreshold = Warn , _loggerConfigScope = [] , _loggerConfigPolicy = LogPolicyDiscard+ , _loggerConfigExceptionLimit = Just 10+ , _loggerConfigExceptionWait = Just 1000+ , _loggerConfigExitTimeout = Just 1000000 } validateLoggerConfig ∷ ConfigValidation LoggerConfig λ@@ -143,6 +211,9 @@ , "log_level" .= _loggerConfigThreshold , "scope" .= _loggerConfigScope , "policy" .= _loggerConfigPolicy+ , "exception_limit" .= _loggerConfigExceptionLimit+ , "exception_wait" .= _loggerConfigExceptionWait+ , "exit_timeout" .= _loggerConfigExitTimeout ] instance FromJSON (LoggerConfig → LoggerConfig) where@@ -151,15 +222,36 @@ <*< loggerConfigThreshold ..: "log_level" × o <*< loggerConfigScope ..: "scope" × o <*< loggerConfigPolicy ..: "policy" × o+ <*< loggerConfigExceptionLimit ..: "exception_limit" × o+ <*< loggerConfigExceptionWait ..: "exception_wait" × o+ <*< loggerConfigExitTimeout ..: "exit_timeout" × o pLoggerConfig ∷ MParser LoggerConfig-pLoggerConfig = id+pLoggerConfig = pLoggerConfig_ ""++pLoggerConfig_+ ∷ T.Text+ -- ^ prefix for this and all subordinate command line options.+ → MParser LoggerConfig+pLoggerConfig_ prefix = id <$< loggerConfigQueueSize .:: option auto- × long "queue-size"+ × long (T.unpack prefix ⊕ "queue-size") ⊕ metavar "INT" ⊕ help "size of the internal logger queue"- <*< loggerConfigThreshold .:: pLogLevel- <*< loggerConfigPolicy .:: pLogPolicy+ <*< loggerConfigThreshold .:: pLogLevel_ prefix+ <*< loggerConfigPolicy .:: pLogPolicy_ prefix+ <*< loggerConfigExceptionLimit .:: fmap Just × option auto+ × long (T.unpack prefix ⊕ "exception-limit")+ ⊕ metavar "INT"+ ⊕ help "maximal number of backend failures before and exception is raised"+ <*< loggerConfigExceptionWait .:: fmap Just × option auto+ × long (T.unpack prefix ⊕ "exception-wait")+ ⊕ metavar "INT"+ ⊕ help "time to wait after an backend failure occured"+ <*< loggerConfigExitTimeout .:: fmap Just × option auto+ × long (T.unpack prefix ⊕ "exit-timeout")+ ⊕ metavar "INT"+ ⊕ help "timeout for flushing the log message queue on exit" -- -------------------------------------------------------------------------- -- -- Logger@@ -177,7 +269,9 @@ -- are enqueued and processed asynchronously by a background worker that takes -- the message from queue and calls the backend function for each log message. ---type LoggerQueue a = TBMQueue (LogMessage a)+type LoggerQueue a = TBMChan (LogMessage a)+-- type LoggerQueue a = TBMQueue (LogMessage a)+-- type LoggerQueue a = FairTBMQueue (LogMessage a) data Logger a = Logger { _loggerQueue ∷ !(LoggerQueue a)@@ -185,7 +279,9 @@ , _loggerThreshold ∷ !LogLevel , _loggerScope ∷ !LogScope , _loggerPolicy ∷ !LogPolicy- , _loggerMissed ∷ !(TVar Int)+ , _loggerMissed ∷ !(TVar Natural)+ , _loggerExitTimeout ∷ !(Maybe Natural)+ , _loggerErrLogFunction ∷ !(T.Text → IO ()) } deriving (Typeable, Generic) @@ -209,19 +305,87 @@ loggerPolicy = lens _loggerPolicy $ \a b → a { _loggerPolicy = b } {-# INLINE loggerPolicy #-} -loggerMissed ∷ Lens' (Logger a) (TVar Int)+loggerMissed ∷ Lens' (Logger a) (TVar Natural) loggerMissed = lens _loggerMissed $ \a b → a { _loggerMissed = b } {-# INLINE loggerMissed #-} +loggerExitTimeout ∷ Lens' (Logger a) (Maybe Natural)+loggerExitTimeout = lens _loggerExitTimeout $ \a b → a { _loggerExitTimeout = b }+{-# INLINE loggerExitTimeout #-}++loggerErrLogFunction ∷ Lens' (Logger a) (T.Text → IO ())+loggerErrLogFunction = lens _loggerErrLogFunction $ \a b → a { _loggerErrLogFunction = b }+{-# INLINE loggerErrLogFunction #-}++-- | Create a new logger. A logger created with this function must be released+-- with a call to 'releaseLogger' and must not be used after it is released.+--+-- The logger calls the backend function exactly once for each log message. If+-- the backend throws an exception, the message is discarded and the exception+-- is dealt with as follows:+--+-- 1. The exception is logged. First it is attempt to log to the backend itself.+-- If that fails, due to another exception, the incident is logged to an+-- alternate log sink, usually @T.putStrLn@ or just @const (return ())@.+--+-- 2. The message is discarded. If the backend exception is of type+-- 'BackendTerminatedException' the exception is rethrown by the logger which+-- causes the logger to exit. Otherwise the exception is appended to the+-- exception list.+--+-- 3. If the length of the exception list exceeds a configurable threshold+-- a 'BackendTooManyExceptions' exception is thrown (which causes the logger+-- to terminate).+--+-- 4. Otherwise the logger waits for a configurable amount of time before+-- proceeding.+--+-- 5. The next time the backend returns without throwing an exception the+-- exception list is reset to @[]@.+--+-- Backends are expected to implement there own retry logic if required.+-- Backends may base their behavoir on the 'LogPolicy' that is effective for a+-- given message. Please refer to the documentation of 'LoggerBackend' for+-- more details about how to implement and backend.+--+-- Backends are called synchronously. Backends authors must thus ensure that a+-- backend returns promptly in accordance with the 'LogPolicy' and the size of+-- the logger queue. For more elaborate failover strategies, such as batching+-- retried messages with the delivery of new messages, backends may implement+-- there only internal queue.+--+-- Exceptions of type 'BlockedIndefinitelyOnSTM' and 'NestedAtomically' are+-- rethrown immediately. Those exceptions indicate a bug in the code due to+-- unsafe usage of 'createLogger'. This exceptions shouldn't be possible when+-- 'withLogger' is used to provide the logger and the reference to the+-- logger isn't used outside the scope of the bracket.+-- createLogger ∷ MonadIO μ ⇒ LoggerConfig → LoggerBackend a → μ (Logger a)-createLogger LoggerConfig{..} backend = liftIO $ do- queue ← newTBMQueueIO _loggerConfigQueueSize+createLogger = createLogger_ (T.hPutStrLn stderr)++-- | A version of 'createLogger' that takes as an extra argument+-- a function for logging errors in the logging system.+--+createLogger_+ ∷ MonadIO μ+ ⇒ (T.Text → IO ())+ -- ^ alternate sink for logging exceptions in the logger itself.+ → LoggerConfig+ → LoggerBackend a+ → μ (Logger a)+createLogger_ errLogFun LoggerConfig{..} backend = liftIO $ do+ queue ← newQueue (fromIntegral _loggerConfigQueueSize) missed ← newTVarIO 0- worker ← backendWorker backend queue missed+ 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+ -- since the constructors of 'Logger' are not exported no external+ -- code could throw an asynchronous exception to this thread.+ link worker return $ Logger { _loggerQueue = queue , _loggerWorker = worker@@ -229,64 +393,136 @@ , _loggerScope = _loggerConfigScope , _loggerPolicy = _loggerConfigPolicy , _loggerMissed = missed+ , _loggerExitTimeout = _loggerConfigExitTimeout+ , _loggerErrLogFunction = errLogFun } --- FIXME: make this more reliable------ For instance if 'readTBMQeue' (not sure if that can happen) throws an--- exception 'releaseLogger' may not terminate.+-- | A backend worker. ----- We must deal better with exceptions thrown by the backend: we should--- use some reasonable re-spawn logic. Right now there is the risk of a--- busy loop.+-- The only way for this function to exist without an exception is when+-- the interal logger queue is closed through a call to 'releaseLogger'. -- backendWorker- ∷ LoggerBackend a+ ∷ (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'+ -- 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.+ → Maybe Natural+ -- ^ number of microseconds to wait after an exception from the backend.+ -- If this is 'Nothing' the logger won't wait at all after an exception.+ → LoggerBackend a → LoggerQueue a- → TVar Int+ → TVar Natural → IO (Async ())-backendWorker backend queue missed = async $ go `catchAny` \e → do- -- chances are that this fails, too...- (backend ∘ Left $ backendErrorMsg (sshow e)) `catchAny` (const $ return ())- go+backendWorker errLogFun errLimit errWait backend queue missed = mask_ $+ asyncWithUnmask $ \umask → umask (go []) `catch` \(_ ∷ LoggerKilled) → return () where- go = atomically readMsg ≫= \case- -- when the queue is closed and empty the backendWorker returns- Nothing → return ()- -- When there are still messages to process the backendWorker loops- Just msg → backend msg ≫ go + -- we assume that 'BlockedIndefinitelyOnSTM' and 'NestedAtomically' are the+ -- only exceptions beside asynchronous exceptions that can be thrown by+ -- @atomically readMsg@.+ --+ go errList = do+ -- That's not ideal since we generally don't know how long we have to wait.+ -- But here it's OK, since the time is used in case there are discarded+ -- messages. We don't expect to wait long in that case.+ t ← getTime Realtime+ readMsg t ≫= \case++ -- When the queue is closed and empty the backendWorker returns.+ -- This is the only way for backendWorker to exit without an exception.+ Nothing → return ()++ -- call backend for the message and loop+ Just msg → runBackend errList msg ≫= go++ runBackend errList msg = (backend msg ≫ return []) `catchAny` \e → do++ -- try to log exception to backend+ t ← getTime Realtime+ let errMsg = backendErrorMsg t (sshow e)+ backend (Left errMsg) `catchAny` \_ →+ -- log exception to alternate sink+ errLogFun (errLogMsg errMsg) `catchAny` \_ →+ -- discard exception log+ return ()++ -- decide how to proceed in case of an error+ case fromException e of+ Just (BackendTerminatedException _ ∷ LoggerException Void) → throwIO e+ _ → do+ maybe (return ()) (threadDelay ∘ fromIntegral) errWait+ let errList' = e:errList+ case errLimit of+ Nothing → return []+ Just n+ | fromIntegral (length errList') > n → throwIO $ BackendTooManyExceptions (reverse errList')+ | otherwise → return errList'+ -- As long as the queue is not closed and empty this retries until -- a new message arrives --- readMsg = do- n ← swapTVar missed 0+ readMsg t = do+ n ← atomically $ swapTVar missed 0 if n > 0 then do- return ∘ Just ∘ Left $ discardMsg n+ return ∘ Just ∘ Left $ discardMsg t n else- fmap Right <$> readTBMQueue queue+ fmap Right <$> readQueue queue -- A log message that informs about discarded log messages- discardMsg n = LogMessage+ discardMsg t n = LogMessage { _logMsg = "discarded " ⊕ sshow n ⊕ " log messages" , _logMsgLevel = Warn , _logMsgScope = [("system", "logger")]+ , _logMsgTime = t } - backendErrorMsg e = LogMessage+ -- A log message that informs about an error in the backend+ backendErrorMsg t e = LogMessage { _logMsg = e , _logMsgLevel = Error , _logMsgScope = [("system", "logger"), ("component", "backend")]+ , _logMsgTime = t } + -- format a log message that is written to the error sink+ errLogMsg LogMessage{..} = T.unwords+ [ formatIso8601Milli _logMsgTime+ , "[" ⊕ logLevelText _logMsgLevel ⊕ "]"+ , formatScope _logMsgScope+ , _logMsg+ ]++ formatScope scope = "[" ⊕ T.intercalate "," (map formatLabel scope) ⊕ "]"+ formatLabel (k,v) = "(" ⊕ k ⊕ "," ⊕ v ⊕ ")"++-- | An Exception that is used internally to kill the logger without killing+-- the calling thread.+--+-- In 'createLogger' the worker 'Async' is 'link'ed to the calling+-- thread. Thus, when 'releaseLogger' calls 'cancel' on that 'Async'+-- the 'ThreadKilled' exception would be rethrown and kill the thread that+-- called 'cancel'.+--+data LoggerKilled = LoggerKilled deriving (Show, Typeable)+instance Exception LoggerKilled+ releaseLogger ∷ MonadIO μ ⇒ Logger a → μ () releaseLogger Logger{..} = liftIO $ do- atomically $ closeTBMQueue _loggerQueue- wait _loggerWorker+ closeQueue _loggerQueue+ complete ← maybe (fmap Just) (timeout ∘ fromIntegral) _loggerExitTimeout $ wait _loggerWorker+ case complete of+ Nothing → _loggerErrLogFunction "logger: timeout while flushing queue; remaining messages are discarded"+ Just _ → return ()+ cancelWith _loggerWorker LoggerKilled -- | Provide a computation with a 'Logger'. --@@ -305,15 +541,31 @@ -- > config = defaultLogConfig -- > & logConfigLogger ∘ loggerConfigThreshold .~ level --+-- For detailed information about how backends are executed refer+-- to the documentation of 'createLogger'.+-- withLogger ∷ (MonadIO μ, MonadBaseControl IO μ) ⇒ LoggerConfig → LoggerBackend a → (Logger a → μ α) → μ α-withLogger config backend =- bracket (createLogger config backend) releaseLogger+withLogger = withLogger_ (T.hPutStrLn stderr) +-- | A version of 'withLogger' that takes as an extra argument+-- a function for logging errors in the logging system.+--+withLogger_+ ∷ (MonadIO μ, MonadBaseControl IO μ)+ ⇒ (T.Text → IO ())+ -- ^ alternate sink for logging exceptions in the logger itself.+ → LoggerConfig+ → LoggerBackend a+ → (Logger a → μ α)+ → μ α+withLogger_ errLogFun config backend =+ bracket (createLogger_ errLogFun config backend) releaseLogger+ -- | For simple cases, when the logger threshold and the logger scope is -- constant this function can be used to directly initialize a log function. --@@ -323,17 +575,25 @@ → LoggerBackend a → (LogFunctionIO a → μ α) → μ α-withLogFunction config backend f = withLogger config backend $ f ∘ loggCtx+withLogFunction = withLogFunction_ (T.hPutStrLn stderr) +-- | For simple cases, when the logger threshold and the logger scope is+-- constant this function can be used to directly initialize a log function.+--+withLogFunction_+ ∷ (Show a, Typeable a, NFData a, MonadIO μ, MonadBaseControl IO μ)+ ⇒ (T.Text → IO ())+ -- ^ alternate sink for logging exceptions in the logger itself.+ → LoggerConfig+ → LoggerBackend a+ → (LogFunctionIO a → μ α)+ → μ α+withLogFunction_ errLogFun config backend f =+ withLogger_ errLogFun config backend $ f ∘ loggCtx+ -- -------------------------------------------------------------------------- -- -- Log Function -data LoggerException a- = QueueFullException (LogMessage a)- deriving (Show, Eq, Ord, Typeable, Generic)--instance (Typeable a, Show a) ⇒ Exception (LoggerException a)- -- Log a message with the given logger context -- -- If the logger context has been released (by closing the queue)@@ -347,22 +607,28 @@ case _loggerThreshold of Quiet → return () threshold- | level ≤ threshold → liftIO ∘ atomically $+ | level ≤ threshold → liftIO $ do+ t ← getTime Realtime writeWithLogPolicy $!! LogMessage { _logMsg = msg , _logMsgLevel = level , _logMsgScope = _loggerScope+ , _logMsgTime = t } | otherwise → return () where writeWithLogPolicy lmsg- | _loggerPolicy ≡ LogPolicyBlock = writeTBMQueue _loggerQueue lmsg- | otherwise = tryWriteTBMQueue _loggerQueue lmsg ≫= \case- Just False- | _loggerPolicy ≡ LogPolicyDiscard → modifyTVar' _loggerMissed succ- | _loggerPolicy ≡ LogPolicyRaise → throwSTM $ QueueFullException lmsg-- _ → return ()+ | _loggerPolicy ≡ LogPolicyBlock = void $ writeQueue _loggerQueue lmsg+ | otherwise = tryWriteQueue _loggerQueue lmsg ≫= \case+ -- Success+ Just True → return ()+ -- Queue is closed+ Just False → return ()+ -- Queue is full+ Nothing+ | _loggerPolicy ≡ LogPolicyDiscard → atomically $ modifyTVar' _loggerMissed succ+ | _loggerPolicy ≡ LogPolicyRaise → throwIO $ QueueFullException lmsg+ | otherwise → return () -- won't happen, covered above. {-# INLINEABLE loggCtx #-} -- -------------------------------------------------------------------------- --
src/System/Logger/Types.hs view
@@ -25,6 +25,7 @@ -- Stability: experimental -- +{-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-}@@ -47,22 +48,28 @@ , logLevelText , readLogLevel , pLogLevel+, pLogLevel_ -- * LogPolicy , LogPolicy(..) , logPolicyText , readLogPolicy , pLogPolicy+, pLogPolicy_ -- * LogLabel , LogLabel , LogScope +-- * Logger Exception+, LoggerException(..)+ -- * Logger Backend , LogMessage(..) , logMsg , logMsgLevel , logMsgScope+, logMsgTime , LoggerBackend -- * Logger Frontend@@ -79,13 +86,13 @@ , withLabel , clearScope , popLabel-, MonadLogIO(..) ) where import Configuration.Utils hiding (Lens', Error) import Control.DeepSeq+import Control.Exception import Control.Lens hiding ((.=)) import Control.Monad.Base import Control.Monad.Except@@ -104,6 +111,7 @@ import qualified Data.Text as T import Data.Text.Lens import Data.Typeable+import Data.Void import GHC.Generics @@ -111,6 +119,8 @@ import Prelude.Unicode +import System.Clock+ -- -------------------------------------------------------------------------- -- -- Log-Level @@ -155,8 +165,14 @@ parseJSON = withText "LogLevel" $ either fail return ∘ readLogLevel pLogLevel ∷ O.Parser LogLevel-pLogLevel = option (eitherReader readLogLevel)- × long "loglevel"+pLogLevel = pLogLevel_ ""++pLogLevel_+ ∷ T.Text+ -- ^ prefix for the command line options.+ → O.Parser LogLevel+pLogLevel_ prefix = option (eitherReader readLogLevel)+ × long (T.unpack prefix ⊕ "log-level") ⊕ metavar "quiet|error|warn|info|debug" ⊕ help "threshold for log messages" @@ -200,8 +216,14 @@ parseJSON = withText "LogPolicy" $ either fail return ∘ readLogPolicy pLogPolicy ∷ O.Parser LogPolicy-pLogPolicy = option (eitherReader readLogPolicy)- × long "log-policy"+pLogPolicy = pLogPolicy_ ""++pLogPolicy_+ ∷ T.Text+ -- ^ prefix for the command line options.+ → O.Parser LogPolicy+pLogPolicy_ prefix = option (eitherReader readLogPolicy)+ × long (T.unpack prefix ⊕ "log-policy") ⊕ metavar "block|raise|discard" ⊕ help "how to deal with a congested logging pipeline" @@ -212,6 +234,18 @@ type LogScope = [LogLabel] -- -------------------------------------------------------------------------- --+-- Logger Exception++data LoggerException a where+ QueueFullException ∷ LogMessage a → LoggerException a+ BackendTerminatedException ∷ SomeException → LoggerException Void+ BackendTooManyExceptions ∷ [SomeException] → LoggerException Void+ deriving (Typeable)++deriving instance Show a ⇒ Show (LoggerException a)+instance (Typeable a, Show a) ⇒ Exception (LoggerException a)++-- -------------------------------------------------------------------------- -- -- Backend -- | The Internal log message type.@@ -229,6 +263,13 @@ -- ^ efficiency of this depends on whether this is shared -- between log messsages. Usually this should be just a pointer to -- a shared list.+ , _logMsgTime ∷ !TimeSpec+ -- ^ a POSIX timestamp+ --+ -- UTC seconds elapsed since UNIX Epoch as returned by @clock_gettime@+ -- on the respective system. NOTE that POSIX is ambigious with regard+ -- to treatment of leap seconds, and some implementations may actually+ -- return TAI. } deriving (Show, Read, Eq, Ord, Typeable, Generic) @@ -241,24 +282,38 @@ logMsgScope ∷ Lens' (LogMessage a) LogScope logMsgScope = lens _logMsgScope $ \a b → a { _logMsgScope = b } +logMsgTime ∷ Lens' (LogMessage a) TimeSpec+logMsgTime = lens _logMsgTime $ \a b → a { _logMsgTime = b }++instance NFData TimeSpec instance NFData a ⇒ NFData (LogMessage a) -- | This is given to logger when it is created. It formats and delivers--- individual log messages synchronously.+-- individual log messages synchronously. The backend is called once for each+-- log message (that meets the required log level). -- -- The type parameter @a@ is expected to provide instances for 'Show' -- 'Typeable', and 'NFData'. ----- The 'Left' values of the argument allows the generation of log messages--- that are independent of the parameter @a@. The motivation for this is--- reporting issues in Logging system itself, like a full logger queue--- or providing statistics about the fill level of the queue. There may--- be other uses of this, too.+-- The 'Left' values of the argument allows the generation of log messages that+-- are independent of the parameter @a@. The motivation for this is reporting+-- issues in Logging system itself, like a full logger queue or providing+-- statistics about the fill level of the queue. There may be other uses of+-- this, too. ----- TODO there may be scenarios where chunked processing is beneficial.--- While this can be done in a closure of this function a more direct--- support might be desirable.+-- Backends that can fail are encouraged (but not forced) to take into account+-- the 'LogPolicy' that is effective for a message. For instance, a backend may+-- implement a reasonable retry logic for each message and then raise a+-- 'BackendTerminatedException' in case the policy is 'LogPolicyBlock' or+-- 'LogPolicyRaise' (thus causing the logger to exit immediately) and raise+-- some other exception otherwise (thus discarding the message without causing+-- the logger to not exit immediately). In addition a backend might retry+-- harder in case of 'LogPolicyBlock'. --+-- TODO there may be scenarios where chunked processing is beneficial. While+-- this can be done in a closure of this function, more direct support might+-- be desirable.+-- type LoggerBackend a = Either (LogMessage T.Text) (LogMessage a) → IO () -- -------------------------------------------------------------------------- --@@ -287,107 +342,6 @@ clearScope ∷ MonadLog a m ⇒ m α → m α clearScope = localScope $ const [] --- | Instances of 'MonadLog' that allow to obtain a 'LogFunctionIO' as plain--- value. This is helpful when dealing with frameworks that take a logging--- function in 'IO' as parameter.------ An instance of this class should apply the 'LogLevel', 'LogScope', and--- 'LogPolicy' at the time when 'logFunIO' is called and not when the returned--- action is excecuted. If the returned action is excecuted after the logger--- got released or otherwise invalidated the behavior should match the behavior--- on a congested logging pipeling accorrding to the log-policy that was in--- scope when 'logFunIO' was called.------ Even though it can be very convenient, instances of this class must be used--- with care. The action may contain in its closure a reference to some--- internal state of the 'MonadLog' instance. Beside of being a source of--- potential memory leaks, there also is nothing that prevents a programer to--- call this action outside of the valid scope of the 'MonadLog' instance. In--- case that the context of the 'MonadLog' instance depends on some state that--- gets explicitely deallocated this action may have unexectped behavior.----class MonadLog a m ⇒ MonadLogIO a m where- logFunIO ∷ m (LogFunctionIO a)---- -------------------------------------------------------------------------- ----- Logger Context---- | Abstraction of a logger context that can be used without dependening on--- a specific monadic context.------ The 'loggerFunIO' incorporates a 'LoggerBackend'. An instance of a 'LoggerCtx'--- is free to use a hard coded 'LoggerBackend' or to be usable with different--- 'LoggerBackend' functions. The latter is recommended but not required.------ You don't have to provide an instance of this for your logger. Instead you--- may just provide an instance of 'MonadLog' directly.------ If this doesn't fit your needs you may use a newtype wrapper and define--- your own instances.----class LoggerCtx ctx msg | ctx → msg where- loggerFunIO- ∷ (Show msg, Typeable msg, NFData msg)- ⇒ ctx- → LogFunctionIO msg-- setLoggerLevel ∷ Setter' ctx LogLevel- setLoggerScope ∷ Setter' ctx LogScope- setLoggerPolicy ∷ Setter' ctx LogPolicy-- withLoggerLevel ∷ LogLevel → ctx → (ctx → α) → α- withLoggerLevel level ctx f = f $ ctx & setLoggerLevel .~ level- {-# INLINE withLoggerLevel #-}-- withLoggerLabel ∷ LogLabel → ctx → (ctx → α) → α- withLoggerLabel label ctx f = f $ ctx & setLoggerScope %~ (:) label- {-# INLINE withLoggerLabel #-}-- withLoggerPolicy ∷ LogPolicy → ctx → (ctx → α) → α- withLoggerPolicy policy ctx f = f $ ctx & setLoggerPolicy .~ policy- {-# INLINE withLoggerPolicy #-}--newtype LoggerCtxT ctx m α = LoggerCtxT { unLoggerCtxT ∷ ReaderT ctx m α }- deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadReader ctx, MonadError a, MonadState a, MonadWriter a, MonadBase a, MonadTrace t)---- This should eventually be defined in Control.Monad.Trace.Class-instance (Monad m, MonadTrace t m) ⇒ MonadTrace t (ReaderT ctx m) where- traceScope s inner = liftWith (\run → traceScope s (run inner)) ≫= restoreT ∘ return- readTrace = lift readTrace--instance MonadTransControl (LoggerCtxT ctx) where- type StT (LoggerCtxT ctx) a = StT (ReaderT ctx) a- liftWith = defaultLiftWith LoggerCtxT unLoggerCtxT- restoreT = defaultRestoreT LoggerCtxT--instance MonadBaseControl b m ⇒ MonadBaseControl b (LoggerCtxT ctx m) where- type StM (LoggerCtxT ctx m) a = ComposeSt (LoggerCtxT ctx) m a- liftBaseWith = defaultLiftBaseWith- restoreM = defaultRestoreM--runLoggerCtxT- ∷ LoggerCtxT ctx m α- → ctx- → m α-runLoggerCtxT = runReaderT ∘ unLoggerCtxT--instance (Show a, Typeable a, NFData a, MonadIO m, LoggerCtx ctx a) ⇒ MonadLog a (LoggerCtxT ctx m) where- logg l m = ask ≫= \ctx → liftIO (loggerFunIO ctx l m)- withLevel level = local $ setLoggerLevel .~ level- withPolicy policy = local $ setLoggerPolicy .~ policy- localScope f = local $ setLoggerScope %~ f-- {-# INLINE logg #-}- {-# INLINE withLevel #-}- {-# INLINE withPolicy #-}- {-# INLINE localScope #-}--instance (Show a, Typeable a, NFData a, MonadIO m, LoggerCtx ctx a) ⇒ MonadLogIO a (LoggerCtxT ctx m) where- logFunIO = ask ≫= return ∘ loggerFunIO---- -------------------------------------------------------------------------- ----- Boilerplate Instances- {- -- Not sure if this instance is a good idea instance (Show a, Typeable a, NFData a, MonadIO m, LoggerCtx ctx a, MonadReader ctx m) ⇒ MonadLog a m where@@ -487,29 +441,76 @@ {-# INLINE withPolicy #-} -} --- MonadLogIO+-- -------------------------------------------------------------------------- --+-- Logger Context -instance (MonadLog a (ReaderT σ m), MonadLogIO a m) ⇒ MonadLogIO a (ReaderT σ m) where- logFunIO = lift logFunIO- {-# INLINE logFunIO #-}+-- | Abstraction of a logger context that can be used without dependening on+-- a specific monadic context.+--+-- The 'loggerFunIO' incorporates a 'LoggerBackend'. An instance of a 'LoggerCtx'+-- is free to use a hard coded 'LoggerBackend' or to be usable with different+-- 'LoggerBackend' functions. The latter is recommended but not required.+--+-- You don't have to provide an instance of this for your logger. Instead you+-- may just provide an instance of 'MonadLog' directly.+--+-- If this doesn't fit your needs you may use a newtype wrapper and define+-- your own instances.+--+class LoggerCtx ctx msg | ctx → msg where+ loggerFunIO+ ∷ (Show msg, Typeable msg, NFData msg)+ ⇒ ctx+ → LogFunctionIO msg -instance (Monoid σ, MonadLogIO a m) ⇒ MonadLogIO a (WriterT σ m) where- logFunIO = lift logFunIO- {-# INLINE logFunIO #-}+ setLoggerLevel ∷ Setter' ctx LogLevel+ setLoggerScope ∷ Setter' ctx LogScope+ setLoggerPolicy ∷ Setter' ctx LogPolicy -instance (MonadLogIO a m) ⇒ MonadLogIO a (ExceptT ε m) where- logFunIO = lift logFunIO- {-# INLINE logFunIO #-}+ withLoggerLevel ∷ LogLevel → ctx → (ctx → α) → α+ withLoggerLevel level ctx f = f $ ctx & setLoggerLevel .~ level+ {-# INLINE withLoggerLevel #-} -instance (MonadLogIO a m) ⇒ MonadLogIO a (StateT σ m) where- logFunIO = lift logFunIO- {-# INLINE logFunIO #-}+ withLoggerLabel ∷ LogLabel → ctx → (ctx → α) → α+ withLoggerLabel label ctx f = f $ ctx & setLoggerScope %~ (:) label+ {-# INLINE withLoggerLabel #-} -instance (MonadLogIO a m) ⇒ MonadLogIO a (TraceT t e m) where- logFunIO = lift logFunIO- {-# INLINE logFunIO #-}+ withLoggerPolicy ∷ LogPolicy → ctx → (ctx → α) → α+ withLoggerPolicy policy ctx f = f $ ctx & setLoggerPolicy .~ policy+ {-# INLINE withLoggerPolicy #-} -instance (MonadLogIO a m) ⇒ MonadLogIO a (EitherT σ m) where- logFunIO = lift logFunIO- {-# INLINE logFunIO #-}+newtype LoggerCtxT ctx m α = LoggerCtxT { unLoggerCtxT ∷ ReaderT ctx m α }+ deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadReader ctx, MonadError a, MonadState a, MonadWriter a, MonadBase a, MonadTrace t)++-- This should eventually be defined in Control.Monad.Trace.Class+instance (Monad m, MonadTrace t m) ⇒ MonadTrace t (ReaderT ctx m) where+ traceScope s inner = liftWith (\run → traceScope s (run inner)) ≫= restoreT ∘ return+ readTrace = lift readTrace++instance MonadTransControl (LoggerCtxT ctx) where+ type StT (LoggerCtxT ctx) a = StT (ReaderT ctx) a+ liftWith = defaultLiftWith LoggerCtxT unLoggerCtxT+ restoreT = defaultRestoreT LoggerCtxT++instance MonadBaseControl b m ⇒ MonadBaseControl b (LoggerCtxT ctx m) where+ type StM (LoggerCtxT ctx m) a = ComposeSt (LoggerCtxT ctx) m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM++runLoggerCtxT+ ∷ LoggerCtxT ctx m α+ → ctx+ → m α+runLoggerCtxT = runReaderT ∘ unLoggerCtxT++instance (Show a, Typeable a, NFData a, MonadIO m, LoggerCtx ctx a) ⇒ MonadLog a (LoggerCtxT ctx m) where+ logg l m = ask ≫= \ctx → liftIO (loggerFunIO ctx l m)+ withLevel level = local $ setLoggerLevel .~ level+ withPolicy policy = local $ setLoggerPolicy .~ policy+ localScope f = local $ setLoggerScope %~ f++ {-# INLINE logg #-}+ {-# INLINE withLevel #-}+ {-# INLINE withPolicy #-}+ {-# INLINE localScope #-}
+ test/Main.hs view
@@ -0,0 +1,39 @@+-- Copyright (c) 2013-2015 PivotCloud, Inc. All Rights Reserved.+--+-- NOTICE: The dissemination, reproduction, or copying of this file and the+-- information contained herein, in any medium, is strictly forbidden.+--+-- The intellectual property and technical concepts contained herein are+-- proprietary to PivotCloud and are protected by U.S. and Foreign law.++-- |+-- Module: Main+-- Copyright: Copyright (c) 2013-2015 PivotCloud, Inc. All Rights Reserved.+-- License: All Rights Reserved, see LICENSE file of the package+-- Maintainer: code@pivotmail.com+-- Stability: experimental+--+-- Test suite for yet-another-logger+--++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++module Main+(main+) where++import Test.Tasty++-- internal+import qualified NoBackend++main ∷ IO ()+main = defaultMain $+ NoBackend.tests+
+ test/NoBackend.hs view
@@ -0,0 +1,333 @@+-- Copyright (c) 2013-2015 PivotCloud, Inc. All Rights Reserved.+--+-- NOTICE: The dissemination, reproduction, or copying of this file and the+-- information contained herein, in any medium, is strictly forbidden.+--+-- The intellectual property and technical concepts contained herein are+-- proprietary to PivotCloud and are protected by U.S. and Foreign law.++-- |+-- Module: NoBackend+-- Copyright: Copyright (c) 2013-2015 PivotCloud, Inc. All Rights Reserved.+-- License: All Rights Reserved, see LICENSE file of the package+-- Maintainer: code@pivotmail.com+-- Stability: experimental+--++{-# LANGUAGE GADTs #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++module NoBackend+( tests+) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception+import Control.Exception.Enclosed+import Control.Monad+import Control.Monad.Unicode+import Control.Lens++import Data.IORef+import Data.Monoid.Unicode+import Data.String+import qualified Data.Text as T+import Data.Typeable+import Data.Void++import Numeric.Natural++import GHC.Generics++import Prelude.Unicode++import Test.Tasty+import Test.Tasty.HUnit hiding (testCaseSteps)++-- yet-another-logger+import System.Logger++-- internal+import TastyTools++-- -------------------------------------------------------------------------- --+-- TestParams++data TestParams = TestParams+ { queueSize ∷ !Natural+ -- ^ queue size+ , threadsN ∷ !Natural+ -- ^ number of threads+ , messageN ∷ !Natural+ -- ^ number of log message to write+ , messageSize ∷ !Natural+ -- ^ size of message+ , frontendDelay ∷ !Natural+ -- ^ delay between messages in microseconds+ , backendDelay ∷ !Natural+ -- ^ write delay in microseconds+ , exitDelay ∷ !(Maybe Natural)+ -- ^ exit timeout in microseconds+ }+ deriving (Show, Read, Eq, Ord, Typeable, Generic)++-- -------------------------------------------------------------------------- --+-- Test Vectors++tests ∷ TestTree+tests = testGroup "trivial backend"+ [ noBackendTestsTimeout 1+ , noBackendTestsTimeout 100+ , noBackendTestsTimeout 100000000+ , buggyBackendTests 11 10+ [ TestParams 10 10 100 1000 25 1 (Just 10)+ , TestParams 1000 100 100 10000 25 1 (Just 10)+ , TestParams 10000000 100 100 10000 25 1 (Just 10)+ ]+ , buggyRecoverBackendTests 2 10+ [ TestParams 10 100 100 1000 100 1 (Just 10)+ , TestParams 1000 100 100 1000 10 1 (Just 10)+ , TestParams 10000000 100 100 1000 10 1 (Just 10)+ ]+ , buggyRecoverBackendTests 8 10+ [ TestParams 1000 10 100 100 100 1 (Just 10)+ ]+ , buggyNoRecoverBackendTests 10 15+ [ TestParams 1000 10 100 100 100 1 (Just 1000)+ -- we give these tests some more time at termination to ensure that+ -- the expected exceptions are actually thrown.+ ]+ ]+ where+ noBackendTestsTimeout t = noBackendTests+ [ TestParams 10 100 100 1000 25 1 (Just t)+ , TestParams 1000 100 100 10000 25 1 (Just t)+ , TestParams 10000000 100 100 10000 25 1 (Just t)++ , TestParams 10 100 100 1000 10 1 (Just t)+ , TestParams 1000 100 100 10000 10 1 (Just t)+ , TestParams 10000000 100 100 10000 10 1 (Just t)++ , TestParams 10 100 100 1000 1 5 (Just t)+ , TestParams 1000 100 100 10000 1 5 (Just t)+ , TestParams 10000000 100 100 10000 1 5 (Just t)+ ]++noBackendTests ∷ [TestParams] → TestTree+noBackendTests = testGroup "no backend" ∘ map tc+ where+ tc args = testCaseSteps (sshow args) $ \logLogStr →+ catchAny+ (noBackendLoggerTest logLogStr args)+ (\e → assertString $ "unexpected exception: " ⊕ show e)++-- Buggy Backend that calls 'BackendTerminatedException'.+--+buggyBackendTests ∷ Natural → Natural → [TestParams] → TestTree+buggyBackendTests m n =+ testGroup ("buggy backend " ⊕ sshow m ⊕ " " ⊕ sshow n) ∘ map tc+ where+ tc args = testCaseSteps (sshow args) $ \logLogStr →+ do+ buggyBackendLoggerTest exception (\x → x `mod` m <= n) logLogStr args+ assertString $ "Missing expected exception"+ `catch` \(e ∷ LoggerException Void) → case e of+ BackendTerminatedException e0 → case fromException e0 of+ Just BuggyBackendException → logLogStr $ "test: expected exception: " ⊕ sshow e+ _ → throwIO e+ _ → throwIO e+ exception = BackendTerminatedException $ toException BuggyBackendException++-- | Buggy Backend that calls some exception.+--+-- The logger is expected to recover.+--+buggyRecoverBackendTests ∷ Natural → Natural → [TestParams] → TestTree+buggyRecoverBackendTests m n =+ testGroup ("buggy recover backend " ⊕ sshow m ⊕ " " ⊕ sshow n) ∘ map tc+ where+ tc args = testCaseSteps (sshow args) $ \logLogStr →+ do+ buggyBackendLoggerTest exception (\x → x `mod` n <= m) logLogStr args+ `catchAny` \e →+ assertString $ "test: unexpected exception: " ⊕ show e+ exception = BuggyBackendException++-- | Buggy Backend that calls some exception.+--+-- The logger is expected to throw 'BackendTooManyExceptions'.+--+buggyNoRecoverBackendTests ∷ Natural → Natural → [TestParams] → TestTree+buggyNoRecoverBackendTests m n =+ testGroup ("buggy no recover backend " ⊕ sshow m ⊕ " " ⊕ sshow n) ∘ map tc+ where+ tc args = testCaseSteps (sshow args) $ \logLogStr → mask $ \umask → do+ do umask $ do+ buggyBackendLoggerTest exception (\x → x `mod` n <= m) logLogStr args+ -- Make sure to configure the exitWait and exceptionWait so that+ -- the backend has enough time to deliver enough messages to trigger+ -- and exception.+ assertString $ "Missing expected exception: " ⊕ sshow exception+ `catch` \(e ∷ LoggerException Void) → case e of+ BackendTooManyExceptions (e0:_) → case fromException e0 of+ Just BuggyBackendException → logLogStr $ "test: expected exception: " ⊕ sshow e+ _ → throwIO e+ _ → throwIO e+ exception = BuggyBackendException++-- -------------------------------------------------------------------------- --+-- Test Backend++-- | A thread that logs messages+--+testThread+ ∷ Natural+ -- ^ number of log message to write+ → Natural+ -- ^ size of message+ → Natural+ -- ^ delay between messages in microseconds+ → LogFunctionIO T.Text+ → IO ()+testThread n s delayMicro logFun = do+ void ∘ replicateM (fromIntegral n) $ do+ threadDelay (fromIntegral delayMicro)+ logFun Debug msg+ where+ msg = T.replicate (fromIntegral s) "a"++-- | A backend that logs all messages with level at least Warning+-- and discards all other messages.+--+-- Assuming that all test messages are of level lower than Warning+-- this will log only messages that are generated by the logging+-- framework itself.+--+testBackend+ ∷ Show msg+ ⇒ (T.Text → IO ())+ → Natural+ -- ^ minimal delay before returning in microseconds+ → LoggerBackend msg+testBackend _logLog delayMicro (Right LogMessage{..}) =+ -- simulate deliver by applying the delay+ threadDelay (fromIntegral delayMicro) ≫ return ()++testBackend logLog delayMicro (Left LogMessage{..}) = do+ -- assume that the message comes from the logging system itself.+ -- simulate delivery by applying the delay.+ logLog $ "[" ⊕ logLevelText _logMsgLevel ⊕ "] " ⊕ sshow _logMsg+ threadDelay (fromIntegral delayMicro)++-- -------------------------------------------------------------------------- --+-- No Backend Logger++noBackendLoggerTest+ ∷ (T.Text → IO ())+ → TestParams+ → IO ()+noBackendLoggerTest logLog TestParams{..} =+ nobackendLogger logLog config backendDelay $ \logFun →+ testClients logFun `catchAny` \e →+ logLog $ "unexpected exception in client: " ⊕ sshow e+ where+ testClients logFun = do+ s ← replicateM (fromIntegral threadsN) .+ async ∘ void $ testThread messageN messageSize frontendDelay logFun+ mapM_ wait s+ config = defaultLoggerConfig+ & loggerConfigThreshold .~ Debug+ & loggerConfigQueueSize .~ queueSize+ & loggerConfigExitTimeout .~ exitDelay++-- | A logger with the testBackend.+--+nobackendLogger+ ∷ (T.Text → IO ())+ → LoggerConfig+ → Natural+ -- ^ write delay in microseconds+ → (LogFunctionIO T.Text → IO ())+ → IO ()+nobackendLogger logLog config delayMicro =+ withLogFunction_ logLog config (testBackend logLog delayMicro)++data BuggyBackendException = BuggyBackendException+ deriving (Show, Read, Eq, Ord, Typeable, Generic)++instance Exception BuggyBackendException++-- -------------------------------------------------------------------------- --+-- Buggy backend++buggyBackendLoggerTest+ ∷ Exception e+ ⇒ e+ → (Natural → Bool)+ -- ^ exception predicate+ → (T.Text → IO ())+ → TestParams+ → IO ()+buggyBackendLoggerTest exception isException logLog TestParams{..} =+ buggyBackendLogger exception isException logLog config backendDelay $ \logFun →+ testClients logFun `catchAny` \e →+ logLog $ "unexpected exception in client: " ⊕ sshow e+ where+ testClients logFun = do+ s ← replicateM (fromIntegral threadsN) .+ async ∘ void $ testThread messageN messageSize frontendDelay logFun+ mapM_ wait s+ config = defaultLoggerConfig+ & loggerConfigThreshold .~ Debug+ & loggerConfigQueueSize .~ queueSize+ & loggerConfigExitTimeout .~ exitDelay+ & loggerConfigExceptionLimit .~ Just 10+ & loggerConfigExceptionWait .~ Just 100++-- | A logger with the testBackend the throw exceptions.+--+buggyBackendLogger+ ∷ Exception e+ ⇒ e+ → (Natural → Bool)+ -- ^ exception predicate+ → (T.Text → IO ())+ → LoggerConfig+ → Natural+ -- ^ write delay in microseconds+ → (LogFunctionIO T.Text → IO ())+ → IO ()+buggyBackendLogger exception isException logLog config delayMicro f =+ withBackend $ \backend → withLogFunction_ logLog config backend f+ where+ withBackend inner = do+ counter ← newIORef 0+ result ← inner $ \msg → case msg of+ -- test log message+ Right{} → do+ modifyIORef' counter succ+ c ← readIORef counter+ if isException c+ then throwIO exception+ else testBackend logLog delayMicro msg+ -- internal log message (we don't count these)+ Left{} → testBackend logLog delayMicro msg+ n ← readIORef counter+ logLog $ "test: delivered " ⊕ sshow n ⊕ " log messages"+ return result++-- -------------------------------------------------------------------------- --+-- Utils++sshow ∷ (Show a, IsString b) ⇒ a → b+sshow = fromString ∘ show+
+ test/TastyTools.hs view
@@ -0,0 +1,139 @@+-- Copyright (c) 2013-2015 PivotCloud, Inc. All Rights Reserved.+--+-- NOTICE: The dissemination, reproduction, or copying of this file and the+-- information contained herein, in any medium, is strictly forbidden.+--+-- The intellectual property and technical concepts contained herein are+-- proprietary to PivotCloud and are protected by U.S. and Foreign law.++-- |+-- Module: TastyTools+-- Copyright: Copyright (c) 2013-2015 PivotCloud, Inc. All Rights Reserved.+-- License: All Rights Reserved, see LICENSE file of the package+-- Maintainer: code@pivotmail.com+-- Stability: experimental+--++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++module TastyTools+( ProgressFunction+, TestCaseProgress+, testCaseProgress++, StepFunction+, testCaseSteps+) where++import Configuration.Utils (boolReader)++import Control.Applicative+import Control.Exception (try)+import Control.Monad+import Control.Monad.IO.Class++import Data.IORef.Lifted+import Data.Monoid.Unicode+import Data.Tagged+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Builder as LT+import Data.Typeable++import GHC.Generics++import Prelude.Unicode++import Test.Tasty+import Test.Tasty.HUnit hiding (testCaseSteps)+import Test.Tasty.Options+import Test.Tasty.Providers++newtype OptionVerbose = OptionVerbose Bool+ deriving (Show, Read, Eq, Ord, Typeable, Generic)++instance IsOption OptionVerbose where+ defaultValue = OptionVerbose False+ parseValue s = OptionVerbose <$> either (\(_::T.Text) → Nothing) Just (boolReader s)+ optionName = Tagged "verbose"+ optionHelp = Tagged "verbosely log test progress messages to the console"++-- | Function to report progress+--+type ProgressFunction+ = MonadIO m+ ⇒ Float+ -- ^ progress measure+ → T.Text+ -- ^ progress message+ → m ()++newtype TestCaseProgress = TestCaseProgress (ProgressFunction → Assertion)+ deriving (Typeable)++instance IsTest TestCaseProgress where+ run opts (TestCaseProgress testAssertion) prog = do+ outRef ← newIORef ""+ try (testAssertion $ step outRef) >>= \case+ Left (HUnitFailure errMsg) → if verbose+ then do+ output ← readIORef outRef+ return ∘ testFailed ∘ LT.unpack ∘ LT.toLazyText $+ output ⊕ "\n" ⊕ LT.fromString errMsg+ else+ return ∘ testFailed $ errMsg+ Right () → if verbose+ then+ testPassed ∘ LT.unpack ∘ LT.toLazyText <$> readIORef outRef+ else+ return $ testPassed ""+ where++ OptionVerbose verbose = lookupOption opts++ step ∷ MonadIO m ⇒ IORef LT.Builder → Float → T.Text → m ()+ step outRef p nm = liftIO $ do+ prog $ Progress (T.unpack nm) p+ when verbose $ atomicModifyIORef' outRef $ \l ->+ (l ⊕ "\n" ⊕ LT.fromText nm, ())++ testOptions = Tagged [Option (Proxy ∷ Proxy OptionVerbose)]++-- | Constructor for a 'TestTree' which can emit progress messages+--+testCaseProgress+ ∷ T.Text+ -- ^ Test name+ → (ProgressFunction → Assertion)+ -- ^ test method+ → TestTree+testCaseProgress testName = singleTest (T.unpack testName) ∘ TestCaseProgress++-- -------------------------------------------------------------------------- --+-- Step++-- | Function to report progress+--+type StepFunction+ = MonadIO m+ ⇒ T.Text+ -- ^ progress message+ → m ()++-- | Constructor for a 'TestTree' which can emit progress messages+--+testCaseSteps+ ∷ T.Text+ -- ^ Test name+ → (StepFunction → Assertion)+ -- ^ test method+ → TestTree+testCaseSteps testName inner = singleTest (T.unpack testName) ∘ TestCaseProgress $ \f →+ inner (f 0)+
yet-another-logger.cabal view
@@ -1,5 +1,5 @@ Name: yet-another-logger-Version: 0.1.1.1+Version: 0.2 Synopsis: Yet Another Logger Description: A logging framework written with flexibility and performance@@ -73,7 +73,7 @@ type: git location: https://github.com/alephcloud/hs-yet-another-logger branch: master- tag: 0.1.1.1+ tag: 0.2 Library default-language: Haskell2010@@ -84,6 +84,7 @@ System.Logger.Backend.ColorOption System.Logger.Backend.Handle System.Logger.Internal+ System.Logger.Internal.Queue System.Logger.Logger System.Logger.Logger.Internal System.Logger.Types@@ -96,6 +97,7 @@ base-unicode-symbols >= 0.2, bytestring >= 0.10, case-insensitive >= 1.2,+ clock >= 0.4, configuration-tools >= 0.2.8, deepseq >= 1.3, either >= 4.3,@@ -108,9 +110,57 @@ stm >= 2.4, stm-chans >= 3.0, text >= 1.2,+ time >= 1.5, trace >= 0.1, transformers >= 0.3,- transformers-base >= 0.4+ transformers-base >= 0.4,+ void >= 0.7 + if !impl(ghc>=7.9)+ build-depends:+ nats >= 1+ ghc-options: -Wall +test-suite tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Main.hs++ other-modules:+ NoBackend+ TastyTools++ build-depends:+ async >= 2.0,+ base == 4.*,+ base-unicode-symbols >= 0.2,+ configuration-tools >= 0.2.12,+ enclosed-exceptions >= 1.0,+ lens >= 4.7,+ lifted-base >= 0.2,+ tagged >= 0.7,+ tasty >= 0.10,+ tasty-hunit >= 0.9,+ text >= 1.2,+ transformers >= 0.3,+ transformers-base >= 0.4,+ void >= 0.7,+ yet-another-logger++ if !impl(ghc>=7.9)+ build-depends:+ nats >= 1++ ghc-options: -Wall -threaded -with-rtsopts=-N++Executable example+ default-language: Haskell2010+ hs-source-dirs: example+ main-is: Example.hs++ build-depends:+ base == 4.*,+ Cabal >= 1.18,+ yet-another-logger