diff --git a/log.cabal b/log.cabal --- a/log.cabal +++ b/log.cabal @@ -1,8 +1,9 @@ name: log -version: 0.5.3 +version: 0.5.4 synopsis: Structured logging solution with multiple backends -description: A library that provides a way to record structured log messages with multiple backends. +description: A library that provides a way to record structured + log messages with multiple backends. . Supported backends: . @@ -15,21 +16,26 @@ homepage: https://github.com/scrive/log license: BSD3 license-file: LICENSE -author: Scrive -maintainer: Andrzej Rybczak , Jonathan Jouty +author: Scrive AB +maintainer: Andrzej Rybczak , + Jonathan Jouty , + Mikhail Glushenkov +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 + Location: https://github.com/scrive/log.git library exposed-modules: Log, Log.Backend.ElasticSearch, Log.Backend.PostgreSQL, Log.Backend.StandardOutput, + Log.Backend.StandardOutput.Bulk, Log.Class, Log.Data, Log.Internal.Logger, @@ -52,6 +58,7 @@ monad-time >= 0.2, mtl, old-locale, + semigroups, split, stm >=2.4, text, @@ -80,3 +87,52 @@ , ScopedTypeVariables , TypeFamilies , UndecidableInstances + +test-suite log-test + type: exitcode-stdio-1.0 + build-depends: aeson, + base, + bloodhound, + bytestring, + http-client, + http-types, + log, + random, + tasty, + tasty-hunit, + time, + text + hs-source-dirs: test + main-is: Test.hs + other-modules: Test.ElasticSearch + ghc-options: -Wall -threaded + default-language: Haskell2010 + default-extensions: BangPatterns + , OverloadedStrings + , RecordWildCards + +test-suite log-test-integration + type: exitcode-stdio-1.0 + build-depends: aeson, + base, + bloodhound, + bytestring, + exceptions, + http-client, + http-types, + log, + process, + random, + tasty, + tasty-hunit, + time, + text, + transformers + hs-source-dirs: test + main-is: IntegrationTest.hs + other-modules: Test.ElasticSearch + ghc-options: -Wall -threaded + default-language: Haskell2010 + default-extensions: BangPatterns + , OverloadedStrings + , RecordWildCards diff --git a/src/Log.hs b/src/Log.hs --- a/src/Log.hs +++ b/src/Log.hs @@ -1,3 +1,4 @@ +-- | Structured logging solution with multiple backends. module Log ( module Log.Class , module Log.Data diff --git a/src/Log/Backend/ElasticSearch.hs b/src/Log/Backend/ElasticSearch.hs --- a/src/Log/Backend/ElasticSearch.hs +++ b/src/Log/Backend/ElasticSearch.hs @@ -1,6 +1,10 @@ +-- | Elasticsearch logging back-end. module Log.Backend.ElasticSearch ( ElasticSearchConfig(..) + , defaultElasticSearchConfig + , withElasticSearchLogger , elasticSearchLogger + ) where import Control.Applicative @@ -14,8 +18,8 @@ import Data.Aeson.Encode.Pretty import Data.Bits import Data.IORef -import Data.Monoid import Data.Monoid.Utils +import Data.Semigroup import Data.Time import Data.Time.Clock.POSIX import Data.Word @@ -33,19 +37,50 @@ import qualified Data.Traversable as F import qualified Data.Vector as V +-- | Configuration for the Elasticsearch 'Logger'. See +-- +-- for the explanation of terms. data ElasticSearchConfig = ElasticSearchConfig { - esServer :: !T.Text - , esIndex :: !T.Text - , esMapping :: !T.Text + esServer :: !T.Text -- ^ Elasticsearch server address. + , esIndex :: !T.Text -- ^ Elasticsearch index name. + , esMapping :: !T.Text -- ^ Elasticsearch mapping name. } deriving (Eq, Show) +-- | Sensible defaults for 'ElasticSearchConfig'. +defaultElasticSearchConfig :: ElasticSearchConfig +defaultElasticSearchConfig = ElasticSearchConfig { + esServer = "http://localhost:9200", + esIndex = "logs", + esMapping = "log" + } + + ---------------------------------------- +-- | Create an 'elasticSearchLogger' for the duration of the given +-- action, and shut it down afterwards, making sure that all buffered +-- messages are actually written to the Elasticsearch store. +withElasticSearchLogger :: ElasticSearchConfig -> IO Word32 -> (Logger -> IO r) + -> IO r +withElasticSearchLogger conf randGen act = do + logger <- elasticSearchLogger conf randGen + (act logger) `finally` (do { waitForLogger logger; shutdownLogger logger; }) -elasticSearchLogger :: ElasticSearchConfig -> IO Word32 -> IO Logger +{-# DEPRECATED elasticSearchLogger "Use 'withElasticSearchLogger' instead!" #-} + +-- | Start an asynchronous logger thread that stores messages using +-- Elasticsearch. +-- +-- Please use 'withElasticSearchLogger' instead, which is more +-- exception-safe (see the note attached to 'mkBulkLogger'). +elasticSearchLogger :: + ElasticSearchConfig -- ^ Configuration. + -> IO Word32 -- ^ Generate a random 32-bit word for use in + -- document IDs. + -> IO Logger elasticSearchLogger ElasticSearchConfig{..} genRandomWord = do checkElasticSearchConnection indexRef <- newIORef $ IndexName T.empty - mkBulkLogger "ElasticSearch" $ \msgs -> do + mkBulkLogger "ElasticSearch" (\msgs -> do now <- getCurrentTime oldIndex <- readIORef indexRef -- Bloodhound doesn't support letting ES autogenerate IDs, so let's generate @@ -56,7 +91,7 @@ <$> (littleEndianRep <$> liftIO genRandomWord) <*> pure (littleEndianRep . floor $ timeToDouble now) retryOnException . runBH_ $ do - -- ElasticSearch index names are additionally indexed by date so that each + -- Elasticsearch index names are additionally indexed by date so that each -- day is logged to a separate index to make log management easier. let index = IndexName $ T.concat [ esIndex @@ -77,7 +112,9 @@ void $ createIndex indexSettings index reply <- putMapping index mapping LogsMapping when (not $ isSuccess reply) $ do - error $ "ElasticSearch: error while creating mapping:" <+> T.unpack (T.decodeUtf8 . BSL.toStrict . jsonToBSL $ decodeReply reply) + error $ "ElasticSearch: error while creating mapping:" + <+> T.unpack (T.decodeUtf8 . BSL.toStrict . jsonToBSL + $ decodeReply reply) liftIO $ writeIORef indexRef index let jsonMsgs = V.fromList $ map (toJsonMsg now) $ zip [1..] msgs reply <- bulk $ V.map (toBulk index baseID) jsonMsgs @@ -95,7 +132,8 @@ guard $ V.length items == V.length jsonMsgs return (hasErrors, items) case result of - Nothing -> liftIO . BSL.putStrLn $ "ElasticSearch: unexpected response:" <+> jsonToBSL replyBody + Nothing -> liftIO . BSL.putStrLn + $ "ElasticSearch: unexpected response:" <+> jsonToBSL replyBody Just (hasErrors, items) -> when hasErrors $ do -- If any message failed to be inserted because of type mismatch, go -- back to them, replace their data with elastic search error and put @@ -110,20 +148,29 @@ ] return . second (H.adjust modifyData "data") $ jsonMsgs V.! n -- Attempt to put modified messages and ignore any further errors. - void $ bulk (V.map (toBulk index baseID) dummyMsgs) + void $ bulk (V.map (toBulk index baseID) dummyMsgs)) + (elasticSearchSync indexRef) where server = Server esServer mapping = MappingName esMapping + elasticSearchSync :: IORef IndexName -> IO () + elasticSearchSync indexRef = do + indexName <- readIORef indexRef + void . runBH_ $ refreshIndex indexName + checkElasticSearchConnection :: IO () checkElasticSearchConnection = try (void $ runBH_ listIndices) >>= \case - Left (ex::HttpException) -> error $ "ElasticSearch: unexpected error: " <> show ex <> " (is ElasticSearch server running?)" + Left (ex::HttpException) -> error $ "ElasticSearch: unexpected error: " + <> show ex + <> " (is ElasticSearch server running?)" Right () -> return () retryOnException :: forall r. IO r -> IO r retryOnException m = try m >>= \case Left (ex::SomeException) -> do - putStrLn $ "ElasticSearch: unexpected error: " <> show ex <> ", retrying in 10 seconds" + putStrLn $ "ElasticSearch: unexpected error: " + <> show ex <> ", retrying in 10 seconds" threadDelay $ 10 * 1000000 retryOnException m Right result -> return result @@ -137,7 +184,8 @@ jsonToBSL :: Value -> BSL.ByteString jsonToBSL = encodePretty' defConfig { confIndent = Spaces 2 } - toJsonMsg :: UTCTime -> (Word32, LogMessage) -> (Word32, H.HashMap T.Text Value) + toJsonMsg :: UTCTime -> (Word32, LogMessage) + -> (Word32, H.HashMap T.Text Value) toJsonMsg now (n, msg) = (n, H.union jMsg $ H.fromList [ ("insertion_order", toJSON n) , ("insertion_time", toJSON now) @@ -146,29 +194,31 @@ Object jMsg = toJSON msg mkDocId :: BS.ByteString -> Word32 -> DocId - mkDocId baseID insertionOrder = DocId . T.decodeUtf8 . B64.encode $ BS.concat [ + mkDocId baseID insertionOrder = DocId . T.decodeUtf8 + . B64.encode $ BS.concat [ baseID , littleEndianRep insertionOrder ] - toBulk :: IndexName -> BS.ByteString -> (Word32, H.HashMap T.Text Value) -> BulkOperation - toBulk index baseID (n, obj) = BulkIndex index mapping (mkDocId baseID n) $ Object obj + toBulk :: IndexName -> BS.ByteString -> (Word32, H.HashMap T.Text Value) + -> BulkOperation + toBulk index baseID (n, obj) = + BulkIndex index mapping (mkDocId baseID n) $ Object obj data LogsMapping = LogsMapping instance ToJSON LogsMapping where toJSON LogsMapping = object [ - "logs" .= object [ - "properties" .= object [ - "insertion_order" .= object [ + "properties" .= object [ + "insertion_order" .= object [ "type" .= ("integer"::T.Text) ] , "insertion_time" .= object [ "type" .= ("date"::T.Text) - , "format" .= ("strict_date_time"::T.Text) + , "format" .= ("date_time"::T.Text) ] , "time" .= object [ "type" .= ("date"::T.Text) - , "format" .= ("strict_date_time"::T.Text) + , "format" .= ("date_time"::T.Text) ] , "domain" .= object [ "type" .= ("string"::T.Text) @@ -183,7 +233,6 @@ "type" .= ("string"::T.Text) ] ] - ] ] ---------------------------------------- diff --git a/src/Log/Backend/PostgreSQL.hs b/src/Log/Backend/PostgreSQL.hs --- a/src/Log/Backend/PostgreSQL.hs +++ b/src/Log/Backend/PostgreSQL.hs @@ -1,4 +1,5 @@ -module Log.Backend.PostgreSQL (pgLogger) where +-- | PostgreSQL logging back-end. +module Log.Backend.PostgreSQL (pgLogger, withPgLogger) where import Control.Applicative import Control.Concurrent @@ -6,8 +7,8 @@ import Control.Monad.State.Lazy import Data.Aeson import Data.List.Split -import Data.Monoid import Data.Monoid.Utils +import Data.Semigroup import Data.String import Data.Typeable import Database.PostgreSQL.PQTypes @@ -25,19 +26,39 @@ newtype InvalidEncodingRecoveryAttempt = Attempt Int deriving Enum --- | Create logger that inserts log messages into PostgreSQL database. +-- | Create a 'pgLogger' for the duration of the given action, and +-- shut it down afterwards, making sure that all buffered messages are +-- actually written to the DB. +withPgLogger :: ConnectionSourceM IO -> (Logger -> IO r) -> IO r +withPgLogger cs act = do + logger <- pgLogger cs + (act logger) `finally` (do { waitForLogger logger; shutdownLogger logger; }) + +{-# DEPRECATED pgLogger "Use 'withPgLogger' instead!" #-} + +-- | Start an asynchronous logger thread that inserts log messages +-- into a PostgreSQL database. +-- +-- Please use 'withPglogger' instead, which is more exception-safe +-- (see the note attached to 'mkBulkLogger'). pgLogger :: ConnectionSourceM IO -> IO Logger pgLogger cs = mkBulkLogger loggerName - $ mapM_ (serialize $ Attempt 1) . chunksOf 1000 + (mapM_ (serialize $ Attempt 1) . chunksOf 1000) + (return ()) where loggerName :: IsString s => s loggerName = "PostgreSQL" sqlInsertLog :: SQL - sqlInsertLog = "INSERT INTO logs (insertion_time, insertion_order, time, level, component, domain, message, data) VALUES" + sqlInsertLog = "INSERT INTO logs " + <+> "(insertion_time, insertion_order, time, level, component," + <+> " domain, message, data) VALUES" serialize :: InvalidEncodingRecoveryAttempt -> [LogMessage] -> IO () - serialize !attempt msgs = runDBT cs ts (runSQL_ $ sqlInsertLog <+> mintercalate ", " (map sqlifyMessage $ zip [1..] msgs)) `catches` [ + serialize !attempt msgs = runDBT cs ts + (runSQL_ $ sqlInsertLog + <+> mintercalate ", " (map sqlifyMessage $ zip [1..] msgs)) + `catches` [ -- Propagate base async exceptions thrown by the runtime system. Handler $ \(e::AsyncException) -> throwIO e , Handler $ \(e::SomeException) -> case fromException e of @@ -49,13 +70,16 @@ -- serialization), then this error occurs only when any of the -- strings we want to serialize contains NULL bytes. In such -- case we scan the logs and replace each NULL with "\0". - putStrLn $ loggerName ++ ": couldn't serialize logs due to character encoding error \"" ++ qeMessagePrimary qe ++ "\", removing NULL bytes and retrying" + putStrLn $ loggerName + ++ ": couldn't serialize logs due to character encoding error \"" + ++ qeMessagePrimary qe ++ "\", removing NULL bytes and retrying" serialize (succ attempt) $ map (\msg -> -- If any text inside the message had NULL bytes, -- add acknowledgment of that fact to its data. case runState (mapTexts removeNULLs msg) False of (newMsg, True) -> newMsg { - lmData = lmData newMsg `addPair` ("_log", "NULL bytes were escaped") + lmData = lmData newMsg + `addPair` ("_log", "NULL bytes were escaped") } (_, False) -> msg) msgs Attempt 2 -> do @@ -63,17 +87,28 @@ -- a minute. If the error is still happening after removal -- of NULL bytes, go through each message and encode all -- texts as base64, effectively transforming them into ASCII. - putStrLn $ loggerName ++ ": couldn't serialize logs due to character encoding error \"" ++ qeMessagePrimary qe ++ "\" after NULL bytes were removed, encoding all texts in the problematic batch as base64 to make them ASCII" + putStrLn $ loggerName + ++ ": couldn't serialize logs due to character encoding error \"" + ++ qeMessagePrimary qe + ++ "\" after NULL bytes were removed, encoding all texts" + ++ " in the problematic batch as base64 to make them ASCII" serialize (succ attempt) $ map (\msg -> let newMsg = runIdentity $ mapTexts convertBase64 msg in newMsg { - lmData = lmData newMsg `addPair` ("_log", "Texts encoded as base64") + lmData = lmData newMsg + `addPair` ("_log", "Texts encoded as base64") }) msgs Attempt _ -> do -- This can't happen, all texts are ASCII now. - putStrLn $ loggerName ++ ": impossible happened (>2 attempt failed because of character encoding error \"" ++ qeMessagePrimary qe ++ "\" even though all texts are ASCII), skipping the batch" + putStrLn $ loggerName + ++ ": impossible happened " + ++ "(>2 attempt failed because of character encoding error \"" + ++ qeMessagePrimary qe + ++ "\" even though all texts are ASCII), skipping the batch" _ -> do - putStrLn $ loggerName ++ ": couldn't serialize logs:" <+> show e ++ ", retrying in 10 seconds" + putStrLn $ loggerName + ++ ": couldn't serialize logs:" + <+> show e ++ ", retrying in 10 seconds" threadDelay $ 10 * 1000000 -- Do not increment the attempt here, it's used to -- track invalid encoding recovery attempts only. diff --git a/src/Log/Backend/StandardOutput.hs b/src/Log/Backend/StandardOutput.hs --- a/src/Log/Backend/StandardOutput.hs +++ b/src/Log/Backend/StandardOutput.hs @@ -1,23 +1,38 @@ +-- | Stdout logging back-end. module Log.Backend.StandardOutput ( simpleStdoutLogger , stdoutLogger + , withSimpleStdOutLogger ) where import Prelude +import Control.Exception 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 + (act logger) `finally` (do { waitForLogger logger; shutdownLogger logger; }) + +{-# DEPRECATED simpleStdoutLogger "Use 'withSimpleStdoutLogger'" #-} + -- | Simple, synchronous logger that prints messages to standard output. simpleStdoutLogger :: Logger simpleStdoutLogger = Logger { loggerWriteMessage = T.putStrLn . showLogMessage Nothing - , loggerWaitForWrite = return () - , loggerFinalizers = [] + , loggerWaitForWrite = hFlush stdout + , loggerShutdown = return () } --- | Create logger that prints messages to standard output. +{-# 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 Control.Exception +import Prelude +import qualified Data.Text.IO as T + +import Log.Data +import Log.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 + (act logger) `finally` (do { waitForLogger logger; shutdownLogger logger; }) + +{-# 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/Class.hs b/src/Log/Class.hs --- a/src/Log/Class.hs +++ b/src/Log/Class.hs @@ -1,3 +1,4 @@ +-- | The 'MonadLog' type class of monads with logging capabilities. {-# OPTIONS_GHC -fno-warn-deprecated-flags #-} {-# LANGUAGE OverlappingInstances #-} module Log.Class ( @@ -23,10 +24,20 @@ import Log.Data --- | Represents the family of monads with logging capabilities. +-- | 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 - logMessage :: UTCTime -> LogLevel -> T.Text -> Value -> m () + -- | 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. @@ -45,26 +56,37 @@ ---------------------------------------- +-- | Log a message and its associated data using current time as the +-- event time and the 'LogAttention' log level. logAttention :: MonadLog m => T.Text -> Value -> m () logAttention = logNow LogAttention +-- | Log a message and its associated data using current time as the +-- event time and the 'LogInfo' log level. logInfo :: MonadLog m => T.Text -> Value -> m () logInfo = logNow LogInfo +-- | Log a message and its associated data using current time as the +-- event time and the 'LogTrace' log level. logTrace :: MonadLog m => T.Text -> Value -> m () logTrace = logNow LogTrace +-- | 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 diff --git a/src/Log/Data.hs b/src/Log/Data.hs --- a/src/Log/Data.hs +++ b/src/Log/Data.hs @@ -1,3 +1,4 @@ +-- | Basic data types used throughout the package. module Log.Data ( LogLevel(..) , showLogLevel @@ -24,7 +25,8 @@ readLogLevel "attention" = LogAttention readLogLevel "info" = LogInfo readLogLevel "trace" = LogTrace -readLogLevel level = error $ "readLogLevel: unknown level: " ++ T.unpack level +readLogLevel level = error $ "readLogLevel: unknown level: " + ++ T.unpack level showLogLevel :: LogLevel -> T.Text showLogLevel LogAttention = "attention" @@ -40,7 +42,7 @@ lmComponent :: !T.Text -- | Aplication log domain. , lmDomain :: ![T.Text] - -- | Time of log. + -- | Time of the logged event. , lmTime :: !UTCTime -- | Log level. , lmLevel :: !LogLevel @@ -50,7 +52,10 @@ , lmData :: !Value } deriving (Eq, Show) -showLogMessage :: Maybe UTCTime -> LogMessage -> T.Text +-- | 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 diff --git a/src/Log/Internal/Logger.hs b/src/Log/Internal/Logger.hs --- a/src/Log/Internal/Logger.hs +++ b/src/Log/Internal/Logger.hs @@ -1,40 +1,61 @@ +-- | The 'Logger' type - implementation details. +{-# OPTIONS_HADDOCK hide #-} module Log.Internal.Logger ( Logger(..) , execLogger , waitForLogger + , shutdownLogger ) where -import Control.Concurrent.STM -import Data.IORef -import Data.Monoid +import Data.Semigroup import Prelude import Log.Data --- | Data type representing logger. +-- | 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 ()) -, loggerWaitForWrite :: !(STM ()) -, loggerFinalizers :: ![IORef ()] + 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 logs stored in an internal queue are serialized. +-- | Wait until all 'LogMessage's stored in the internal queue are +-- serialized. waitForLogger :: Logger -> IO () -waitForLogger Logger{..} = atomically loggerWaitForWrite +waitForLogger Logger{..} = loggerWaitForWrite --- | Composition of 'Logger' objects. -instance Monoid Logger where - mempty = Logger (const $ return ()) (return ()) [] - l1 `mappend` l2 = Logger { +-- | 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 + +instance Semigroup Logger where + l1 <> l2 = Logger { loggerWriteMessage = \msg -> do loggerWriteMessage l1 msg loggerWriteMessage l2 msg , loggerWaitForWrite = do loggerWaitForWrite l1 loggerWaitForWrite l2 - , loggerFinalizers = loggerFinalizers l1 ++ loggerFinalizers 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 --- a/src/Log/Logger.hs +++ b/src/Log/Logger.hs @@ -1,9 +1,11 @@ +-- | The 'Logger' type of logging back-ends. module Log.Logger ( Logger , mkLogger , mkBulkLogger , execLogger , waitForLogger + , shutdownLogger ) where import Control.Applicative @@ -11,8 +13,7 @@ import Control.Concurrent.STM import Control.Exception import Control.Monad -import Data.IORef -import Data.Monoid +import Data.Semigroup import Prelude import qualified Data.Text as T import qualified Data.Text.IO as T @@ -20,19 +21,65 @@ import Log.Data import Log.Internal.Logger --- | Make 'Logger' that consumes one queued message at a time. +-- | Start a logger thread that consumes one queued message at a time. mkLogger :: T.Text -> (LogMessage -> IO ()) -> IO Logger -mkLogger = mkLoggerImpl - newTQueueIO isEmptyTQueue readTQueue writeTQueue $ return () +mkLogger name exec = mkLoggerImpl + newTQueueIO isEmptyTQueue readTQueue writeTQueue (return ()) + name exec (return ()) --- | Make 'Logger' that consumes all queued messages once per second. -mkBulkLogger :: T.Text -> ([LogMessage] -> IO ()) -> IO Logger +-- | 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 'withElasticSearchLogger' or '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 <- elasticSearchLogger +-- a <- async (withElasticSearchLogger $ \logger -> +-- runLogT "main" logger $ 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 <- elasticSearchLogger +-- a <- async (withElasticSearchLogger $ \logger -> +-- runLogT "main" logger $ logTrace_ "foo") +-- 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 + newSQueueIO isEmptySQueue readSQueue writeSQueue (threadDelay 1000000) ---------------------------------------- --- | Simple STM based queue. +-- | A simple STM based queue. newtype SQueue a = SQueue (TVar [a]) -- | Create an instance of 'SQueue'. @@ -64,29 +111,54 @@ -> IO () -> T.Text -> (msgs -> IO ()) + -> IO () -> IO Logger -mkLoggerImpl newQueue isQueueEmpty readQueue writeQueue afterExecDo name exec = do - (queue, inProgress) <- (,) <$> newQueue <*> newTVarIO False - finalizer <- newIORef () - mask $ \release -> do - tid <- forkIO . (`finally` printLoggerTerminated) . release . forever $ do +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 - afterExecDo - let waitForWrite = do - isEmpty <- isQueueEmpty queue - isInProgress <- readTVar inProgress - when (not isEmpty || isInProgress) retry - void . mkWeakIORef finalizer $ do - atomically waitForWrite - killThread tid - return Logger { - loggerWriteMessage = atomically . writeQueue queue - , loggerWaitForWrite = waitForWrite - , loggerFinalizers = [finalizer] - } - where + + 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 --- a/src/Log/Monad.hs +++ b/src/Log/Monad.hs @@ -1,3 +1,4 @@ +-- | The 'LogT' monad transformer for adding logging capabilities to any monad. {-# LANGUAGE CPP #-} module Log.Monad ( Logger @@ -25,28 +26,41 @@ import Log.Data import Log.Logger --- | 'LogT' environment. +-- | The state that every 'LogT' carries around. data LoggerEnv = LoggerEnv { - leLogger :: !Logger -, leComponent :: !Text -, leDomain :: ![Text] -, leData :: ![Pair] + 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) + deriving (Alternative, Applicative, Functor, Monad, MonadBase b, MonadCatch + ,MonadIO, MonadMask, MonadPlus, MonadThrow, MonadTrans) -runLogT :: Text -> Logger -> LogT m a -> m a +-- | 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 @@ -94,6 +108,8 @@ | otherwise -> object $ ("_data", data_) : leData } - localData data_ = LogT . local (\e -> e { leData = data_ ++ leData e }) . unLogT + localData data_ = + LogT . local (\e -> e { leData = data_ ++ leData e }) . unLogT - localDomain domain = LogT . local (\e -> e { leDomain = leDomain e ++ [domain] }) . unLogT + localDomain domain = + LogT . local (\e -> e { leDomain = leDomain e ++ [domain] }) . unLogT diff --git a/test/IntegrationTest.hs b/test/IntegrationTest.hs new file mode 100644 --- /dev/null +++ b/test/IntegrationTest.hs @@ -0,0 +1,54 @@ +module Main where + +import Log +import Log.Backend.StandardOutput +import Log.Backend.StandardOutput.Bulk +import Log.Backend.ElasticSearch +import Test.ElasticSearch + +import Data.List +import System.Environment +import System.Process +import System.Random +import Test.Tasty +import Test.Tasty.HUnit + +main :: IO () +main = do + args <- getArgs + case args of + ["test-simple-stdout"] -> do + withSimpleStdOutLogger $ \logger -> + runLogT "log-test-integration" logger $ logTrace_ "kaboozle" + ["test-bulk-stdout"] -> do + withBulkStdOutLogger $ \logger -> + runLogT "log-test-integration" logger $ logTrace_ "kaboozle" + ["test-elasticsearch"] -> do + let config = defaultElasticSearchConfig + withElasticSearchLogger config randomIO $ \logger -> + runLogT "log-test-integration" logger $ logTrace_ "kaboozle" + _ -> runTests + +runTests :: IO () +runTests = do + path <- getExecutablePath + let config = defaultElasticSearchConfig + testConfig <- defaultElasticSearchTestConfig config + defaultMain $ testGroup "Integration Tests" [ + testCase "Log messages are not lost (simple stdout back-end)" $ do + out <- readProcess path ["test-simple-stdout"] "" + assertBool "Output doesn't contain 'kaboozle'" + $ "kaboozle" `isInfixOf` out, + + testCase "Log messages are not lost (bulk stdout back-end)" $ do + out <- readProcess path ["test-bulk-stdout"] "" + assertBool "Output doesn't contain 'kaboozle'" + $ "kaboozle" `isInfixOf` out, + + testCase "Log messages are not lost (Elasticsearch back-end)" $ do + callProcess path ["test-elasticsearch"] + refreshTestIndex testConfig + hits <- getNumHits testConfig "kaboozle" + assertBool "Elasticsearch returned zero hits for 'kaboozle'" + $ (hits > 0) + ] diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,41 @@ +module Main where + +import Log +import Log.Backend.ElasticSearch +import Test.ElasticSearch + +import System.Random +import Test.Tasty +import Test.Tasty.HUnit + +tests :: ElasticSearchTestConfig -> Logger -> TestTree +tests config logger = testGroup "Unit Tests" [ + testCase "After logging 'foo', 'foo' is there" $ do + runLogT "log-test" logger $ do + logTrace_ "foo" + waitForLogger logger + hits <- getNumHits config "foo" + assertBool "expected at least one hit for 'foo'" (hits > 0), + testCase "After logging 'foo' thrice, searching 'foo' gives >=3 hits" $ do + runLogT "log-test" logger $ do + logTrace_ "foo" + logTrace_ "foo" + logTrace_ "foo" + waitForLogger logger + hits <- getNumHits config "foo" + assertBool "expected at least 3 hits for 'foo'" (hits >= 3), + testCase "After logging 'foo' and 'bar', searching 'baz' gives 0 hits" $ do + runLogT "log-test" logger $ do + logTrace_ "foo" + logTrace_ "bar" + waitForLogger logger + hits <- getNumHits config "baz" + assertBool "expected zero hits for 'baz'" (hits == 0) + ] + +main :: IO () +main = do + let config = defaultElasticSearchConfig + testConfig <- defaultElasticSearchTestConfig config + withElasticSearchLogger config randomIO $ \logger -> + defaultMain $ tests testConfig logger diff --git a/test/Test/ElasticSearch.hs b/test/Test/ElasticSearch.hs new file mode 100644 --- /dev/null +++ b/test/Test/ElasticSearch.hs @@ -0,0 +1,58 @@ +module Test.ElasticSearch + (ElasticSearchTestConfig(..) + ,defaultElasticSearchConfig + ,defaultElasticSearchTestConfig + ,getNumHits + ,refreshTestIndex) +where + +import Log.Backend.ElasticSearch + +import Control.Monad +import Data.Aeson +import Data.Text (Text) +import Data.Time +import Database.Bloodhound +import Network.HTTP.Client +import Test.Tasty.HUnit + +import qualified Data.Text as T + +data ElasticSearchTestConfig = ElasticSearchTestConfig { + testServer :: Server, + testIndex :: IndexName + } + +defaultElasticSearchTestConfig :: ElasticSearchConfig + -> IO ElasticSearchTestConfig +defaultElasticSearchTestConfig ElasticSearchConfig{..} = do + now <- getCurrentTime + let testServer = Server esServer + testIndex = IndexName $ T.concat + [ esIndex + , "-" + , T.pack $ formatTime defaultTimeLocale "%F" now + ] + return ElasticSearchTestConfig{..} + + +getNumHits :: ElasticSearchTestConfig -> Text -> IO Int +getNumHits ElasticSearchTestConfig{..} query = do + let tquery = TermQuery (Term "message" query) Nothing + search = mkSearch (Just tquery) Nothing + reply <- withBH' $ searchByIndex testIndex search + let result = eitherDecode (responseBody reply) + :: Either String (SearchResult Value) + case result of + Left err -> assertString err >> return (-1) + Right res -> return . hitsTotal . searchHits $ res + + where + withBH' = withBH defaultManagerSettings testServer + +refreshTestIndex :: ElasticSearchTestConfig -> IO () +refreshTestIndex ElasticSearchTestConfig{..} = + void . withBH' $ refreshIndex testIndex + + where + withBH' = withBH defaultManagerSettings testServer