diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ===== diff --git a/constraints b/constraints --- 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 @@ 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 --- /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 +-- 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 --- a/src/System/Logger.hs +++ b/src/System/Logger.hs @@ -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 diff --git a/src/System/Logger/Backend/ColorOption.hs b/src/System/Logger/Backend/ColorOption.hs --- 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 @@ , 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" diff --git a/src/System/Logger/Backend/Handle.hs b/src/System/Logger/Backend/Handle.hs --- a/src/System/Logger/Backend/Handle.hs +++ b/src/System/Logger/Backend/Handle.hs @@ -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:" ⊕ 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 diff --git a/src/System/Logger/Internal.hs b/src/System/Logger/Internal.hs --- a/src/System/Logger/Internal.hs +++ b/src/System/Logger/Internal.hs @@ -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) diff --git a/src/System/Logger/Internal/Queue.hs b/src/System/Logger/Internal/Queue.hs new file mode 100644 --- /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 +-- 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 --- a/src/System/Logger/Logger.hs +++ b/src/System/Logger/Logger.hs @@ -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 diff --git a/src/System/Logger/Logger/Internal.hs b/src/System/Logger/Logger/Internal.hs --- a/src/System/Logger/Logger/Internal.hs +++ b/src/System/Logger/Logger/Internal.hs @@ -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 +instance ToJSON Natural where + toJSON = Number ∘ fromIntegral + +-- Submitted pull request to aeson +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 #-} -- -------------------------------------------------------------------------- -- diff --git a/src/System/Logger/Types.hs b/src/System/Logger/Types.hs --- 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 @@ , 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 #-} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /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 --- /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 --- /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 --- 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 @@ 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