log-base (empty) → 0.7

raw patch · 12 files changed

+820/−0 lines, 12 filesdep +aesondep +aeson-prettydep +basesetup-changed

Dependencies added: aeson, aeson-pretty, base, bytestring, deepseq, exceptions, monad-control, monad-time, mtl, semigroups, stm, text, time, transformers-base, unordered-containers

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• log-base.cabal +72/−0
• src/Log.hs +45/−0
• src/Log/Backend/StandardOutput.hs +37/−0
• src/Log/Backend/StandardOutput/Bulk.hs +32/−0
• src/Log/Backend/Text.hs +31/−0
• src/Log/Class.hs +93/−0
• src/Log/Data.hs +128/−0
• src/Log/Internal/Logger.hs +70/−0
• src/Log/Logger.hs +165/−0
• src/Log/Monad.hs +115/−0

@@ -0,0 +1,30 @@+Copyright (c) 2015, Scrive AB++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andrzej Rybczak nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,72 @@+name:                log-base+version:             0.7+synopsis:            Structured logging solution (base package)++description:         A library that provides a way to record structured log+                     messages. Use this package in conjunction with+                     'log-elasticsearch' or 'log-postgres', depending+                     on which back end you need. Use the 'log' library+                     if you need all back ends.+++homepage:            https://github.com/scrive/log+license:             BSD3+license-file:        LICENSE+author:              Scrive AB+maintainer:          Andrzej Rybczak <andrzej@rybczak.net>,+                     Jonathan Jouty <jonathan@scrive.com>,+                     Mikhail Glushenkov <mikhail@scrive.com>,+                     Oleg Grenrus <oleg.grenrus@iki.fi>+copyright:           Scrive AB+category:            System+build-type:          Simple+cabal-version:       >=1.10+tested-with:         GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1++Source-repository head+  Type:     git+  Location: https://github.com/scrive/log.git++library+  exposed-modules:     Log,+                       Log.Backend.StandardOutput,+                       Log.Backend.StandardOutput.Bulk,+                       Log.Backend.Text,+                       Log.Class,+                       Log.Data,+                       Log.Internal.Logger,+                       Log.Logger,+                       Log.Monad+  build-depends:       base <5,+                       aeson >=0.11.0.0,+                       aeson-pretty >=0.8.2,+                       bytestring,+                       deepseq,+                       exceptions >=0.6,+                       monad-control >=0.3,+                       monad-time >= 0.2,+                       mtl,+                       semigroups,+                       stm >=2.4,+                       text,+                       time >= 1.5,+                       transformers-base,+                       unordered-containers+  hs-source-dirs:      src++  ghc-options:         -O2 -Wall -funbox-strict-fields++  default-language:   Haskell2010+  default-extensions: BangPatterns+                    , FlexibleContexts+                    , FlexibleInstances+                    , GeneralizedNewtypeDeriving+                    , LambdaCase+                    , MultiParamTypeClasses+                    , NoImplicitPrelude+                    , OverloadedStrings+                    , RankNTypes+                    , RecordWildCards+                    , ScopedTypeVariables+                    , TypeFamilies+                    , UndecidableInstances

@@ -0,0 +1,45 @@+-- | Structured logging solution with multiple backends.+--+-- @+-- {-\# LANGUAGE OverloadedStrings #-}+--+-- module Main where+--+-- import Log+-- import Log.Backend.ElasticSearch+--+-- import System.Random+--+-- main :: IO ()+-- main = do+--   let config = 'Log.Backend.ElasticSearch.ElasticSearchConfig' {+--         esServer  = "http://localhost:9200",+--         esIndex   = "logs",+--         esMapping = "log"+--         }+--   'Log.Backend.ElasticSearch.withElasticSearchLogger' config randomIO $ \\logger -> do+--     'runLogT' "main" logger $ do+--       'logTrace_' "foo"+-- @+module Log (+    -- * Documentation+    -- | 'Log.Class.MonadLog' type class of monads with logging capabilities.+    module Log.Class+    -- | 'Log.Data.LogMessage' and 'Log.Data.LogLevel' data definitions.+  , module Log.Data+    -- | 'Log.Logger.Logger' objects used to perform logging operations in ''Log.Monad.LogT'.+  , module Log.Logger+    -- | 'Log.Monad.LogT' monad transformer that adds logging capabilities to+    -- the underlying monad.+  , module Log.Monad+   -- * Aeson re-exports+  , object+  , (.=)+  ) where++import Data.Aeson++import Log.Class+import Log.Data+import Log.Logger+import Log.Monad

@@ -0,0 +1,37 @@+-- | Stdout logging back-end.+module Log.Backend.StandardOutput (+    simpleStdoutLogger+  , stdoutLogger+  , withSimpleStdOutLogger+  ) where++import Prelude+import qualified Data.Text.IO as T+import System.IO++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.+simpleStdoutLogger :: Logger+simpleStdoutLogger = Logger {+    loggerWriteMessage = T.putStrLn . showLogMessage Nothing+  , loggerWaitForWrite = hFlush stdout+  , loggerShutdown     = return ()+  }++{-# DEPRECATED stdoutLogger "Use 'withSimpleStdOutLogger'" #-}++-- | Create a logger that prints messages to standard output.+stdoutLogger :: IO Logger+stdoutLogger = mkLogger "stdout" $ T.putStrLn . showLogMessage Nothing

@@ -0,0 +1,32 @@+-- | Bulk stdout logging back-end, useful mainly for testing.+module Log.Backend.StandardOutput.Bulk (+    withBulkStdOutLogger,+    bulkStdoutLogger+  ) where++import Prelude+import qualified Data.Text.IO as T++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.+withBulkStdOutLogger :: (Logger -> IO r) -> IO r+withBulkStdOutLogger act = do+  logger <- bulkStdoutLogger+  withLogger logger act++{-# DEPRECATED bulkStdoutLogger "Use 'withBulkStdOutLogger' instead!" #-}++-- | 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"+                   (mapM_ $ T.putStrLn . showLogMessage Nothing)+                   (return ())

@@ -0,0 +1,31 @@+-- | A logger that produces in-memory 'Text' values. Mainly useful for+-- testing.+module Log.Backend.Text ( withSimpleTextLogger ) where++import Control.Applicative+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++import Log.Data+import Log.Internal.Logger++-- | 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+  builderRef <- newIORef mempty+  let logger = Logger+        { loggerWriteMessage = \msg -> do+            let msg' = B.fromText $ showLogMessage Nothing msg+            modifyIORef' builderRef (<> msg' <> B.fromText "\n")+        , loggerWaitForWrite = return ()+        , loggerShutdown     = return ()+        }+  r <- act logger+  txt <- L.toStrict . B.toLazyText <$> readIORef builderRef+  return (txt, r)

@@ -0,0 +1,93 @@+-- | 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+  , logTrace+  , logAttention_+  , logInfo_+  , 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++-- | Represents the family of monads with logging capabilities. Each+-- '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+  -- | 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 ()+  -- | 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++-- | Generic, overlapping instance.+instance (+    MonadLog m+  , Monad (t m)+  , MonadTransControl t+  ) => MonadLog (t m) where+    logMessage time level message = lift . logMessage time level message+    localData data_ m = controlT $ \run -> localData data_ (run m)+    localDomain domain m = controlT $ \run -> localDomain domain (run m)++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++-- | 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++-- | 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++-- | Like 'logAttention', but without any additional associated data.+logAttention_ :: MonadLog m => T.Text -> m ()+logAttention_ = (`logAttention` emptyObject)++-- | Like 'logInfo', but without any additional associated data.+logInfo_ :: MonadLog m => T.Text -> m ()+logInfo_ = (`logInfo` emptyObject)++-- | 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_

@@ -0,0 +1,128 @@+-- | Basic data types used throughout the package.+module Log.Data (+    LogLevel(..)+  , showLogLevel+  , readLogLevel+  , LogMessage(..)+  , showLogMessage+  ) where++import Control.DeepSeq+import Control.Applicative+import Data.Aeson+import Data.Aeson.Encode.Pretty+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.+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+readLogLevelEither "info"      = Right LogInfo+readLogLevelEither "trace"     = Right LogTrace+readLogLevelEither level       = Left $ "readLogLevel: unknown level: "+                                 ++ T.unpack level++showLogLevel :: LogLevel -> T.Text+showLogLevel LogAttention = "attention"+showLogLevel LogInfo      = "info"+showLogLevel LogTrace     = "trace"++instance ToJSON LogLevel where+  toJSON = toJSON . showLogLevel+  toEncoding = toEncoding . showLogLevel++instance FromJSON LogLevel where+  parseJSON = withText "LogLevel" $+    either fail pure . readLogLevelEither++instance NFData LogLevel where+  rnf = (`seq` ())++-- | Represents message to be logged.+data LogMessage = LogMessage {+  -- | Component of an application.+  lmComponent :: !T.Text+  -- | Aplication log domain.+, lmDomain    :: ![T.Text]+  -- | Time of the logged event.+, lmTime      :: !UTCTime+  -- | Log level.+, lmLevel     :: !LogLevel+  -- | Message to be logged.+, lmMessage   :: !T.Text+  -- | Additional data associated with the message.+, lmData      :: !Value+} deriving (Eq, Show)++-- | Render a 'LogMessage' to 'Text'.+showLogMessage :: Maybe UTCTime -- ^ The time that message was added to the log.+               -> LogMessage    -- ^ The actual message.+               -> T.Text+showLogMessage mInsertionTime LogMessage{..} = T.concat $ [+    T.pack $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" lmTime+  , case mInsertionTime of+      Nothing -> " "+      Just it -> T.pack $ formatTime defaultTimeLocale " (%H:%M:%S) " it+  , T.toUpper $ showLogLevel lmLevel+  , " "+  , T.intercalate "/" $ lmComponent : lmDomain+  , ": "+  , lmMessage+  ] ++ if lmData == emptyObject+    then []+    else [" ", textifyData lmData]+  where+    textifyData :: Value -> T.Text+    textifyData = T.decodeUtf8 . toStrict . encodePretty' defConfig {+      confIndent = Spaces 2+    }++instance ToJSON LogMessage where+  toJSON LogMessage{..} = object [+      "component" .= lmComponent+    , "domain"    .= lmDomain+    , "time"      .= lmTime+    , "level"     .= lmLevel+    , "message"   .= lmMessage+    , "data"      .= lmData+    ]++  toEncoding LogMessage{..} = pairs $ Monoid.mconcat [+      "component" .= lmComponent+    , "domain"    .= lmDomain+    , "time"      .= lmTime+    , "level"     .= lmLevel+    , "message"   .= lmMessage+    , "data"      .= lmData+    ]++instance FromJSON LogMessage where+  parseJSON = withObject "LogMessage" $ \obj -> LogMessage+    -- to suppress warnings+    Control.Applicative.<$> obj .: "component"+    <*> obj .: "domain"+    <*> obj .: "time"+    <*> obj .: "level"+    <*> obj .: "message"+    <*> obj .: "data"++instance NFData LogMessage where+  rnf LogMessage{..} = rnf lmComponent+    `seq` rnf lmDomain+    `seq` rnf lmTime+    `seq` rnf lmLevel+    `seq` rnf lmMessage+    `seq` rnf lmData

@@ -0,0 +1,70 @@+-- | The 'Logger' type - implementation details.+{-# OPTIONS_HADDOCK hide #-}+module Log.Internal.Logger (+    Logger(..)+  , execLogger+  , waitForLogger+  , shutdownLogger+  , withLogger+  ) where++import Data.Semigroup+import Control.Exception+import Prelude++import Log.Data++-- | An object used for communication with a logger thread that+-- outputs 'LogMessage's using e.g. PostgreSQL, Elasticsearch or+-- stdout (depending on the back-end chosen).+data Logger = Logger {+  loggerWriteMessage :: !(LogMessage -> IO ()) -- ^ Output a 'LogMessage'.+, loggerWaitForWrite :: !(IO ())+                     -- ^ Wait for the logger to output all messages+                     -- in its input queue (in the case logging is+                     -- done asynchronously).+, loggerShutdown     :: !(IO ())+                     -- ^ Kill the logger thread. Subsequent attempts+                     -- to write messages to the logger will raise an+                     -- exception.+}++-- | Execute logger to serialize a 'LogMessage'.+execLogger :: Logger -> LogMessage -> IO ()+execLogger Logger{..} = loggerWriteMessage++-- | Wait until all 'LogMessage's stored in the internal queue are+-- serialized.+waitForLogger :: Logger -> IO ()+waitForLogger Logger{..} = loggerWaitForWrite++-- | Shutdown the logger thread associated with this 'Logger'+-- object. Subsequent attempts to write messages via this 'Logger'+-- will result in an exception.+shutdownLogger :: Logger -> IO ()+shutdownLogger Logger{..} = loggerShutdown++-- | 'bracket'-like execution of an 'IO' action, verifying all messages+-- are properly logged. See 'mkBulkLogger'.+withLogger :: Logger -> (Logger -> IO r) -> IO r+withLogger logger act = act logger `finally` cleanup+  where+    cleanup = waitForLogger logger >> shutdownLogger logger++instance Semigroup Logger where+  l1 <> l2 = Logger {+    loggerWriteMessage = \msg -> do+      loggerWriteMessage l1 msg+      loggerWriteMessage l2 msg+  , loggerWaitForWrite = do+      loggerWaitForWrite l1+      loggerWaitForWrite l2+  , loggerShutdown     = do+      loggerShutdown l1+      loggerShutdown l2+  }++-- | Composition of 'Logger' objects.+instance Monoid Logger where+  mempty  = Logger (const $ return ()) (return ()) (return ())+  mappend = (<>)

@@ -0,0 +1,165 @@+-- | The 'Logger' type of logging back-ends.+module Log.Logger (+    Logger+  , mkLogger+  , mkBulkLogger+  , execLogger+  , waitForLogger+  , 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.Text as T+import qualified Data.Text.IO as T++import Log.Data+import Log.Internal.Logger++-- | Start a logger thread that consumes one queued message at a time.+mkLogger :: T.Text -> (LogMessage -> IO ()) -> IO Logger+mkLogger name exec = mkLoggerImpl+  newTQueueIO isEmptyTQueue readTQueue writeTQueue (return ())+  name exec (return ())++-- | Start an asynchronous logger thread that consumes all queued+-- messages once per second. 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.+--+-- 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:+-- <https://mail.haskell.org/pipermail/haskell-cafe/2014-February/112754.html>+--+-- To work around this issue, make sure that the main thread doesn't+-- exit until all its children have terminated. The 'async' package+-- makes this easy.+--+-- Problematic example:+--+-- @+-- import Control.Concurrent.Async+--+-- main :: IO ()+-- 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")+--    -- Main thread exits without waiting for the child+--    -- to finish and without giving the child a chance+--    -- to do proper cleanup.+-- @+--+-- Fixed example:+--+-- @+-- import Control.Concurrent.Async+--+-- main :: IO ()+-- 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")+--    '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 = mkLoggerImpl+  newSQueueIO isEmptySQueue readSQueue writeSQueue (threadDelay 1000000)++----------------------------------------++-- | A simple STM based queue.+newtype SQueue a = SQueue (TVar [a])++-- | Create an instance of 'SQueue'.+newSQueueIO :: IO (SQueue a)+newSQueueIO = SQueue <$> newTVarIO []++-- | Check if an 'SQueue' is empty.+isEmptySQueue :: SQueue a -> STM Bool+isEmptySQueue (SQueue queue) = null <$> readTVar queue++-- | Read all the values stored in an 'SQueue'.+readSQueue :: SQueue a -> STM [a]+readSQueue (SQueue queue) = do+  elems <- readTVar queue+  when (null elems) retry+  writeTVar queue []+  return $ reverse elems++-- | Write a value to an 'SQueue'.+writeSQueue :: SQueue a -> a -> STM ()+writeSQueue (SQueue queue) a = modifyTVar queue (a :)++----------------------------------------++mkLoggerImpl :: IO queue+             -> (queue -> STM Bool)+             -> (queue -> STM msgs)+             -> (queue -> LogMessage -> STM ())+             -> IO ()+             -> T.Text+             -> (msgs -> IO ())+             -> IO ()+             -> IO Logger+mkLoggerImpl newQueue isQueueEmpty readQueue writeQueue afterExecDo+  name exec sync = do+  queue      <- newQueue+  inProgress <- newTVarIO False+  isRunning  <- newTVarIO True+  tid <- forkFinally (forever $ loop queue inProgress)+                     (\_ -> cleanup queue inProgress)+  return Logger {+    loggerWriteMessage = \msg -> atomically $ do+        checkIsRunning isRunning+        writeQueue queue msg,+    loggerWaitForWrite = do+        atomically $ waitForWrite queue inProgress+        sync,+    loggerShutdown     = do+        killThread tid+        atomically $ writeTVar isRunning False+    }+  where+    checkIsRunning isRunning' = do+      isRunning <- readTVar isRunning'+      when (not isRunning) $+        throwSTM (AssertionFailed $ "Log.Logger.mkLoggerImpl: "+                   ++ "attempt to write to a shut down logger")++    loop queue inProgress = do+      step queue inProgress+      afterExecDo++    step queue inProgress = do+      msgs <- atomically $ do+        writeTVar inProgress True+        readQueue queue+      exec msgs+      atomically $ writeTVar inProgress False++    cleanup queue inProgress = do+      step queue inProgress+      sync+      -- Don't call afterExecDo, since it's either a no-op or a+      -- threadDelay.+      printLoggerTerminated++    waitForWrite queue inProgress = do+      isEmpty <- isQueueEmpty queue+      isInProgress <- readTVar inProgress+      when (not isEmpty || isInProgress) retry++    printLoggerTerminated = T.putStrLn $ name <> ": logger thread terminated"

@@ -0,0 +1,115 @@+-- | The 'LogT' monad transformer for adding logging capabilities to any monad.+{-# LANGUAGE CPP #-}+module Log.Monad (+    Logger+  , LoggerEnv(..)+  , InnerLogT+  , LogT(..)+  , runLogT+  , mapLogT+  ) where++import Control.Applicative+import Control.DeepSeq+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Data.Aeson+import Data.Aeson.Types+import Data.Text (Text)+import Prelude+import qualified Control.Exception as E+import qualified Data.HashMap.Strict as H++import Log.Class+import Log.Data+import Log.Logger++-- | The state that every 'LogT' carries around.+data LoggerEnv = LoggerEnv {+  leLogger    :: !Logger -- ^ The 'Logger' to use.+, leComponent :: !Text   -- ^ Current application component.+, leDomain    :: ![Text] -- ^ Current application domain.+, leData      :: ![Pair] -- ^ Additional data to be merged with the+                         -- log message\'s data.+}++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)++-- | Run a 'LogT' computation.+--+-- Note that in the case of asynchronous/bulk loggers 'runLogT'+-- doesn't guarantee that all messages are actually written to the log+-- once it finishes. Use 'withPGLogger' or 'withElasticSearchLogger'+-- for that.+runLogT :: Text     -- ^ Application component name to use.+        -> Logger   -- ^ The logging back-end to use.+        -> LogT m a -- ^ The 'LogT' computation to run.+        -> m a+runLogT component logger m = runReaderT (unLogT m) LoggerEnv {+  leLogger = logger+, leComponent = component+, leDomain = []+, leData = []+} -- We can't do synchronisation here, since 'runLogT' can be invoked+  -- quite often from the application (e.g. on every request).++-- | Transform the computation inside a 'LogT'.+mapLogT :: (m a -> n b) -> LogT m a -> LogT n b+mapLogT f = LogT . mapReaderT f . unLogT++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 (MonadBase IO m, MonadTime m) => MonadLog (LogT m) where+  logMessage time level message data_ = LogT $ ReaderT logMsg+    where+      logMsg LoggerEnv{..} = liftBase $ do+        execLogger leLogger =<< E.evaluate (force lm)+        where+          lm = LogMessage {+            lmComponent = leComponent+          , lmDomain = leDomain+          , lmTime = time+          , 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+          }++  localData data_ =+    LogT . local (\e -> e { leData = data_ ++ leData e }) . unLogT++  localDomain domain =+    LogT . local (\e -> e { leDomain = leDomain e ++ [domain] }) . unLogT