log 0.5.3 → 0.5.4

raw patch · 14 files changed

+576/−99 lines, 14 filesdep +http-typesdep +logdep +processdep ~aesondep ~basedep ~bloodhoundnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: http-types, log, process, random, semigroups, tasty, tasty-hunit

Dependency ranges changed: aeson, base, bloodhound, exceptions, time

API changes (from Hackage documentation)

Files

• log.cabal +61/−5
• src/Log.hs +1/−0
• src/Log/Backend/ElasticSearch.hs +71/−22
• src/Log/Backend/PostgreSQL.hs +47/−12
• src/Log/Backend/StandardOutput.hs +18/−3
• src/Log/Backend/StandardOutput/Bulk.hs +32/−0
• src/Log/Class.hs +24/−2
• src/Log/Data.hs +8/−3
• src/Log/Internal/Logger.hs +35/−14
• src/Log/Logger.hs +100/−28
• src/Log/Monad.hs +26/−10
• test/IntegrationTest.hs +54/−0
• test/Test.hs +41/−0
• test/Test/ElasticSearch.hs +58/−0

@@ -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 <andrzej@rybczak.net>, Jonathan Jouty <jonathan@scrive.com>+author:              Scrive AB+maintainer:          Andrzej Rybczak <andrzej@rybczak.net>,+                     Jonathan Jouty <jonathan@scrive.com>,+                     Mikhail Glushenkov <mikhail@scrive.com>+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

@@ -1,3 +1,4 @@+-- | Structured logging solution with multiple backends. module Log (     module Log.Class   , module Log.Data

@@ -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+-- <https://www.elastic.co/guide/en/elasticsearch/reference/current/glossary.html>+-- 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)           ]         ]-      ]     ]  ----------------------------------------

@@ -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.

@@ -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

@@ -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 ())

@@ -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

@@ -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

@@ -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 = (<>)

@@ -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:+-- <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 <- 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"

@@ -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

@@ -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)+    ]

@@ -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

@@ -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