log (empty) → 0.1.0
raw patch · 11 files changed
+525/−0 lines, 11 filesdep +aesondep +aeson-prettydep +basesetup-changed
Dependencies added: aeson, aeson-pretty, base, bytestring, deepseq, exceptions, hpqtypes, monad-control, monad-time, mtl, old-locale, split, stm, text, time, transformers-base, unordered-containers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- log.cabal +58/−0
- src/Log.hs +15/−0
- src/Log/Backend/PostgreSQL.hs +51/−0
- src/Log/Backend/StandardOutput.hs +41/−0
- src/Log/Class.hs +53/−0
- src/Log/Class/Instances.hs +22/−0
- src/Log/Data.hs +37/−0
- src/Log/Logger.hs +121/−0
- src/Log/Monad.hs +95/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Scrive++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Andrzej Rybczak nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ log.cabal view
@@ -0,0 +1,58 @@+name: log+version: 0.1.0+synopsis: Structured logging solution with multiple backends++description: A library that provides a way to record structured log messages with multiple backends.+ .+ Supported backends:+ .+ * standard output+ .+ * PostgreSQL++homepage: https://github.com/scrive/log+license: BSD3+license-file: LICENSE+author: Scrive+maintainer: andrzej@scrive.com+category: System+build-type: Simple+cabal-version: >=1.10++Source-repository head+ Type: git+ Location: https://github.com/scrive/log++library+ exposed-modules: Log,+ Log.Logger,+ Log.Class,+ Log.Data,+ Log.Monad,+ Log.Class.Instances,+ Log.Backend.PostgreSQL,+ Log.Backend.StandardOutput++ build-depends: base <5,+ aeson >=0.6.2.0,+ stm >=2.4,+ text,+ monad-time,+ time,+ deepseq,+ transformers-base,+ exceptions >=0.6,+ mtl,+ monad-control >=0.3,+ unordered-containers,+ bytestring,+ split,+ hpqtypes >=1.4,+ aeson-pretty >=0.7,+ old-locale++ hs-source-dirs: src++ ghc-options: -O2 -Wall -funbox-strict-fields++ default-language: Haskell2010
+ src/Log.hs view
@@ -0,0 +1,15 @@+module Log (+ module Log.Class+ , module Log.Data+ , module Log.Logger+ , module Log.Monad+ , object+ , (.=)+ ) where++import Data.Aeson++import Log.Class+import Log.Data+import Log.Logger+import Log.Monad
+ src/Log/Backend/PostgreSQL.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}+module Log.Backend.PostgreSQL (pgLogger) where++import Control.Concurrent+import Control.Exception+import Data.Aeson+import Data.ByteString (ByteString)+import Data.ByteString.Lazy (toStrict)+import Data.Monoid+import Data.Monoid.Utils+import Data.List.Split+import Database.PostgreSQL.PQTypes++import Log.Data+import Log.Logger++-- | Create logger that inserts log messages into PostgreSQL database.+pgLogger :: ConnectionSource -> IO Logger+pgLogger cs = mkBulkLogger "PostgreSQL" $ mapM_ serialize . chunksOf 1000+ where+ serialize :: [LogMessage] -> IO ()+ serialize msgs = runDBT cs ts (runSQL_ $ "INSERT INTO logs (insertion_time, insertion_order, time, level, component, message, data) VALUES" <+> mintercalate ", " (map sqlifyMessage $ zip [1..] msgs)) `catches` [+ Handler $ \(e::AsyncException) -> throwIO e+ , Handler $ \(e::SomeException) -> do+ putStrLn $ "PostgreSQL: couldn't serialize logs: " ++ show e ++ ", retrying in 10 seconds"+ threadDelay $ 10 * 1000000+ serialize msgs+ ]++ sqlifyMessage :: (Int, LogMessage) -> SQL+ sqlifyMessage (n, LogMessage{..}) = mconcat [+ "("+ , "now()"+ , "," <?> n+ , "," <?> lmTime+ , "," <?> sqlifyLevel lmLevel+ , "," <?> lmComponent+ , "," <?> lmMessage+ , "," <?> toStrict (encode lmData) <> "::jsonb"+ , ")"+ ]++ sqlifyLevel :: LogLevel -> ByteString+ sqlifyLevel LogAttention = "attention"+ sqlifyLevel LogInfo = "info"+ sqlifyLevel LogTrace = "trace"++ ts :: TransactionSettings+ ts = def {+ tsAutoTransaction = False+ }
+ src/Log/Backend/StandardOutput.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+module Log.Backend.StandardOutput (stdoutLogger) where++import Data.Aeson.Encode.Pretty+import Data.Aeson.Types+import Data.ByteString.Lazy (toStrict)+import Data.Time+import System.Locale+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T++import Log.Data+import Log.Logger++-- | Create logger that prints messages to standard output.+stdoutLogger :: IO Logger+stdoutLogger = mkLogger "stdout" printLogMessage++printLogMessage :: LogMessage -> IO ()+printLogMessage LogMessage{..} = T.putStrLn . T.concat $ [+ T.pack $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" lmTime+ , " "+ , textifyLevel lmLevel+ , " "+ , lmComponent+ , ": "+ , lmMessage+ ] ++ if lmData == emptyObject+ then []+ else [" ", textifyData lmData]+ where+ textifyData :: Value -> T.Text+ textifyData = T.decodeUtf8 . toStrict . encodePretty' defConfig {+ confIndent = 2+ }++ textifyLevel :: LogLevel -> T.Text+ textifyLevel LogAttention = "ATTENTION"+ textifyLevel LogInfo = "INFO"+ textifyLevel LogTrace = "TRACE"
+ src/Log/Class.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverlappingInstances #-}+module Log.Class (+ UTCTime+ , MonadTime(..)+ , MonadLog(..)+ , logAttention+ , logInfo+ , logTrace+ , logAttention_+ , logInfo_+ , logTrace_+ ) where++import Control.Monad.Time+import Control.Monad.Time.Instances ()+import Data.Aeson+import Data.Aeson.Types+import Data.Time+import qualified Data.Text as T++import Log.Data++-- | Represents the family of monads with logging capabilities.+class MonadTime m => MonadLog m where+ logMessage :: UTCTime -> LogLevel -> T.Text -> Value -> m ()+ localData :: [Pair] -> m a -> m a++----------------------------------------++logAttention :: MonadLog m => String -> Value -> m ()+logAttention = logNow LogAttention . T.pack++logInfo :: MonadLog m => String -> Value -> m ()+logInfo = logNow LogInfo . T.pack++logTrace :: MonadLog m => String -> Value -> m ()+logTrace = logNow LogTrace . T.pack++logAttention_ :: MonadLog m => String -> m ()+logAttention_ = (`logAttention` emptyObject)++logInfo_ :: MonadLog m => String -> m ()+logInfo_ = (`logInfo` emptyObject)++logTrace_ :: MonadLog m => String -> m ()+logTrace_ = (`logTrace` emptyObject)++----------------------------------------++logNow :: MonadLog m => LogLevel -> T.Text -> Value -> m ()+logNow level message data_ = do+ time <- currentTime+ logMessage time level message data_
+ src/Log/Class/Instances.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverlappingInstances+ , RankNTypes, UndecidableInstances #-}+module Log.Class.Instances () where++import Control.Monad.Trans+import Control.Monad.Trans.Control++import Log.Class++-- | 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)++controlT :: (MonadTransControl t, Monad (t m), Monad m)+ => (Run t -> m (StT t a)) -> t m a+controlT f = liftWith f >>= restoreT . return
+ src/Log/Data.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE RecordWildCards #-}+module Log.Data (+ LogLevel(..)+ , LogMessage(..)+ ) where++import Control.DeepSeq+import Data.Aeson+import Data.Text (Text)+import Data.Time++-- | Available log levels.+data LogLevel = LogAttention | LogInfo | LogTrace+ deriving (Bounded, Eq, Ord, Show)++instance NFData LogLevel++-- | Represents message to be logged.+data LogMessage = LogMessage {+ -- | Component of an application.+ lmComponent :: !Text+ -- | Time of log.+, lmTime :: !UTCTime+ -- | Log level.+, lmLevel :: !LogLevel+ -- | Message to be logged.+, lmMessage :: !Text+ -- | Additional data associated with the message.+, lmData :: !Value+} deriving (Eq, Show)++instance NFData LogMessage where+ rnf LogMessage{..} = rnf lmComponent+ `seq` rnf lmTime+ `seq` rnf lmLevel+ `seq` rnf lmMessage+ `seq` rnf lmData
+ src/Log/Logger.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+module Log.Logger (+ Logger+ , mkLogger+ , mkBulkLogger+ , execLogger+ , waitForLogger+ ) where++import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import Data.IORef+import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.IO as T++import Log.Data++-- | 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 :)++----------------------------------------++-- | Opaque data type representing logger.+data Logger = Logger {+ loggerWriteMessage :: !(LogMessage -> IO ())+, loggerWaitForWrite :: !(STM ())+, loggerFinalizers :: ![IORef ()]+}++-- | Execute logger to serialize a 'LogMessage'.+execLogger :: Logger -> LogMessage -> IO ()+execLogger Logger{..} = loggerWriteMessage++-- | Wait until logs stored in an internal queue are serialized.+waitForLogger :: Logger -> IO ()+waitForLogger Logger{..} = atomically loggerWaitForWrite++-- | Composition of 'Logger' objects.+instance Monoid Logger where+ mempty = Logger (const $ return ()) (return ()) []+ l1 `mappend` l2 = Logger {+ loggerWriteMessage = \msg -> do+ loggerWriteMessage l1 msg+ loggerWriteMessage l2 msg+ , loggerWaitForWrite = do+ loggerWaitForWrite l1+ loggerWaitForWrite l2+ , loggerFinalizers = loggerFinalizers l1 ++ loggerFinalizers l2+ }++----------------------------------------++-- | Make 'Logger' that consumes one queued message at a time.+mkLogger :: T.Text -> (LogMessage -> IO ()) -> IO Logger+mkLogger = mkLoggerImpl+ newTQueueIO isEmptyTQueue readTQueue writeTQueue $ return ()++-- | Make 'Logger' that consumes all queued messages once per second.+mkBulkLogger :: T.Text -> ([LogMessage] -> IO ()) -> IO Logger+mkBulkLogger = mkLoggerImpl+ newSQueueIO isEmptySQueue readSQueue writeSQueue $ threadDelay 1000000++----------------------------------------++mkLoggerImpl :: IO queue+ -> (queue -> STM Bool)+ -> (queue -> STM msgs)+ -> (queue -> LogMessage -> STM ())+ -> IO ()+ -> T.Text+ -> (msgs -> 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+ 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+ printLoggerTerminated = T.putStrLn $ name <> ": logger thread terminated"
+ src/Log/Monad.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances+ , GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings+ , RecordWildCards, TypeFamilies, UndecidableInstances #-}+module Log.Monad (+ Logger+ , LoggerEnv(..)+ , InnerLogT+ , LogT(..)+ , runLogT+ , mapLogT+ ) where++import Control.Applicative+import Control.DeepSeq+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Data.Aeson+import Data.Aeson.Types+import Data.Text (Text)+import qualified Control.Exception as E+import qualified Data.HashMap.Strict as H++import Log.Class+import Log.Data+import Log.Logger++-- | 'LogT' environment.+data LoggerEnv = LoggerEnv {+ leLogger :: !Logger+, leComponent :: !Text+, leData :: ![Pair]+}++type InnerLogT = ReaderT LoggerEnv++-- | Monad transformer that adds logging capabilities to the underlying monad.+newtype LogT m a = LogT { unLogT :: InnerLogT m a }+ deriving (Applicative, Functor, Monad, MonadBase b, MonadCatch, MonadIO, MonadMask, MonadThrow, MonadTrans)++runLogT :: Text -> Logger -> LogT m a -> m a+runLogT component logger m = runReaderT (unLogT m) LoggerEnv {+ leLogger = logger+, leComponent = component+, leData = []+}++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+ , 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