diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/log-base.cabal b/log-base.cabal new file mode 100644 --- /dev/null +++ b/log-base.cabal @@ -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 , + Jonathan Jouty , + Mikhail Glushenkov , + Oleg Grenrus +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 diff --git a/src/Log.hs b/src/Log.hs new file mode 100644 --- /dev/null +++ b/src/Log.hs @@ -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 diff --git a/src/Log/Backend/StandardOutput.hs b/src/Log/Backend/StandardOutput.hs new file mode 100644 --- /dev/null +++ b/src/Log/Backend/StandardOutput.hs @@ -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 diff --git a/src/Log/Backend/StandardOutput/Bulk.hs b/src/Log/Backend/StandardOutput/Bulk.hs new file mode 100644 --- /dev/null +++ b/src/Log/Backend/StandardOutput/Bulk.hs @@ -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 ()) diff --git a/src/Log/Backend/Text.hs b/src/Log/Backend/Text.hs new file mode 100644 --- /dev/null +++ b/src/Log/Backend/Text.hs @@ -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) diff --git a/src/Log/Class.hs b/src/Log/Class.hs new file mode 100644 --- /dev/null +++ b/src/Log/Class.hs @@ -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_ diff --git a/src/Log/Data.hs b/src/Log/Data.hs new file mode 100644 --- /dev/null +++ b/src/Log/Data.hs @@ -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 diff --git a/src/Log/Internal/Logger.hs b/src/Log/Internal/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Log/Internal/Logger.hs @@ -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 = (<>) diff --git a/src/Log/Logger.hs b/src/Log/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Log/Logger.hs @@ -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: +-- +-- +-- 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" diff --git a/src/Log/Monad.hs b/src/Log/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Log/Monad.hs @@ -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