summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorlarsk <>2015-04-09 16:10:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-04-09 16:10:00 (GMT)
commit448630158fa31d27198ad5a10d4f7218d0a4dfa8 (patch)
treeb0a9ba1b80681d8e4f38d4e7b80fc929e658d763
parent122f23b607c18fc7f63e64f4a320390d97dd42cf (diff)
version 0.20.2
-rw-r--r--CHANGELOG.md57
-rw-r--r--constraints145
-rw-r--r--example/Example.hs42
-rw-r--r--src/System/Logger.hs14
-rw-r--r--src/System/Logger/Backend/ColorOption.hs19
-rw-r--r--src/System/Logger/Backend/Handle.hs27
-rw-r--r--src/System/Logger/Internal.hs55
-rw-r--r--src/System/Logger/Internal/Queue.hs146
-rw-r--r--src/System/Logger/Logger.hs7
-rw-r--r--src/System/Logger/Logger/Internal.hs378
-rw-r--r--src/System/Logger/Types.hs269
-rw-r--r--test/Main.hs39
-rw-r--r--test/NoBackend.hs333
-rw-r--r--test/TastyTools.hs139
-rw-r--r--yet-another-logger.cabal56
15 files changed, 1446 insertions, 280 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index dd4cb33..0e7132a 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,7 +1,58 @@
-0.1.1.1
-=======
+0.2
+===
+
+* 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.
-* Add `NFData` instance for `LogPolicy`.
+* 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
=====
diff --git a/constraints b/constraints
index 0e86bf3..4c95d1d 100644
--- a/constraints
+++ b/constraints
@@ -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 @@ constraints: Cabal ==1.22.0.0,
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
diff --git a/example/Example.hs b/example/Example.hs
new file mode 100644
index 0000000..709f437
--- /dev/null
+++ b/example/Example.hs
@@ -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"
+
diff --git a/src/System/Logger.hs b/src/System/Logger.hs
index d552ab1..be91154 100644
--- a/src/System/Logger.hs
+++ b/src/System/Logger.hs
@@ -59,6 +59,7 @@ module System.Logger
, defaultLogConfig
, validateLogConfig
, pLogConfig
+, pLogConfig_
) where
import Configuration.Utils hiding (Lens')
@@ -159,7 +160,12 @@ instance FromJSON (LogConfig → LogConfig) where
<*< 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
diff --git a/src/System/Logger/Backend/ColorOption.hs b/src/System/Logger/Backend/ColorOption.hs
index 91d707f..e6e9479 100644
--- a/src/System/Logger/Backend/ColorOption.hs
+++ b/src/System/Logger/Backend/ColorOption.hs
@@ -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 @@ module System.Logger.Backend.ColorOption
, 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 @@ instance FromJSON ColorOption where
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"
diff --git a/src/System/Logger/Backend/Handle.hs b/src/System/Logger/Backend/Handle.hs
index 37e40f0..07b87b2 100644
--- a/src/System/Logger/Backend/Handle.hs
+++ b/src/System/Logger/Backend/Handle.hs
@@ -43,6 +43,7 @@ module System.Logger.Backend.Handle
, readLoggerHandleConfig
, validateLoggerHandleConfig
, pLoggerHandleConfig
+, pLoggerHandleConfig_
-- * Backend Configuration
, HandleBackendConfig(..)
@@ -51,6 +52,7 @@ module System.Logger.Backend.Handle
, defaultHandleBackendConfig
, validateHandleBackendConfig
, pHandleBackendConfig
+, pHandleBackendConfig_
-- * Backend Implementation
, withHandleBackend
@@ -134,8 +136,14 @@ instance FromJSON LoggerHandleConfig where
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,9 +192,15 @@ instance FromJSON (HandleBackendConfig → HandleBackendConfig) where
<*< 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 @@ handleBackend
→ 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
diff --git a/src/System/Logger/Internal.hs b/src/System/Logger/Internal.hs
index 74e6c48..f464042 100644
--- a/src/System/Logger/Internal.hs
+++ b/src/System/Logger/Internal.hs
@@ -28,12 +28,24 @@
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
@@ -41,3 +53,46 @@ sshow
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)
+
diff --git a/src/System/Logger/Internal/Queue.hs b/src/System/Logger/Internal/Queue.hs
new file mode 100644
index 0000000..f2d5340
--- /dev/null
+++ b/src/System/Logger/Internal/Queue.hs
@@ -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
+
diff --git a/src/System/Logger/Logger.hs b/src/System/Logger/Logger.hs
index 751688f..3539e28 100644
--- a/src/System/Logger/Logger.hs
+++ b/src/System/Logger/Logger.hs
@@ -42,7 +42,9 @@ module System.Logger.Logger
-- * Logger
, Logger
, withLogger
+, withLogger_
, withLogFunction
+, withLogFunction_
-- * LoggerT Monad Transformer
, LoggerT
@@ -56,9 +58,14 @@ module System.Logger.Logger
, loggerConfigQueueSize
, loggerConfigThreshold
, loggerConfigScope
+, loggerConfigPolicy
+, loggerConfigExceptionLimit
+, loggerConfigExceptionWait
+, loggerConfigExitTimeout
, defaultLoggerConfig
, validateLoggerConfig
, pLoggerConfig
+, pLoggerConfig_
) where
diff --git a/src/System/Logger/Logger/Internal.hs b/src/System/Logger/Logger/Internal.hs
index 899a836..21d42d6 100644
--- a/src/System/Logger/Logger/Internal.hs
+++ b/src/System/Logger/Logger/Internal.hs
@@ -31,6 +31,7 @@
-- module as an example and starting point.
--
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -49,19 +50,27 @@ module System.Logger.Logger.Internal
, 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 @@ module System.Logger.Logger.Internal
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.Trans.Control
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 @@ loggerConfigScope = lens _loggerConfigScope $ \a b → a { _loggerConfigScope =
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 @@ instance ToJSON LoggerConfig where
, "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 @@ instance FromJSON (LoggerConfig → LoggerConfig) where
<*< 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 @@ pLoggerConfig = id
-- 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 @@ data Logger a = Logger
, _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' (Logger a) LogPolicy
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 @@ createLogger LoggerConfig{..} backend = liftIO $ do
, _loggerScope = _loggerConfigScope
, _loggerPolicy = _loggerConfigPolicy
, _loggerMissed = missed
+ , _loggerExitTimeout = _loggerConfigExitTimeout
+ , _loggerErrLogFunction = errLogFun
}
--- FIXME: make this more reliable
+-- | A backend worker.
--
--- For instance if 'readTBMQeue' (not sure if that can happen) throws an
--- exception 'releaseLogger' may not terminate.
---
--- 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,14 +541,30 @@ releaseLogger Logger{..} = liftIO $ do
-- > 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 @@ withLogFunction
→ 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 @@ loggCtx Logger{..} level msg = do
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 #-}
-- -------------------------------------------------------------------------- --
diff --git a/src/System/Logger/Types.hs b/src/System/Logger/Types.hs
index 9621edf..32a9d11 100644
--- a/src/System/Logger/Types.hs
+++ b/src/System/Logger/Types.hs
@@ -25,6 +25,7 @@
-- Stability: experimental
--
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
@@ -47,22 +48,28 @@ module System.Logger.Types
, 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 @@ module System.Logger.Types
, 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 Data.String
import qualified Data.Text as T
import Data.Text.Lens
import Data.Typeable
+import Data.Void
import GHC.Generics
@@ -111,6 +119,8 @@ import qualified Options.Applicative as O
import Prelude.Unicode
+import System.Clock
+
-- -------------------------------------------------------------------------- --
-- Log-Level
@@ -155,8 +165,14 @@ instance FromJSON LogLevel where
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 @@ instance FromJSON LogPolicy where
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 LogLabel = (T.Text, T.Text)
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 @@ data LogMessage a = LogMessage
-- ^ 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,23 +282,37 @@ logMsgLevel = lens _logMsgLevel $ \a b → a { _logMsgLevel = b }
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.
+--
+-- 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 a more direct
--- support might be desirable.
+-- 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 @@ popLabel = localScope $ \case { [] → []; (_:t) → t }
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 @@ instance (MonadLog a m, MonadTransControl t, Monad n, n ~ (t m)) ⇒ MonadLog a
{-# 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 #-}
+
+ 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
-instance (MonadLogIO a m) ⇒ MonadLogIO a (TraceT t e m) where
- logFunIO = lift logFunIO
- {-# INLINE logFunIO #-}
+runLoggerCtxT
+ ∷ LoggerCtxT ctx m α
+ → ctx
+ → m α
+runLoggerCtxT = runReaderT ∘ unLoggerCtxT
-instance (MonadLogIO a m) ⇒ MonadLogIO a (EitherT σ m) where
- logFunIO = lift logFunIO
- {-# INLINE logFunIO #-}
+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 #-}
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
index 0000000..c7a3221
--- /dev/null
+++ b/test/Main.hs
@@ -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
+
diff --git a/test/NoBackend.hs b/test/NoBackend.hs
new file mode 100644
index 0000000..13eec1b
--- /dev/null
+++ b/test/NoBackend.hs
@@ -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
+
diff --git a/test/TastyTools.hs b/test/TastyTools.hs
new file mode 100644
index 0000000..5bc5fd4
--- /dev/null
+++ b/test/TastyTools.hs
@@ -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)
+
diff --git a/yet-another-logger.cabal b/yet-another-logger.cabal
index 536282d..ca7235e 100644
--- a/yet-another-logger.cabal
+++ b/yet-another-logger.cabal
@@ -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 @@ source-repository this
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 @@ Library
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 @@ Library
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 @@ Library
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