log 0.6 → 0.7
raw patch · 12 files changed
+33/−1093 lines, 12 filesdep +log-basedep +log-elasticsearchdep +log-postgresdep −aeson-prettydep −base64-bytestringdep −deepseqdep ~aesondep ~bloodhounddep ~exceptions
Dependencies added: log-base, log-elasticsearch, log-postgres
Dependencies removed: aeson-pretty, base64-bytestring, deepseq, hpqtypes, lifted-base, monad-control, monad-time, mtl, old-locale, semigroups, split, stm, text-show, transformers-base, unordered-containers, vector
Dependency ranges changed: aeson, bloodhound, exceptions, time
Files
- log.cabal +7/−39
- src/Log.hs +2/−13
- src/Log/Backend/ElasticSearch.hs +2/−246
- src/Log/Backend/PostgreSQL.hs +4/−180
- src/Log/Backend/StandardOutput.hs +2/−34
- src/Log/Backend/StandardOutput/Bulk.hs +2/−29
- src/Log/Backend/Text.hs +4/−30
- src/Log/Class.hs +2/−90
- src/Log/Data.hs +2/−91
- src/Log/Internal/Logger.hs +2/−67
- src/Log/Logger.hs +2/−162
- src/Log/Monad.hs +2/−112
log.cabal view
@@ -1,5 +1,5 @@ name: log-version: 0.6+version: 0.7 synopsis: Structured logging solution with multiple backends description: A library that provides a way to record structured@@ -19,7 +19,8 @@ author: Scrive AB maintainer: Andrzej Rybczak <andrzej@rybczak.net>, Jonathan Jouty <jonathan@scrive.com>,- Mikhail Glushenkov <mikhail@scrive.com>+ Mikhail Glushenkov <mikhail@scrive.com>,+ Oleg Grenrus <oleg.grenrus@iki.fi> copyright: Scrive AB category: System build-type: Simple@@ -44,49 +45,16 @@ Log.Monad build-depends: base <5,- aeson >=0.6.2.0,- aeson-pretty >=0.8.2,- base64-bytestring,- bloodhound >= 0.11.1,- bytestring,- deepseq,- exceptions >=0.6,- hpqtypes >=1.5,- http-client,- lifted-base,- monad-control >=0.3,- monad-time >= 0.2,- mtl,- old-locale,- semigroups,- split,- stm >=2.4,- text,- text-show >= 2,- time >= 1.5,- transformers,- transformers-base,- unordered-containers,- vector+ log-base >= 0.7,+ log-elasticsearch >= 0.7,+ log-postgres >= 0.7 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+ default-extensions: PackageImports test-suite log-test type: exitcode-stdio-1.0
src/Log.hs view
@@ -1,16 +1,5 @@--- | Structured logging solution with multiple backends. module Log (- module Log.Class- , module Log.Data- , module Log.Logger- , module Log.Monad- , object- , (.=)+ module Log ) where -import Data.Aeson--import Log.Class-import Log.Data-import Log.Logger-import Log.Monad+import "log-base" Log
src/Log/Backend/ElasticSearch.hs view
@@ -1,249 +1,5 @@--- | Elasticsearch logging back-end. module Log.Backend.ElasticSearch (- ElasticSearchConfig(..)- , defaultElasticSearchConfig- , withElasticSearchLogger- , elasticSearchLogger-+ module Log.Backend.ElasticSearch ) where -import Control.Applicative-import Control.Arrow (second)-import Control.Concurrent-import Control.Exception-import Control.Monad-import Control.Monad.IO.Class-import Data.Aeson-import Data.Aeson.Encode.Pretty-import Data.Bits-import Data.IORef-import Data.Monoid.Utils-import Data.Semigroup-import Data.Time-import Data.Time.Clock.POSIX-import Data.Word-import Database.Bloodhound hiding (Status)-import Log-import Log.Internal.Logger-import Network.HTTP.Client-import Prelude-import TextShow-import qualified Data.ByteString as BS-import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.HashMap.Strict as H-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-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 -- ^ 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- withLogger logger act--{-# 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- now <- getCurrentTime- oldIndex <- readIORef indexRef- -- Bloodhound doesn't support letting ES autogenerate IDs, so let's generate- -- them ourselves. An ID of a log message is 12 bytes (4 bytes: random, 4- -- bytes: current time as epoch, 4 bytes: insertion order) encoded as- -- Base64. This makes eventual collisions practically impossible.- baseID <- (<>)- <$> (littleEndianRep <$> liftIO genRandomWord)- <*> pure (littleEndianRep . floor $ timeToDouble now)- retryOnException . runBH_ $ do- -- 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- , "-"- , T.pack $ formatTime defaultTimeLocale "%F" now- ]- when (oldIndex /= index) $ do- -- There is an obvious race condition in the presence of more than one- -- logger instance running, but it's irrelevant as attempting to create- -- index that already exists is harmless.- indexExists' <- indexExists index- unless indexExists' $ do- -- Bloodhound is weird and won't let us create index using default- -- settings, so pass these as the default ones.- let indexSettings = IndexSettings {- indexShards = ShardCount 4- , indexReplicas = ReplicaCount 1- }- 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)- liftIO $ writeIORef indexRef index- let jsonMsgs = V.fromList $ map (toJsonMsg now) $ zip [1..] msgs- reply <- bulk $ V.map (toBulk index baseID) jsonMsgs- -- Try to parse parts of reply to get information about log messages that- -- failed to be inserted for some reason.- let replyBody = decodeReply reply- result = do- Object response <- return replyBody- Bool hasErrors <- "errors" `H.lookup` response- Array jsonItems <- "items" `H.lookup` response- items <- F.forM jsonItems $ \v -> do- Object item <- return v- Object index_ <- "index" `H.lookup` item- return index_- guard $ V.length items == V.length jsonMsgs- return (hasErrors, items)- case result of- 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- -- old data into its own namespace to work around insertion errors.- let failed = V.findIndices (H.member "error") items- dummyMsgs <- V.forM failed $ \n -> do- dataNamespace <- liftIO genRandomWord- let modifyData oldData = object [- "__es_error" .= H.lookup "error" (items V.! n)- , "__es_modified" .= True- , ("__data_" <> showt dataNamespace) .= oldData- ]- 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))- (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?)"- 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"- threadDelay $ 10 * 1000000- retryOnException m- Right result -> return result-- timeToDouble :: UTCTime -> Double- timeToDouble = realToFrac . utcTimeToPOSIXSeconds-- runBH_ :: forall r. BH IO r -> IO r- runBH_ = withBH defaultManagerSettings server-- jsonToBSL :: Value -> BSL.ByteString- jsonToBSL = encodePretty' defConfig { confIndent = Spaces 2 }-- 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)- ])- where- Object jMsg = toJSON msg-- mkDocId :: BS.ByteString -> Word32 -> DocId- 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--data LogsMapping = LogsMapping-instance ToJSON LogsMapping where- toJSON LogsMapping = object [- "properties" .= object [- "insertion_order" .= object [- "type" .= ("integer"::T.Text)- ]- , "insertion_time" .= object [- "type" .= ("date"::T.Text)- , "format" .= ("date_time"::T.Text)- ]- , "time" .= object [- "type" .= ("date"::T.Text)- , "format" .= ("date_time"::T.Text)- ]- , "domain" .= object [- "type" .= ("string"::T.Text)- ]- , "level" .= object [- "type" .= ("string"::T.Text)- ]- , "component" .= object [- "type" .= ("string"::T.Text)- ]- , "message" .= object [- "type" .= ("string"::T.Text)- ]- ]- ]--------------------------------------------littleEndianRep :: Word32 -> BS.ByteString-littleEndianRep = fst . BS.unfoldrN 4 step- where- step n = Just (fromIntegral $ n .&. 0xff, n `shiftR` 8)--decodeReply :: Reply -> Value-decodeReply reply = case eitherDecode' $ responseBody reply of- Right body -> body- Left err -> object ["decoding_error" .= err]+import "log-elasticsearch" Log.Backend.ElasticSearch
src/Log/Backend/PostgreSQL.hs view
@@ -1,181 +1,5 @@--- | PostgreSQL logging back-end.-module Log.Backend.PostgreSQL (pgLogger, withPgLogger) where--import Control.Applicative-import Control.Concurrent-import Control.Exception.Lifted-import Control.Monad.State.Lazy-import Data.Aeson-import Data.List.Split-import Data.Monoid.Utils-import Data.Semigroup-import Data.String-import Data.Typeable-import Database.PostgreSQL.PQTypes-import Prelude-import qualified Data.ByteString.Base64 as B64-import qualified Data.Foldable as F-import qualified Data.HashMap.Strict as H-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Vector as V--import Log.Data-import Log.Logger-import Log.Internal.Logger--newtype InvalidEncodingRecoveryAttempt = Attempt Int- deriving Enum---- | 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- withLogger logger act--{-# 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)- (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"-- serialize :: InvalidEncodingRecoveryAttempt -> [LogMessage] -> IO ()- 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- Just dbe@DBException{..}- | Just qe <- getEncodingQueryError dbe -> case attempt of- Attempt 1 -> do- -- If a client uses UTF-8 encoding (TODO: in fact it should- -- always be the case as Text is encoded as UTF-8 for sql- -- 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"- 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")- }- (_, False) -> msg) msgs- Attempt 2 -> do- -- This should never happen, but let us be paranoid for- -- 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"- serialize (succ attempt) $ map (\msg ->- let newMsg = runIdentity $ mapTexts convertBase64 msg- in newMsg {- 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"- _ -> do- 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.- serialize attempt msgs- ]-- addPair :: Value -> (T.Text, Value) -> Value- addPair data_ (name, value) = case data_ of- Object obj -> Object $ H.insert name value obj- _ -> object [- "_data" .= data_- , "_log" .= value- ]-- getEncodingQueryError :: DBException -> Maybe DetailedQueryError- getEncodingQueryError DBException{..}- | Just (qe::DetailedQueryError) <- cast dbeError- , qeErrorCode qe == CharacterNotInRepertoire- || qeErrorCode qe == UntranslatableCharacter = Just qe- | otherwise = Nothing-- convertBase64 :: T.Text -> Identity T.Text- convertBase64 = return . T.decodeLatin1 . B64.encode . T.encodeUtf8-- removeNULLs :: T.Text -> State Bool T.Text- removeNULLs s = do- let newS = T.replace "\0" "\\0" s- when (T.length newS /= T.length s) $ put True- return newS-- mapTexts :: forall m. (Applicative m, Monad m)- => (T.Text -> m T.Text) -> LogMessage -> m LogMessage- mapTexts doText lm = do- component <- doText $ lmComponent lm- domain <- mapM doText $ lmDomain lm- message <- doText $ lmMessage lm- data_ <- doValue $ lmData lm- return lm {- lmComponent = component- , lmDomain = domain- , lmMessage = message- , lmData = data_- }- where- doValue :: Value -> m Value- doValue (Object obj) = Object <$> F.foldrM (\(name, value) acc -> H.insert- <$> doText name <*> doValue value <*> pure acc) H.empty (H.toList obj)- doValue (Array arr) = Array <$> V.mapM doValue arr- doValue (String s) = String <$> doText s- doValue v = return v-- sqlifyMessage :: (Int, LogMessage) -> SQL- sqlifyMessage (n, LogMessage{..}) = mconcat [- "("- , "now()"- , "," <?> n- , "," <?> lmTime- , "," <?> showLogLevel lmLevel- , "," <?> lmComponent- , "," <?> Array1 lmDomain- , "," <?> lmMessage- , "," <?> JSONB (encode lmData)- , ")"- ]+module Log.Backend.PostgreSQL (+ module Log.Backend.PostgreSQL+ ) where - ts :: TransactionSettings- ts = def {- tsAutoTransaction = False- }+import "log-postgres" Log.Backend.PostgreSQL
src/Log/Backend/StandardOutput.hs view
@@ -1,37 +1,5 @@--- | Stdout logging back-end. module Log.Backend.StandardOutput (- simpleStdoutLogger- , stdoutLogger- , withSimpleStdOutLogger+ module Log.Backend.StandardOutput ) 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+import "log-base" Log.Backend.StandardOutput
src/Log/Backend/StandardOutput/Bulk.hs view
@@ -1,32 +1,5 @@--- | Bulk stdout logging back-end, useful mainly for testing. module Log.Backend.StandardOutput.Bulk (- withBulkStdOutLogger,- bulkStdoutLogger+ module Log.Backend.StandardOutput.Bulk ) 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 ())+import "log-base" Log.Backend.StandardOutput.Bulk
src/Log/Backend/Text.hs view
@@ -1,31 +1,5 @@--- | 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+module Log.Backend.Text (+ module Log.Backend.Text+ ) where --- | 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)+import "log-base" Log.Backend.Text
src/Log/Class.hs view
@@ -1,93 +1,5 @@--- | 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_+ module Log.Class ) 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_+import "log-base" Log.Class
src/Log/Data.hs view
@@ -1,94 +1,5 @@--- | Basic data types used throughout the package. module Log.Data (- LogLevel(..)- , showLogLevel- , readLogLevel- , LogMessage(..)- , showLogMessage+ module Log.Data ) where -import Control.DeepSeq-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---- | Available log levels.-data LogLevel = LogAttention | LogInfo | LogTrace- deriving (Bounded, Eq, Ord, Show)--readLogLevel :: T.Text -> LogLevel-readLogLevel "attention" = LogAttention-readLogLevel "info" = LogInfo-readLogLevel "trace" = LogTrace-readLogLevel level = error $ "readLogLevel: unknown level: "- ++ T.unpack level--showLogLevel :: LogLevel -> T.Text-showLogLevel LogAttention = "attention"-showLogLevel LogInfo = "info"-showLogLevel LogTrace = "trace"--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" .= showLogLevel lmLevel- , "message" .= lmMessage- , "data" .= lmData- ]--instance NFData LogMessage where- rnf LogMessage{..} = rnf lmComponent- `seq` rnf lmDomain- `seq` rnf lmTime- `seq` rnf lmLevel- `seq` rnf lmMessage- `seq` rnf lmData+import "log-base" Log.Data
src/Log/Internal/Logger.hs view
@@ -1,70 +1,5 @@--- | The 'Logger' type - implementation details.-{-# OPTIONS_HADDOCK hide #-} module Log.Internal.Logger (- Logger(..)- , execLogger- , waitForLogger- , shutdownLogger- , withLogger+ module Log.Internal.Logger ) 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 = (<>)+import "log-base" Log.Internal.Logger
src/Log/Logger.hs view
@@ -1,165 +1,5 @@--- | The 'Logger' type of logging back-ends. module Log.Logger (- Logger- , mkLogger- , mkBulkLogger- , execLogger- , waitForLogger- , shutdownLogger+ module Log.Logger ) where -import Control.Applicative-import Control.Concurrent-import Control.Concurrent.STM-import Control.Exception-import Control.Monad-import Data.Semigroup-import Prelude-import qualified Data.Text as T-import qualified Data.Text.IO as T--import Log.Data-import Log.Internal.Logger---- | Start a logger thread that consumes one queued message at a time.-mkLogger :: T.Text -> (LogMessage -> IO ()) -> IO Logger-mkLogger name exec = mkLoggerImpl- newTQueueIO isEmptyTQueue readTQueue writeTQueue (return ())- name exec (return ())---- | Start an asynchronous logger thread that consumes all queued--- messages once per second. To make sure that the messages get--- written out in the presence of exceptions, use high-level wrappers--- like 'withLogger', 'Log.Backend.ElasticSearch.withElasticSearchLogger' or--- 'Log.Backend.StandardOutput.Bulk.withBulkStdOutLogger'--- instead of this function directly.------ Note: some messages can be lost when the main thread shuts down--- without making sure that all logger threads have written out all--- messages, because in that case child threads are not given a chance--- to clean up by the RTS. This is apparently a feature:--- <https://mail.haskell.org/pipermail/haskell-cafe/2014-February/112754.html>------ To work around this issue, make sure that the main thread doesn't--- exit until all its children have terminated. The 'async' package--- makes this easy.------ Problematic example:------ @--- import Control.Concurrent.Async------ main :: IO ()--- main = do--- logger \<- 'Log.Backend.ElasticSearch.elasticSearchLogger'--- a \<- 'Control.Concurrent.Async.async' ('Log.Backend.ElasticSearch.withElasticSearchLogger' $ \\logger ->--- 'Log.Monad.runLogT' "main" logger $ 'Log.Class.logTrace_' "foo")--- -- Main thread exits without waiting for the child--- -- to finish and without giving the child a chance--- -- to do proper cleanup.--- @------ Fixed example:------ @--- import Control.Concurrent.Async------ main :: IO ()--- main = do--- logger \<- 'Log.Backend.ElasticSearch.elasticSearchLogger'--- a \<- 'Control.Concurrent.Async.async' ('Log.Backend.ElasticSearch.withElasticSearchLogger' $ \\logger ->--- 'Log.Monad.runLogT' "main" logger $ 'Log.Class.logTrace_' "foo")--- 'Control.Concurrent.Async.wait' a--- -- Main thread waits for the child to finish, giving--- -- it a chance to shut down properly. This works even--- -- in the presence of exceptions in the child thread.--- @-mkBulkLogger :: T.Text -> ([LogMessage] -> IO ()) -> IO () -> IO Logger-mkBulkLogger = mkLoggerImpl- newSQueueIO isEmptySQueue readSQueue writeSQueue (threadDelay 1000000)---------------------------------------------- | A simple STM based queue.-newtype SQueue a = SQueue (TVar [a])---- | Create an instance of 'SQueue'.-newSQueueIO :: IO (SQueue a)-newSQueueIO = SQueue <$> newTVarIO []---- | Check if an 'SQueue' is empty.-isEmptySQueue :: SQueue a -> STM Bool-isEmptySQueue (SQueue queue) = null <$> readTVar queue---- | Read all the values stored in an 'SQueue'.-readSQueue :: SQueue a -> STM [a]-readSQueue (SQueue queue) = do- elems <- readTVar queue- when (null elems) retry- writeTVar queue []- return $ reverse elems---- | Write a value to an 'SQueue'.-writeSQueue :: SQueue a -> a -> STM ()-writeSQueue (SQueue queue) a = modifyTVar queue (a :)--------------------------------------------mkLoggerImpl :: IO queue- -> (queue -> STM Bool)- -> (queue -> STM msgs)- -> (queue -> LogMessage -> STM ())- -> IO ()- -> T.Text- -> (msgs -> IO ())- -> IO ()- -> IO Logger-mkLoggerImpl newQueue isQueueEmpty readQueue writeQueue afterExecDo- name exec sync = do- queue <- newQueue- inProgress <- newTVarIO False- isRunning <- newTVarIO True- tid <- forkFinally (forever $ loop queue inProgress)- (\_ -> cleanup queue inProgress)- return Logger {- loggerWriteMessage = \msg -> atomically $ do- checkIsRunning isRunning- writeQueue queue msg,- loggerWaitForWrite = do- atomically $ waitForWrite queue inProgress- sync,- loggerShutdown = do- killThread tid- atomically $ writeTVar isRunning False- }- where- checkIsRunning isRunning' = do- isRunning <- readTVar isRunning'- when (not isRunning) $- throwSTM (AssertionFailed $ "Log.Logger.mkLoggerImpl: "- ++ "attempt to write to a shut down logger")-- loop queue inProgress = do- step queue inProgress- afterExecDo-- step queue inProgress = do- msgs <- atomically $ do- writeTVar inProgress True- readQueue queue- exec msgs- atomically $ writeTVar inProgress False-- cleanup queue inProgress = do- step queue inProgress- sync- -- Don't call afterExecDo, since it's either a no-op or a- -- threadDelay.- printLoggerTerminated-- waitForWrite queue inProgress = do- isEmpty <- isQueueEmpty queue- isInProgress <- readTVar inProgress- when (not isEmpty || isInProgress) retry-- printLoggerTerminated = T.putStrLn $ name <> ": logger thread terminated"+import "log-base" Log.Logger
src/Log/Monad.hs view
@@ -1,115 +1,5 @@--- | The 'LogT' monad transformer for adding logging capabilities to any monad.-{-# LANGUAGE CPP #-} module Log.Monad (- Logger- , LoggerEnv(..)- , InnerLogT- , LogT(..)- , runLogT- , mapLogT+ module Log.Monad ) 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+import "log-base" Log.Monad