log 0.3.1 → 0.4
raw patch · 7 files changed
+80/−74 lines, 7 filesdep ~monad-time
Dependency ranges changed: monad-time
Files
- log.cabal +3/−3
- src/Log/Backend/StandardOutput.hs +1/−1
- src/Log/Class.hs +19/−2
- src/Log/Class/Instances.hs +0/−23
- src/Log/Data.hs +5/−3
- src/Log/Internal/Logger.hs +39/−0
- src/Log/Logger.hs +13/−42
log.cabal view
@@ -1,5 +1,5 @@ name: log-version: 0.3.1+version: 0.4 synopsis: Structured logging solution with multiple backends description: A library that provides a way to record structured log messages with multiple backends.@@ -28,8 +28,8 @@ Log.Backend.PostgreSQL, Log.Backend.StandardOutput, Log.Class,- Log.Class.Instances, Log.Data,+ Log.Internal.Logger, Log.Logger, Log.Monad @@ -43,7 +43,7 @@ hpqtypes >=1.4, lifted-base, monad-control >=0.3,- monad-time,+ monad-time >= 0.2, mtl, old-locale, split,
src/Log/Backend/StandardOutput.hs view
@@ -8,4 +8,4 @@ -- | Create logger that prints messages to standard output. stdoutLogger :: IO Logger-stdoutLogger = mkLogger "stdout" $ T.putStrLn . showLogMessage+stdoutLogger = mkLogger "stdout" $ T.putStrLn . showLogMessage Nothing
src/Log/Class.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE OverlappingInstances #-}+{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverlappingInstances+ , RankNTypes, UndecidableInstances #-} module Log.Class ( UTCTime , MonadTime(..)@@ -12,7 +14,8 @@ ) where import Control.Monad.Time-import Control.Monad.Time.Instances ()+import Control.Monad.Trans+import Control.Monad.Trans.Control import Data.Aeson import Data.Aeson.Types import Data.Time@@ -25,6 +28,20 @@ logMessage :: UTCTime -> LogLevel -> T.Text -> Value -> m () localData :: [Pair] -> m a -> m a 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 ----------------------------------------
− src/Log/Class/Instances.hs
@@ -1,23 +0,0 @@-{-# 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)- 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
src/Log/Data.hs view
@@ -53,10 +53,12 @@ , lmData :: !Value } deriving (Eq, Show) -showLogMessage :: LogMessage -> T.Text-showLogMessage LogMessage{..} = T.concat $ [+showLogMessage :: Maybe UTCTime -> LogMessage -> 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
+ src/Log/Internal/Logger.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE RecordWildCards #-}+module Log.Internal.Logger (+ Logger(..)+ , execLogger+ , waitForLogger+ ) where++import Control.Concurrent.STM+import Data.IORef++import Log.Data++-- | 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+ }
src/Log/Logger.hs view
@@ -18,7 +18,20 @@ import qualified Data.Text.IO as T import Log.Data+import Log.Internal.Logger +-- | 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++----------------------------------------+ -- | Simple STM based queue. newtype SQueue a = SQueue (TVar [a]) @@ -41,48 +54,6 @@ -- | 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 ----------------------------------------