packages feed

log-base 0.8.0.1 → 0.12.1.0

raw patch · 14 files changed

Files

CHANGELOG.md view
@@ -1,3 +1,44 @@+# log-base-0.12.1.0 (2025-06-26)+* Add utility function to log unhandled exceptions.++# log-base-0.12.0.1 (2023-03-14)+* Add support for GHC 9.6.++# log-base-0.12.0.0 (2022-09-21)+* Deprecate `withSimpleStdOutLogger` as it's broken in multithreaded environments.+* Generalize logger related functions to `MonadUnliftIO`.+* Remove redundant `INLINE` pragmas.++# log-base-0.11.1.0 (2022-04-04)+* Add support for aeson 2.0.1.0.+* Add support for GHC 9.2.+* Drop support for GHC < 8.8.++# log-base-0.11.0.0 (2021-10-11)+* Add support for defining maximum log level.++# log-base-0.10.0.1 (2021-07-29)+* Fix compilation issues caused by ambiguos occurence of `controlT`.++# log -base-0.10.0.0 (2021-06-09)+* Drop `MonadTime` constraint and use system time by default.++# log-base-0.9.1.1 (2021-05-28)+* Support GHC 9.0.++# log-base-0.9.1.0 (2021-03-01)+* Add a `LogList` logger++# log-base-0.9.0.0 (2020-09-07)+* Always make data attached to a log message a json object+* Add unliftio-core-0.2 compatiblity+* Tidy up flushing stdout in stdout loggers+* Use `simpleStdoutLogger` in `withSimpleStdOutLogger` instead of `stdoutLogger`+* Remove deprecated functions+* Add JSON loggers+* Make `mkLogger` use bounded queue internally (similar to `mkBulkLogger`)+* Get rid of a space leak in bounded queue used in `mkBulkLogger`+ # log-base-0.8.0.1 (2020-05-08) * Update version bounds.
README.md view
@@ -1,5 +1,40 @@-# log-base [![Hackage version](https://img.shields.io/hackage/v/log-base.svg?label=Hackage)](https://hackage.haskell.org/package/log-base) [![Build Status](https://secure.travis-ci.org/scrive/log.svg?branch=master)](http://travis-ci.org/scrive/log)+# log -Base package for the `log` library suite. Includes only the standard output-back end. Use this package in conjunction with `log-elasticsearch` or-`log-postgres`, depending on which back end you need.+[![Hackage version](https://img.shields.io/hackage/v/log-base.svg?label=Hackage)](https://hackage.haskell.org/package/log-base)+[![Build Status](https://github.com/scrive/log/workflows/Haskell-CI/badge.svg?branch=master)](https://github.com/scrive/log/actions?query=branch%3Amaster)++A set of libraries that provide a way to record structured log messages with+multiple backends.++Supported backends:++* Standard output via+  [`log-base`](https://hackage.haskell.org/package/log-base).+* Elasticsearch via+  [`log-elasticsearch`](https://hackage.haskell.org/package/log-elasticsearch).+* PostgreSQL via+  [`log-postgres`](https://hackage.haskell.org/package/log-postgres).++## Example++A sample usage for logging to both standard output and Elasticsearch:++```haskell+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Log+import Log.Backend.ElasticSearch+import Log.Backend.StandardOutput++main :: IO ()+main = do+  let config = defaultElasticSearchConfig+        { esServer = "http://localhost:9200"+        , esIndex  = "logs"+        }+  withStdOutLogger $ \stdoutLogger -> do+    withElasticSearchLogger config $ \esLogger -> do+      runLogT "main" (stdoutLogger <> esLogger) defaultLogLevel $ do+        logInfo_ "Hi there"+```
log-base.cabal view
@@ -1,5 +1,6 @@+cabal-version:       3.0 name:                log-base-version:             0.8.0.1+version:             0.12.1.0 synopsis:            Structured logging solution (base package)  description:         A library that provides a way to record structured log@@ -9,7 +10,7 @@   homepage:            https://github.com/scrive/log-license:             BSD3+license:             BSD-3-Clause license-file:        LICENSE author:              Scrive AB maintainer:          Andrzej Rybczak <andrzej@rybczak.net>,@@ -19,44 +20,44 @@ copyright:           Scrive AB category:            System build-type:          Simple-cabal-version:       >=1.10 extra-source-files:  CHANGELOG.md, README.md-tested-with:         GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 || ==8.10.1+tested-with:         GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.2, 9.12.2 } -Source-repository head-  Type:     git-  Location: https://github.com/scrive/log.git+source-repository head+  type:     git+  location: https://github.com/scrive/log.git  library   exposed-modules:     Log,+                       Log.Backend.LogList,                        Log.Backend.StandardOutput,                        Log.Backend.StandardOutput.Bulk,                        Log.Backend.Text,                        Log.Class,                        Log.Data,+                       Log.Internal.Aeson.Compat,                        Log.Internal.Logger,                        Log.Logger,                        Log.Monad-  build-depends:       base >= 4.9 && <5,-                       aeson >=0.11.0.0,+  build-depends:       base >= 4.13 && <5,+                       aeson >= 1.0,                        aeson-pretty >=0.8.2,                        bytestring,                        deepseq,                        exceptions >=0.6,-                       mmorph >=1.0.9 && <1.2,-                       monad-control >=0.3,-                       monad-time >= 0.2,+                       mmorph >=1.0.9 && <1.3,+                       monad-control >=1.0.3,                        mtl,                        semigroups,                        stm >=2.4,                        text,                        time >= 1.5,                        transformers-base,-                       unliftio-core >= 0.1.2.0 && < 0.2,+                       unliftio-core >= 0.1.2.0 && < 0.3,                        unordered-containers   hs-source-dirs:      src -  ghc-options:         -O2 -Wall -funbox-strict-fields+  ghc-options:         -Wall    default-language:   Haskell2010   default-extensions: BangPatterns@@ -65,7 +66,6 @@                     , GeneralizedNewtypeDeriving                     , LambdaCase                     , MultiParamTypeClasses-                    , NoImplicitPrelude                     , OverloadedStrings                     , RankNTypes                     , RecordWildCards
src/Log.hs view
@@ -18,7 +18,7 @@ --         esMapping = "log" --         } --   'Log.Backend.ElasticSearch.withElasticSearchLogger' config randomIO $ \\logger -> do---     'runLogT' "main" logger $ do+--     'runLogT' "main" logger defaultLogLevel $ do --       'logTrace_' "foo" -- @ module Log (
+ src/Log/Backend/LogList.hs view
@@ -0,0 +1,44 @@+-- | LogList logging backed.+module Log.Backend.LogList+  ( LogList+  , newLogList+  , getLogList+  , putLogList+  , clearLogList+  , withLogListLogger+  ) where++import Control.Concurrent.MVar+import Control.Monad.IO.Unlift++import Log.Data+import Log.Internal.Logger++newtype LogList = LogList (MVar [LogMessage])+  deriving Eq++-- | Create a new, empty list.+newLogList :: MonadIO m => m LogList+newLogList = LogList <$> liftIO (newMVar [])++-- | Retrieve messages stored in the list.+getLogList :: MonadIO m => LogList -> m [LogMessage]+getLogList (LogList ll) = reverse <$> liftIO (readMVar ll)++-- | Put a message into the list.+putLogList :: MonadIO m => LogList -> LogMessage -> m ()+putLogList (LogList ll) msg = liftIO . modifyMVar_ ll $ \msgs -> return $! msg : msgs++-- | Clear the list.+clearLogList :: MonadIO m => LogList -> m ()+clearLogList (LogList ll) = liftIO . modifyMVar_ ll . const $ return []++-- | Creates a logger that stores messages in the given 'LogList'.+withLogListLogger :: MonadUnliftIO m => LogList -> (Logger -> m r) -> m r+withLogListLogger ll act = withRunInIO $ \unlift -> withLogger logger (unlift . act)+  where+    logger = Logger+      { loggerWriteMessage = putLogList ll+      , loggerWaitForWrite = return ()+      , loggerShutdown     = return ()+      }
src/Log/Backend/StandardOutput.hs view
@@ -1,41 +1,38 @@ -- | Stdout logging back-end.-module Log.Backend.StandardOutput (-    simpleStdoutLogger-  , stdoutLogger-  , withSimpleStdOutLogger+module Log.Backend.StandardOutput+  ( withSimpleStdOutLogger+  , withStdOutLogger+  , withJsonStdOutLogger   ) where -import Prelude-import qualified Data.Text.IO as T+import Control.Monad.IO.Unlift+import Data.Aeson import System.IO+import qualified Data.Text.IO as T+import qualified Data.ByteString.Lazy.Char8 as BSL  import Log.Data import Log.Internal.Logger import Log.Logger --- | Create a 'simpleStdoutlogger' for the duration of the given--- action, making sure that stdout is flushed afterwards.-withSimpleStdOutLogger :: (Logger -> IO r) -> IO r-withSimpleStdOutLogger act = do-  logger <- stdoutLogger-  withLogger logger act--{-# DEPRECATED simpleStdoutLogger "Use 'withSimpleStdOutLogger'" #-}---- | Simple, synchronous logger that prints messages to standard--- output. Flushes 'stdout' on each call to 'loggerWriteMessage'. Use--- 'Log.Backend.StandardOutput.Bulk.withBulkStdOutLogger' if you want--- buffering.-simpleStdoutLogger :: Logger-simpleStdoutLogger = Logger {-    loggerWriteMessage = \msg -> (T.putStrLn . showLogMessage Nothing $ msg)-                                 >> hFlush stdout-  , loggerWaitForWrite = hFlush stdout-  , loggerShutdown     = return ()-  }+withSimpleStdOutLogger :: MonadUnliftIO m => (Logger -> m r) -> m r+withSimpleStdOutLogger = withStdOutLogger+{-# DEPRECATED withSimpleStdOutLogger "Use withStdOutLogger instead" #-} -{-# DEPRECATED stdoutLogger "Use 'withSimpleStdOutLogger'" #-}+-- | Create a logger that prints messages to standard output for the duration of+-- the given action.+withStdOutLogger :: MonadUnliftIO m => (Logger -> m r) -> m r+withStdOutLogger act = withRunInIO $ \unlift -> do+  logger <- mkLogger "stdout" $ \msg -> do+    T.putStrLn $ showLogMessage Nothing msg+    hFlush stdout+  withLogger logger (unlift . act) --- | Create a logger that prints messages to standard output.-stdoutLogger :: IO Logger-stdoutLogger = mkLogger "stdout" $ T.putStrLn . showLogMessage Nothing+-- | Create a logger that prints messages in the JSON format to standard output+-- for the duration of the given action.+withJsonStdOutLogger :: MonadUnliftIO m => (Logger -> m r) -> m r+withJsonStdOutLogger act = withRunInIO $ \unlift -> do+  logger <- mkLogger "stdout-json" $ \msg -> do+    BSL.putStrLn $ encode msg+    hFlush stdout+  withLogger logger (unlift . act)
src/Log/Backend/StandardOutput/Bulk.hs view
@@ -1,34 +1,39 @@--- | Bulk stdout logging back-end, useful mainly for testing.-module Log.Backend.StandardOutput.Bulk (-    withBulkStdOutLogger,-    bulkStdoutLogger+-- | Bulk stdout logging back-end.+module Log.Backend.StandardOutput.Bulk+  ( withBulkStdOutLogger+  , withBulkJsonStdOutLogger   ) where -import Prelude-import qualified Data.Text.IO as T+import Control.Monad.IO.Unlift+import Data.Aeson import System.IO (hFlush, stdout)+import qualified Data.Text.IO as T+import qualified Data.ByteString.Lazy.Char8 as BSL  import Log.Data import Log.Logger import Log.Internal.Logger --- | Create a 'bulkStdoutLogger' for the duration of the given action,--- and shut it down afterwards, making sure that all buffered messages--- are actually written to stdout. Flushes 'stdout' on each bulk write.-withBulkStdOutLogger :: (Logger -> IO r) -> IO r-withBulkStdOutLogger act = do-  logger <- bulkStdoutLogger-  withLogger logger act--{-# DEPRECATED bulkStdoutLogger "Use 'withBulkStdOutLogger' instead!" #-}+-- | Create an asynchronouis logger thread that prints messages to standard+-- output once per second for the duration of the given action. Flushes 'stdout'+-- on each bulk write.+withBulkStdOutLogger :: MonadUnliftIO m => (Logger -> m r) -> m r+withBulkStdOutLogger act = withRunInIO $ \unlift -> do+  logger <- mkBulkLogger "stdout-bulk"+    (\msgs -> do+        mapM_ (T.putStrLn . showLogMessage Nothing) msgs+        hFlush stdout+    ) (return ())+  withLogger logger (unlift . act) --- | Start an asynchronous logger thread that prints messages to--- standard output.------ Please use 'withBulkStdOutLogger'' instead, which is more exception-safe--- (see the note attached to 'mkBulkLogger').-bulkStdoutLogger :: IO Logger-bulkStdoutLogger = mkBulkLogger "stdout-bulk"-                   (\msgs -> mapM_ (T.putStrLn . showLogMessage Nothing) msgs-                             >> hFlush stdout)-                   (hFlush stdout)+-- | Create a bulk logger that prints messages in the JSON format to standard+-- output once per second for the duration of the given action. Flushes 'stdout'+-- on each bulk write.+withBulkJsonStdOutLogger :: MonadUnliftIO m => (Logger -> m r) -> m r+withBulkJsonStdOutLogger act = withRunInIO $ \unlift -> do+  logger <- mkBulkLogger "stdout-bulk-json"+    (\msgs -> do+        mapM_ (BSL.putStrLn . encode) msgs+        hFlush stdout+    ) (return ())+  withLogger logger (unlift . act)
src/Log/Backend/Text.hs view
@@ -2,10 +2,8 @@ -- testing. module Log.Backend.Text ( withSimpleTextLogger ) where -import Control.Applicative+import Control.Monad.IO.Unlift import Data.IORef-import Data.Monoid-import Prelude import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B@@ -16,8 +14,8 @@ -- | Create an in-memory logger for the duration of the given action, -- returning both the result of the action and the logger's output as -- a 'Text' value afterwards.-withSimpleTextLogger :: (Logger -> IO r) -> IO (T.Text, r)-withSimpleTextLogger act = do+withSimpleTextLogger :: MonadUnliftIO m => (Logger -> m r) -> m (T.Text, r)+withSimpleTextLogger act = withRunInIO $ \unlift -> do   builderRef <- newIORef mempty   let logger = Logger         { loggerWriteMessage = \msg -> do@@ -26,6 +24,6 @@         , loggerWaitForWrite = return ()         , loggerShutdown     = return ()         }-  r <- act logger+  r <- unlift $ act logger   txt <- L.toStrict . B.toLazyText <$> readIORef builderRef   return (txt, r)
src/Log/Class.hs view
@@ -1,9 +1,6 @@ -- | The 'MonadLog' type class of monads with logging capabilities.-{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}-{-# LANGUAGE OverlappingInstances #-} module Log.Class (     UTCTime-  , MonadTime(..)   , MonadLog(..)   , logAttention   , logInfo@@ -13,13 +10,11 @@   , logTrace_   ) where -import Control.Monad.Time import Control.Monad.Trans import Control.Monad.Trans.Control import Data.Aeson import Data.Aeson.Types import Data.Time-import Prelude import qualified Data.Text as T  import Log.Data@@ -29,52 +24,51 @@ -- 'MonadLog' carries with it some associated state (the logging -- environment) that can be modified locally with 'localData' and -- 'localDomain'.-class MonadTime m => MonadLog m where+class Monad m => MonadLog m where   -- | Write a message to the log.-  logMessage  :: UTCTime  -- ^ Time of the event.-              -> LogLevel -- ^ Log level.-              -> T.Text   -- ^ Log message.-              -> Value    -- ^ Additional data associated with the message.-              -> m ()+  logMessage+    :: LogLevel -- ^ Log level.+    -> T.Text   -- ^ Log message.+    -> Value    -- ^ Additional data associated with the message.+    -> m ()   -- | Extend the additional data associated with each log message locally.   localData   :: [Pair] -> m a -> m a   -- | Extend the current application domain locally.   localDomain :: T.Text -> m a -> m a+  -- | Override the current maximum log level.+  localMaxLogLevel :: LogLevel -> m a -> m a   -- | Get current 'LoggerEnv' object. Useful for construction of logging   -- functions that work in a different monad, see 'getLoggerIO' as an example.   getLoggerEnv :: m LoggerEnv  -- | Generic, overlapping instance.-instance (+instance {-# OVERLAPPABLE #-} (     MonadLog m   , Monad (t m)   , MonadTransControl t   ) => MonadLog (t m) where-    logMessage time level message = lift . logMessage time level message+    logMessage level message = lift . logMessage level message     localData data_ m = controlT $ \run -> localData data_ (run m)     localDomain domain m = controlT $ \run -> localDomain domain (run m)+    localMaxLogLevel level m = controlT $ \run -> localMaxLogLevel level (run m)     getLoggerEnv = lift getLoggerEnv -controlT :: (MonadTransControl t, Monad (t m), Monad m)-         => (Run t -> m (StT t a)) -> t m a-controlT f = liftWith f >>= restoreT . return- ----------------------------------------  -- | Log a message and its associated data using current time as the -- event time and the 'LogAttention' log level. logAttention :: (MonadLog m, ToJSON a) => T.Text -> a -> m ()-logAttention msg = logNow LogAttention msg . toJSON+logAttention msg = logMessage LogAttention msg . toJSON  -- | Log a message and its associated data using current time as the -- event time and the 'LogInfo' log level. logInfo :: (MonadLog m, ToJSON a) => T.Text -> a -> m ()-logInfo msg = logNow LogInfo msg . toJSON+logInfo msg = logMessage LogInfo msg . toJSON  -- | Log a message and its associated data using current time as the -- event time and the 'LogTrace' log level. logTrace :: (MonadLog m, ToJSON a) => T.Text -> a -> m ()-logTrace msg = logNow LogTrace msg . toJSON+logTrace msg = logMessage LogTrace msg . toJSON  -- | Like 'logAttention', but without any additional associated data. logAttention_ :: MonadLog m => T.Text -> m ()@@ -87,12 +81,3 @@ -- | Like 'logTrace', but without any additional associated data. logTrace_ :: MonadLog m => T.Text -> m () logTrace_ = (`logTrace` emptyObject)---------------------------------------------- | Write a log message using the given log level, message text and--- additional data. Current time is used as the event time.-logNow :: MonadLog m => LogLevel -> T.Text -> Value -> m ()-logNow level message data_ = do-  time <- currentTime-  logMessage time level message data_
src/Log/Data.hs view
@@ -3,8 +3,10 @@     LogLevel(..)   , showLogLevel   , readLogLevel+  , readLogLevelEither   , LogMessage(..)   , showLogMessage+  , defaultLogLevel   ) where  import Control.DeepSeq@@ -14,19 +16,19 @@ import Data.Aeson.Types import Data.ByteString.Lazy (toStrict) import Data.Time-import Prelude import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Monoid as Monoid  -- | Available log levels.+-- Note that ordering in this definintion determines what the maximum log level is.+-- See 'Log.Monad.leMaxLogLevel'. data LogLevel = LogAttention | LogInfo | LogTrace   deriving (Bounded, Eq, Ord, Show)  -- | This function is partial. readLogLevel :: T.Text -> LogLevel readLogLevel = either error id . readLogLevelEither-{-# INLINE readLogLevel #-}  readLogLevelEither :: T.Text -> Either String LogLevel readLogLevelEither "attention" = Right LogAttention@@ -39,6 +41,10 @@ showLogLevel LogAttention = "attention" showLogLevel LogInfo      = "info" showLogLevel LogTrace     = "trace"++-- | The default log level. Returns `LogInfo`.+defaultLogLevel :: LogLevel+defaultLogLevel = LogInfo  instance ToJSON LogLevel where   toJSON = toJSON . showLogLevel
+ src/Log/Internal/Aeson/Compat.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}+module Log.Internal.Aeson.Compat+  ( module Map+#if !MIN_VERSION_aeson(2,0,1)+  , KeyMap+#endif+  , fromText+  , doName+  ) where++import Data.Text++#if MIN_VERSION_aeson(2,0,1)+import Data.Aeson.KeyMap as Map +import qualified Data.Aeson.Key as K++fromText :: Text -> K.Key+fromText = K.fromText++doName :: Monad m => (Text -> m Text) -> K.Key -> m K.Key+doName f = fmap K.fromText . f . K.toText++#else++import Data.HashMap.Strict as Map++type KeyMap a = Map.HashMap Text a++fromText :: Text -> Text+fromText = id++doName :: (Text -> m Text) -> Text -> m Text+doName = id++#endif
src/Log/Internal/Logger.hs view
@@ -8,9 +8,7 @@   , withLogger   ) where -import Data.Semigroup import Control.Exception-import Prelude  import Log.Data @@ -50,6 +48,10 @@ withLogger logger act = act logger `finally` cleanup   where     cleanup = waitForLogger logger >> shutdownLogger logger+-- Prevent GHC from inlining this function so its callers are small and+-- considered for inlining instead (as they will be generalized to MonadIO or+-- MonadUnliftIO).+{-# NOINLINE withLogger #-}  instance Semigroup Logger where   l1 <> l2 = Logger {
src/Log/Logger.hs view
@@ -3,6 +3,7 @@   ( LoggerEnv(..)   , Logger   , mkLogger+  , mkLogger'   , mkBulkLogger   , mkBulkLogger'   , execLogger@@ -10,13 +11,10 @@   , shutdownLogger   ) where -import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Monad-import Data.Semigroup-import Prelude import qualified Data.Aeson.Types as A import qualified Data.Text as T import qualified Data.Text.IO as T@@ -31,23 +29,37 @@   , leDomain    :: ![T.Text] -- ^ Current application domain.   , leData      :: ![A.Pair] -- ^ Additional data to be merged with the log                              -- message\'s data.+  , leMaxLogLevel :: LogLevel -- ^ The maximum log level allowed to be logged.   }  -- | Start a logger thread that consumes one queued message at a time.+--+-- /Note:/ a bounded queue of size 1000000 is used internally to avoid+-- unrestricted memory consumption. mkLogger :: T.Text -> (LogMessage -> IO ()) -> IO Logger-mkLogger name exec = mkLoggerImpl-  newTQueueIO isEmptyTQueue readTQueue writeTQueue (return ())-  name exec (return ())+mkLogger = mkLogger' defaultQueueCapacity --- | Start an asynchronous logger thread that consumes all queued--- messages once per second. Uses a bounded queue internally to avoid--- space leaks. To make sure that the messages get written out in the--- presence of exceptions, use high-level wrappers like 'withLogger',+-- | Like 'mkBulkLogger', but with configurable queue size.+--+-- @since 0.9.0.0+mkLogger' :: Int -> T.Text -> (LogMessage -> IO ()) -> IO Logger+mkLogger' cap name exec = mkLoggerImpl+  (newTBQueueIO $ fromIntegral cap) isEmptyTBQueue readTBQueue writeTBQueue+  (return ()) name exec (return ())++-- | Start an asynchronous logger thread that consumes all queued messages once+-- per second.+--+-- /Note:/ a bounded queue of size 1000000 is used internally to avoid+-- unrestricted memory consumption.+--+-- To make sure that the messages get written out in the presence of exceptions,+-- use high-level wrappers like 'withLogger', -- 'Log.Backend.ElasticSearch.withElasticSearchLogger' or--- 'Log.Backend.StandardOutput.Bulk.withBulkStdOutLogger' instead of--- this function directly.+-- 'Log.Backend.StandardOutput.Bulk.withBulkStdOutLogger' instead of this+-- function directly. ----- Note: some messages can be lost when the main thread shuts down+-- /Note:/ some messages can be lost when the main thread shuts down -- without making sure that all logger threads have written out all -- messages, because in that case child threads are not given a chance -- to clean up by the RTS. This is apparently a feature:@@ -66,7 +78,7 @@ -- main = do --    logger \<- 'Log.Backend.ElasticSearch.elasticSearchLogger' --    a \<- 'Control.Concurrent.Async.async' ('Log.Backend.ElasticSearch.withElasticSearchLogger' $ \\logger ->---                'Log.Monad.runLogT' "main" logger $ 'Log.Class.logTrace_' "foo")+--                'Log.Monad.runLogT' "main" logger defaultLogLevel $ 'Log.Class.logTrace_' "foo") --    -- Main thread exits without waiting for the child --    -- to finish and without giving the child a chance --    -- to do proper cleanup.@@ -81,14 +93,14 @@ -- main = do --    logger \<- 'Log.Backend.ElasticSearch.elasticSearchLogger' --    a \<- 'Control.Concurrent.Async.async' ('Log.Backend.ElasticSearch.withElasticSearchLogger' $ \\logger ->---                'Log.Monad.runLogT' "main" logger $ 'Log.Class.logTrace_' "foo")+--                'Log.Monad.runLogT' "main" logger defaultLogLevel $ 'Log.Class.logTrace_' "foo") --    'Control.Concurrent.Async.wait' a --    -- Main thread waits for the child to finish, giving --    -- it a chance to shut down properly. This works even --    -- in the presence of exceptions in the child thread. -- @ mkBulkLogger :: T.Text -> ([LogMessage] -> IO ()) -> IO () -> IO Logger-mkBulkLogger = mkBulkLogger' sbDefaultCapacity 1000000+mkBulkLogger = mkBulkLogger' defaultQueueCapacity 1000000  -- | Like 'mkBulkLogger', but with configurable queue size and thread delay. --@@ -106,14 +118,15 @@  ---------------------------------------- +-- | Default capacity of log queues (TBQueue for regular logger, 'SBQueue' for+-- bulk loggers). This corresponds to approximately 200 MiB memory residency+-- when the queue is full.+defaultQueueCapacity :: Int+defaultQueueCapacity = 1000000+ -- | A simple STM based bounded queue. data SBQueue a = SBQueue !(TVar [a]) !(TVar Int) !Int --- | Default capacity of a 'SBQueue'. This corresponds to--- approximately 200 MiB memory residency when the queue is full.-sbDefaultCapacity :: Int-sbDefaultCapacity = 1000000- -- | Create an instance of 'SBQueue' with a given capacity. newSBQueueIO :: Int -> IO (SBQueue a) newSBQueueIO capacity = SBQueue <$> newTVarIO [] <*> newTVarIO 0 <*> pure capacity@@ -141,7 +154,8 @@   numElems <- readTVar count   if numElems < capacity     then do modifyTVar queue (a :)-            modifyTVar count (+1)+            -- Strict modification of the queue size to avoid space leak+            modifyTVar' count (+1)     else return ()  ----------------------------------------@@ -204,3 +218,7 @@       when (not isEmpty || isInProgress) retry      printLoggerTerminated = T.putStrLn $ name <> ": logger thread terminated"+-- Prevent GHC from inlining this function so its callers are small and+-- considered for inlining instead (as they will be generalized to MonadIO or+-- MonadUnliftIO).+{-# NOINLINE mkLoggerImpl #-}
src/Log/Monad.hs view
@@ -6,6 +6,7 @@   , InnerLogT   , LogT(..)   , runLogT+  , logExceptions   , mapLogT   , logMessageIO   , getLoggerIO@@ -13,10 +14,10 @@  import Control.Applicative import Control.DeepSeq+import Control.Monad import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Error.Class-import Control.Monad.Fail (MonadFail) import Control.Monad.IO.Unlift import Control.Monad.Morph (MFunctor (..)) import Control.Monad.Reader@@ -25,20 +26,21 @@ import Control.Monad.Writer.Class import Data.Aeson import Data.Text (Text)-import Prelude+import Data.Time+import qualified Control.Monad.Fail as MF import qualified Control.Exception as E-import qualified Data.HashMap.Strict as H  import Log.Class import Log.Data import Log.Logger+import qualified Log.Internal.Aeson.Compat as AC  type InnerLogT = ReaderT LoggerEnv  -- | Monad transformer that adds logging capabilities to the underlying monad. newtype LogT m a = LogT { unLogT :: InnerLogT m a }   deriving (Alternative, Applicative, Functor, Monad, MonadBase b, MonadCatch-           ,MonadIO, MonadMask, MonadPlus, MonadThrow, MonadTrans, MonadFail+           ,MonadIO, MonadMask, MonadPlus, MonadThrow, MonadTrans, MF.MonadFail            ,MonadError e, MonadWriter w, MonadState s)  instance MonadReader r m => MonadReader r (LogT m) where@@ -53,16 +55,38 @@ -- for that. runLogT :: Text     -- ^ Application component name to use.         -> Logger   -- ^ The logging back-end to use.+        -> LogLevel -- ^ The maximum log level allowed to be logged.+                    --   Only messages less or equal than this level with be logged.         -> LogT m a -- ^ The 'LogT' computation to run.         -> m a-runLogT component logger m = runReaderT (unLogT m) LoggerEnv {+runLogT component logger maxLogLevel m = runReaderT (unLogT m) LoggerEnv {   leLogger = logger , leComponent = component , leDomain = [] , leData = []+, leMaxLogLevel = maxLogLevel } -- We can't do synchronisation here, since 'runLogT' can be invoked   -- quite often from the application (e.g. on every request). +-- | Ensure uncaught exceptions get logged.+-- Convenient to compose right after `runLogT` so any exception+-- will show up.+logExceptions :: (MonadBaseControl IO m, MonadLog m) => m a -> m a+logExceptions f =+  liftedCatch f $ \(SomeException e) -> do+      logAttention "Uncaught exception" $ object ["exception" .= show e]+      liftBase $ E.throwIO e++-- Generalized version of catch taken from `lifted-base`.+liftedCatch :: (MonadBaseControl IO m, Exception e)+      => m a       -- ^ The computation to run.+      -> (e -> m a) -- ^ Handler to invoke if an exception is raised.+      -> m a+liftedCatch a handler = control $ \runInIO ->+  E.catch+    (runInIO a)+    (runInIO . handler)+ -- | Transform the computation inside a 'LogT'. mapLogT :: (m a -> n b) -> LogT m a -> LogT n b mapLogT f = LogT . mapReaderT f . unLogT@@ -71,7 +95,8 @@ -- 'LoggerEnv'. Useful for reimplementation of 'MonadLog' instance. logMessageIO :: LoggerEnv -> UTCTime -> LogLevel -> Text -> Value -> IO () logMessageIO LoggerEnv{..} time level message data_ =-  execLogger leLogger =<< E.evaluate (force lm)+  when (level <= leMaxLogLevel) $+    execLogger leLogger =<< E.evaluate (force lm)   where     lm = LogMessage       { lmComponent = leComponent@@ -80,11 +105,23 @@       , lmLevel = level       , lmMessage = message       , lmData = case data_ of-          Object obj -> Object . H.union obj $ H.fromList leData-          _ | null leData -> data_-            | otherwise -> object $ ("_data", data_) : leData+          -- If lmData is not an object, we make it so and put previous data as+          -- the singleton value with key reflecting its type. It's required for+          -- ElasticSearch as ES needs fields with the same name to be of the+          -- same type in all log messages.+          Object obj      -> Object . AC.union obj $ AC.fromList leData+          _ | null leData -> object [dataTyped data_ .= data_]+            | otherwise   -> object $ (dataTyped data_, data_) : leData       } +    dataTyped = \case+      Object{} -> "__data_object"+      Array{}  -> "__data_array"+      String{} -> "__data_string"+      Number{} -> "__data_number"+      Bool{}   -> "__data_bool"+      Null{}   -> "__data_null"+ -- | Return an IO action that logs messages using the current 'MonadLog' -- context. Useful for interfacing with libraries such as @aws@ or @amazonka@ -- that accept logging callbacks operating in IO.@@ -95,47 +132,33 @@ -- -- @since 0.7.2 instance MFunctor LogT where-    hoist = mapLogT+    hoist f = mapLogT f  instance MonadTransControl LogT where-#if MIN_VERSION_monad_control(1,0,0)   type StT LogT m = StT InnerLogT m   liftWith = defaultLiftWith LogT unLogT   restoreT = defaultRestoreT LogT-#else-  newtype StT LogT m = StLogT { unStLogT :: StT InnerLogT m }-  liftWith = defaultLiftWith LogT unLogT StLogT-  restoreT = defaultRestoreT LogT unStLogT-#endif-  {-# INLINE liftWith #-}-  {-# INLINE restoreT #-}  instance MonadBaseControl b m => MonadBaseControl b (LogT m) where-#if MIN_VERSION_monad_control(1,0,0)   type StM (LogT m) a = ComposeSt LogT m a   liftBaseWith = defaultLiftBaseWith   restoreM     = defaultRestoreM-#else-  newtype StM (LogT m) a = StMLogT { unStMLogT :: ComposeSt LogT m a }-  liftBaseWith = defaultLiftBaseWith StMLogT-  restoreM     = defaultRestoreM unStMLogT-#endif-  {-# INLINE liftBaseWith #-}-  {-# INLINE restoreM #-}  instance MonadUnliftIO m => MonadUnliftIO (LogT m) where-  askUnliftIO = do-    UnliftIO runInIO <- LogT askUnliftIO-    return $ UnliftIO $ runInIO . unLogT+  withRunInIO inner = LogT $ withRunInIO $ \run -> inner (run . unLogT) -instance (MonadBase IO m, MonadTime m) => MonadLog (LogT m) where-  logMessage time level message data_ = LogT . ReaderT $ \logEnv ->-    liftBase $ logMessageIO logEnv time level message data_+instance MonadBase IO m => MonadLog (LogT m) where+  logMessage level message data_ = LogT . ReaderT $ \logEnv -> liftBase $ do+    time <- getCurrentTime+    logMessageIO logEnv time level message data_    localData data_ =     LogT . local (\e -> e { leData = data_ ++ leData e }) . unLogT    localDomain domain =     LogT . local (\e -> e { leDomain = leDomain e ++ [domain] }) . unLogT++  localMaxLogLevel level =+    LogT . local (\e -> e { leMaxLogLevel = level }) . unLogT    getLoggerEnv = LogT ask