diff --git a/log.cabal b/log.cabal --- a/log.cabal +++ b/log.cabal @@ -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 , Jonathan Jouty , - Mikhail Glushenkov + Mikhail Glushenkov , + Oleg Grenrus 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 diff --git a/src/Log.hs b/src/Log.hs --- a/src/Log.hs +++ b/src/Log.hs @@ -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 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,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 --- --- 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 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,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 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,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 diff --git a/src/Log/Backend/StandardOutput/Bulk.hs b/src/Log/Backend/StandardOutput/Bulk.hs --- a/src/Log/Backend/StandardOutput/Bulk.hs +++ b/src/Log/Backend/StandardOutput/Bulk.hs @@ -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 diff --git a/src/Log/Backend/Text.hs b/src/Log/Backend/Text.hs --- a/src/Log/Backend/Text.hs +++ b/src/Log/Backend/Text.hs @@ -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 diff --git a/src/Log/Class.hs b/src/Log/Class.hs --- a/src/Log/Class.hs +++ b/src/Log/Class.hs @@ -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 diff --git a/src/Log/Data.hs b/src/Log/Data.hs --- a/src/Log/Data.hs +++ b/src/Log/Data.hs @@ -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 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,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 diff --git a/src/Log/Logger.hs b/src/Log/Logger.hs --- a/src/Log/Logger.hs +++ b/src/Log/Logger.hs @@ -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: --- --- --- 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 diff --git a/src/Log/Monad.hs b/src/Log/Monad.hs --- a/src/Log/Monad.hs +++ b/src/Log/Monad.hs @@ -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