diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -23,3 +23,8 @@ * Added the IO module. * Introduced null logging backend. +## 0.3.1.0 -- 2017-10-30 + +* Introduced Dynamic backend, which allows to change backend or its settings in runtime. +* Introduced FilteringM backend, which allows to change filtering settings in runtime. + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -19,6 +19,9 @@ * Possiblity to write messages to several backends in parallel. * Logging backend settings can be defined dynamically; it is not necessary to hardcode which backend you will use, you can load settings in runtime. +* It is possible to change backend or it's settings in runtime (more precisely, + you can change underlying backend if you use `DynamicBackend` as a backend, + or you can change backend's filter if you use `FilteringM` as a backend). * Sane default set of logging message severity levels and possibility to define custom severity levels. * Logging context stacks support (aka mapped diagnostic contexts, MDC). Each diff --git a/heavy-logger.cabal b/heavy-logger.cabal --- a/heavy-logger.cabal +++ b/heavy-logger.cabal @@ -1,5 +1,5 @@ name: heavy-logger -version: 0.3.0.0 +version: 0.3.1.0 synopsis: Full-weight logging based on fast-logger description: This is Haskell logging library, which prefers functionality and extendability over light weight and simplicity. It can use fast-logger as backend, and is compatible @@ -20,9 +20,11 @@ exposed-modules: System.Log.Heavy System.Log.Heavy.Level System.Log.Heavy.Types + System.Log.Heavy.Util System.Log.Heavy.LoggingT System.Log.Heavy.Format System.Log.Heavy.Backends + System.Log.Heavy.Backends.Dynamic System.Log.Heavy.Shortcuts System.Log.Heavy.TH System.Log.Heavy.IO @@ -45,7 +47,8 @@ monad-logger >= 0.3.22, hsyslog >= 5, text-format-heavy >= 0.1.5.0, - thread-local-storage >= 0.1.1 + thread-local-storage >= 0.1.1, + stm >= 2.4 hs-source-dirs: src default-language: Haskell2010 ghc-options: -fwarn-unused-imports diff --git a/src/System/Log/Heavy.hs b/src/System/Log/Heavy.hs --- a/src/System/Log/Heavy.hs +++ b/src/System/Log/Heavy.hs @@ -64,8 +64,13 @@ module System.Log.Heavy.Level, module System.Log.Heavy.LoggingT, module System.Log.Heavy.Backends, + module System.Log.Heavy.Backends.Dynamic, + -- * Logging functions + logMessage, + -- * Run actions with logging withLogging, withLoggingF, withLoggingT, - isLevelEnabledByBackend, isLevelEnabled, + -- * Check current settings + isLevelEnabledByBackend, isLevelEnabled ) where import Control.Monad.Trans @@ -75,8 +80,10 @@ import System.Log.Heavy.Types import System.Log.Heavy.Level +import System.Log.Heavy.Util import System.Log.Heavy.LoggingT import System.Log.Heavy.Backends +import System.Log.Heavy.Backends.Dynamic -- | Execute actions with logging backend. -- This is mostly an utility function to be used to construct custom @@ -119,11 +126,11 @@ -- This function assumes that if some events filtering is enabled by the -- backend, it does not depend on message text, only on source and -- severity level. -isLevelEnabledByBackend :: forall m. (Monad m, HasLogBackend AnyLogBackend m) => LogSource -> Level -> m Bool +isLevelEnabledByBackend :: forall m. (Monad m, MonadIO m, HasLogBackend AnyLogBackend m) => LogSource -> Level -> m Bool isLevelEnabledByBackend src level = do backend <- getLogBackend :: m AnyLogBackend let msg = LogMessage level src undefined TL.empty () [] - return $ wouldWriteMessage backend msg + liftIO $ wouldWriteMessage backend msg -- | Check if logging of events of specified level from specified source -- is enabled by both context and backend filter. @@ -131,11 +138,11 @@ -- This function assumes that if some events filtering is enabled by the -- backend, it does not depend on message text, only on source and -- severity level. -isLevelEnabled :: forall m. (Monad m, HasLogBackend AnyLogBackend m, HasLogContext m) => LogSource -> Level -> m Bool +isLevelEnabled :: forall m. (Monad m, MonadIO m, HasLogBackend AnyLogBackend m, HasLogContext m) => LogSource -> Level -> m Bool isLevelEnabled src level = do let msg = LogMessage level src undefined TL.empty () [] backend <- getLogBackend :: m AnyLogBackend - let isEnabledByBackend = wouldWriteMessage backend msg + isEnabledByBackend <- liftIO $ wouldWriteMessage backend msg isEnabledByContext <- checkContextFilterM msg return $ isEnabledByContext && isEnabledByBackend diff --git a/src/System/Log/Heavy/Backends.hs b/src/System/Log/Heavy/Backends.hs --- a/src/System/Log/Heavy/Backends.hs +++ b/src/System/Log/Heavy/Backends.hs @@ -18,18 +18,12 @@ defStderrSettings, defFileSettings, defaultSyslogSettings, - defaultSyslogFormat, - -- * Utilities for other backends implementation - checkLogLevel, checkLogLevel', - checkContextFilter, checkContextFilter', checkContextFilterM, - logMessage + defaultSyslogFormat ) where import Control.Monad import Control.Monad.Trans (liftIO) -import Control.Monad.Reader import Control.Concurrent -import Data.List (isPrefixOf) import qualified Data.ByteString.Unsafe as BSU import qualified Data.Text.Format.Heavy as F import qualified System.Posix.Syslog as Syslog @@ -40,6 +34,7 @@ import System.Log.Heavy.Types import System.Log.Heavy.Level import System.Log.Heavy.Format +import System.Log.Heavy.Util -- $description -- @@ -62,8 +57,12 @@ -- * Filtering - passes messages, that match specified filter, -- to underlying backend. -- +-- * FilteringM - similar to Filtering, but allows to change the filter in runtime. +-- -- * Parallel - writes messages to several backends in parallel. -- +-- * Dynamic - allows to change underlying backend or its settings in runtime. +-- -- | Default settings for fast-logger stdout output defStdoutSettings :: LogBackendSettings FastLoggerBackend @@ -177,8 +176,9 @@ instance IsLogBackend ParallelBackend where data LogBackendSettings ParallelBackend = ParallelLogSettings [LoggingSettings] - wouldWriteMessage (ParallelBackend list) msg = - or [wouldWriteMessage backend msg | backend <- list] + wouldWriteMessage (ParallelBackend list) msg = do + results <- sequence [wouldWriteMessage backend msg | backend <- list] + return $ or results makeLogger (ParallelBackend list) msg = forM_ list $ \(AnyLogBackend backend) -> makeLogger backend msg @@ -210,7 +210,8 @@ instance IsLogBackend b => IsLogBackend (Filtering b) where data LogBackendSettings (Filtering b) = Filtering (LogMessage -> Bool) (LogBackendSettings b) - wouldWriteMessage (FilteringBackend fltr _) msg = fltr msg + wouldWriteMessage (FilteringBackend fltr _) msg = do + return $ fltr msg makeLogger (FilteringBackend fltr backend) msg = do when (fltr msg) $ do @@ -230,79 +231,11 @@ instance IsLogBackend NullBackend where data LogBackendSettings NullBackend = NullLogSettings - wouldWriteMessage _ _ = False + wouldWriteMessage _ _ = return False makeLogger _ _ = return () initLogBackend _ = return NullBackend cleanupLogBackend _ = return () - --- | Check if message level matches given filter. -checkLogLevel :: LogFilter -> LogMessage -> Bool -checkLogLevel fltr m = - checkLogLevel' fltr (lmSource m) (lmLevel m) - --- | Check if message level matches given filter. -checkLogLevel' :: LogFilter -> LogSource -> Level -> Bool -checkLogLevel' fltr source level = - case lookup (bestMatch source (map fst fltr)) fltr of - Nothing -> False - Just min -> level <= min - where - bestMatch :: LogSource -> [LogSource] -> LogSource - bestMatch src list = go [] src list - - go best src [] = best - go best src (x:xs) - | src == x = x - | x `isPrefixOf` src && length x > length best = go x src xs - | otherwise = go best src xs - --- | Check if message source and level passes specified filters. --- --- The message is passed if: --- --- * No @include@ filters are defined in context stack, OR the message conforms to ANY of @include@ filters; --- --- * AND the message does not conform to any of @exclude@ filters in the stack. --- -checkContextFilter' :: [LogContextFilter] -> LogSource -> Level -> Bool -checkContextFilter' filters source level = - let includeFilters = [fltr | LogContextFilter (Just fltr) _ <- filters] - excludeFilters = [fltr | LogContextFilter _ (Just fltr) <- filters] - includeOk = null includeFilters || or [checkLogLevel' fltr source level | fltr <- includeFilters] - excludeOk = or [checkLogLevel' fltr source level | fltr <- excludeFilters] - in includeOk && not excludeOk - --- | Check if message matches filters from logging context. --- --- The message is passed if: --- --- * No @include@ filters are defined in context stack, OR the message conforms to ANY of @include@ filters; --- --- * AND the message does not conform to any of @exclude@ filters in the stack. --- -checkContextFilter :: LogContext -> LogMessage -> Bool -checkContextFilter context msg = - checkContextFilter' (map lcfFilter context) (lmSource msg) (lmLevel msg) - --- | Check if message matches filters from logging context. --- This function is similar to @checkContextFilter@, but uses current context --- from monadic state. -checkContextFilterM :: HasLogContext m => LogMessage -> m Bool -checkContextFilterM msg = do - context <- getLogContext - return $ checkContextFilter context msg - --- | Log a message. This will add current context to context specified --- in the message. --- This function checks current context filter. -logMessage :: forall m. (HasLogging m, MonadIO m) => LogMessage -> m () -logMessage msg = do - ok <- checkContextFilterM msg - when ok $ do - context <- getLogContext - logger <- getLogger - liftIO $ logger $ msg {lmContext = context ++ lmContext msg} diff --git a/src/System/Log/Heavy/Backends/Dynamic.hs b/src/System/Log/Heavy/Backends/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Heavy/Backends/Dynamic.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances #-} +-- | This module incldues logging backend combinators that allow to change +-- underlying backend or it's settings in runtime. +module System.Log.Heavy.Backends.Dynamic + ( + -- * Dynamic backend + DynamicBackend, + DynamicBackendHandle, + newDynamicBackendHandle, + updateDynamicBackendSettings, + LogBackendSettings (..), + -- * Dynamic filtering + FilteringM, filteringM, excludingM + ) where + +import Control.Monad (when) +import Control.Concurrent +import Control.Concurrent.STM + +import System.Log.Heavy.Types +import System.Log.Heavy.Util + +-- | Abstract handle, that is used to control @DynamicBackend@. +data DynamicBackendHandle = DynamicBackendHandle { + dbhBroadcast :: TChan LoggingSettings -- ^ Broadcast TChan. It is write-only. + , dbhDefault :: LoggingSettings -- ^ Initial logging settings. Used only before first update in TChan. + -- We cannot put this into TChan at beginning, because after dupTChan + -- newly created TChan's will be empty anyway. + } +-- I put these data into special Handle type, to hide the implementation detail +-- that it uses TChan inside. This detail can be changed in later versions. + +-- | Create an instance of @DynamicBackendHandle@. +newDynamicBackendHandle :: LoggingSettings -- ^ Initial logging settings. This can be changed later with @updateDynamicBackendSettings@. + -> IO DynamicBackendHandle +newDynamicBackendHandle settings = do + broadcast <- newBroadcastTChanIO + return $ DynamicBackendHandle broadcast settings + +-- | Update settings of @DynamicBackend@, which was created by provided handle. +updateDynamicBackendSettings :: DynamicBackendHandle -- ^ Handle of @DynamicBackend@. + -> LoggingSettings -- ^ New logging settings. + -> IO () +updateDynamicBackendSettings handle settings = do + atomically $ writeTChan (dbhBroadcast handle) settings + +-- | Dynamic logging backend allows to change logging backend or it's settings +-- in runtime. When it sees new backend settings, it deinitializes old backend +-- and initializes new one. +-- +-- How to use it: +-- +-- * Before creating @DynamicSettings@, you have to select some initial +-- @LoggingSettings@ and create @DynamicBackendHandle@ with it. +-- * When you decide that you want to use new backend settings, call +-- @updateDynamicBackendSettings@ on existing @DynamicBackendHandle@. +-- @DynamicBackend@ will use new settings for the next logging function call. +-- * It is responsibility of caller code to do not change backends too frequently; +-- for example, if you are checking your config file for updates of logging +-- settings each 10s, you have to check that settings actually changed since +-- last time. +-- +-- It is possible to create one instance of @DynamicBackendHandle@ and pass it +-- to multiple threads. +-- +data DynamicBackend = DynamicBackend { + dbCurrentBackend :: MVar AnyLogBackend -- ^ Currently used logging backend + , dbNewSettings :: TChan LoggingSettings -- ^ TChan with updates of settings. This is read only. + } + +-- Implementation is based on idea that Backend instances theirself are thread-safe; +-- i.e. it is safe to create several instances of any IsLogBackend data type in several threads +-- and they will coexist without problems (they do not use any shared state). +-- So, we can have one TChan, in which we can push updated settings when we want; +-- Each instance of DynamicBackend will have its own instance of underlying backend. +instance IsLogBackend DynamicBackend where + data LogBackendSettings DynamicBackend = DynamicSettings DynamicBackendHandle + + initLogBackend (DynamicSettings (DynamicBackendHandle broadcast (LoggingSettings dfltSettings))) = do + -- Duplicate broadcast TChan - create "own copy". + mySettingsChan <- atomically $ dupTChan broadcast + -- Initialize default backend + backend <- initLogBackend dfltSettings + backendVar <- newMVar (AnyLogBackend backend) + return $ DynamicBackend backendVar mySettingsChan + + cleanupLogBackend (DynamicBackend backendVar _) = do + -- Cleanup currently used backend + backend <- takeMVar backendVar + cleanupLogBackend backend + + wouldWriteMessage (DynamicBackend backendVar _) msg = do + -- Delegate the call to currently used backend. + backend <- readMVar backendVar + wouldWriteMessage backend msg + + makeLogger (DynamicBackend backendVar settingsChan) msg = do + -- See if there is an update of settings queued. + mbNewSettings <- atomically $ tryReadTChan settingsChan + -- Note: tryReadTChan will remove element from channel, if there is any. + -- But, it will affect only "our own copy" of TChan. If there are other + -- instances of DynamicBackend living in other threads with the same + -- Handle, they will still see settings update in their own copies of + -- TChan. + case mbNewSettings of + Nothing -> do + -- No updates. Use current backend. + backend <- readMVar backendVar + makeLogger backend msg + Just (LoggingSettings newSettings) -> do + -- New settings came. We have to switch backends. + oldBackend <- takeMVar backendVar + -- Cleanup old backend + cleanupLogBackend oldBackend + -- Initialize new backend + newBackend <- initLogBackend newSettings + putMVar backendVar (AnyLogBackend newBackend) + -- Delegate call to new backend + makeLogger newBackend msg + +-- | Filtering backend with mutable filter. +data FilteringM b = FilteringBackendM (MVar (LogMessage -> Bool)) b + +-- | Specify filter as @LogFilter@. This filter can be changed later. +filteringM :: IsLogBackend b => LogFilter -> LogBackendSettings b -> IO (LogBackendSettings (FilteringM b)) +filteringM fltr b = do + fltrVar <- newMVar (checkLogLevel fltr) + return $ FilteringM fltrVar b + +-- | Exclude messages by filter. This filter can be changed later. +excludingM :: IsLogBackend b => LogFilter -> LogBackendSettings b -> IO (LogBackendSettings (FilteringM b)) +excludingM fltr b = do + fltrVar <- newMVar ex + return $ FilteringM fltrVar b + where + ex msg = not $ checkContextFilter' [LogContextFilter Nothing (Just fltr)] (lmSource msg) (lmLevel msg) + +instance IsLogBackend b => IsLogBackend (FilteringM b) where + data LogBackendSettings (FilteringM b) = + FilteringM (MVar (LogMessage -> Bool)) (LogBackendSettings b) + + wouldWriteMessage (FilteringBackendM fltrVar _) msg = do + fltr <- readMVar fltrVar + return $ fltr msg + + makeLogger (FilteringBackendM fltrVar backend) msg = do + fltr <- readMVar fltrVar + when (fltr msg) $ do + makeLogger backend msg + + initLogBackend (FilteringM fltrVar settings) = do + backend <- initLogBackend settings + return $ FilteringBackendM fltrVar backend + + cleanupLogBackend (FilteringBackendM _ backend) = cleanupLogBackend backend + diff --git a/src/System/Log/Heavy/Shortcuts.hs b/src/System/Log/Heavy/Shortcuts.hs --- a/src/System/Log/Heavy/Shortcuts.hs +++ b/src/System/Log/Heavy/Shortcuts.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, AllowAmbiguousTypes, FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, FlexibleContexts #-} -- | This module contains some shortcut functions that can be of use in simple usage cases. module System.Log.Heavy.Shortcuts @@ -15,7 +15,7 @@ import System.Log.Heavy.Types import System.Log.Heavy.Level -import System.Log.Heavy.Backends +import System.Log.Heavy.Util -- | Message stub with Info severity. infoMessage :: F.VarContainer vars => TL.Text -> vars -> LogMessage diff --git a/src/System/Log/Heavy/Types.hs b/src/System/Log/Heavy/Types.hs --- a/src/System/Log/Heavy/Types.hs +++ b/src/System/Log/Heavy/Types.hs @@ -112,8 +112,8 @@ -- | Should return True if the specified message would be -- actually written to the log. Default implementation -- always returns True. - wouldWriteMessage :: b -> LogMessage -> Bool - wouldWriteMessage _ _ = True + wouldWriteMessage :: b -> LogMessage -> IO Bool + wouldWriteMessage _ _ = return True -- | Cleanup logging backend (release resources and so on) cleanupLogBackend :: b -> IO () diff --git a/src/System/Log/Heavy/Util.hs b/src/System/Log/Heavy/Util.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Heavy/Util.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, FlexibleContexts #-} + +module System.Log.Heavy.Util + ( + -- * Functions of common use + logMessage, + -- * Utilities for backends implementation + checkLogLevel, checkLogLevel', + checkContextFilter, checkContextFilter', checkContextFilterM + ) where + +import Control.Monad (when) +import Control.Monad.Trans +import Data.List (isPrefixOf) + +import System.Log.Heavy.Types +import System.Log.Heavy.Level + +-- | Check if message source and level passes specified filters. +-- +-- The message is passed if: +-- +-- * No @include@ filters are defined in context stack, OR the message conforms to ANY of @include@ filters; +-- +-- * AND the message does not conform to any of @exclude@ filters in the stack. +-- +checkContextFilter' :: [LogContextFilter] -> LogSource -> Level -> Bool +checkContextFilter' filters source level = + let includeFilters = [fltr | LogContextFilter (Just fltr) _ <- filters] + excludeFilters = [fltr | LogContextFilter _ (Just fltr) <- filters] + includeOk = null includeFilters || or [checkLogLevel' fltr source level | fltr <- includeFilters] + excludeOk = or [checkLogLevel' fltr source level | fltr <- excludeFilters] + in includeOk && not excludeOk + +-- | Check if message matches filters from logging context. +-- +-- The message is passed if: +-- +-- * No @include@ filters are defined in context stack, OR the message conforms to ANY of @include@ filters; +-- +-- * AND the message does not conform to any of @exclude@ filters in the stack. +-- +checkContextFilter :: LogContext -> LogMessage -> Bool +checkContextFilter context msg = + checkContextFilter' (map lcfFilter context) (lmSource msg) (lmLevel msg) + +-- | Check if message matches filters from logging context. +-- This function is similar to @checkContextFilter@, but uses current context +-- from monadic state. +checkContextFilterM :: HasLogContext m => LogMessage -> m Bool +checkContextFilterM msg = do + context <- getLogContext + return $ checkContextFilter context msg + +-- | Check if message level matches given filter. +checkLogLevel :: LogFilter -> LogMessage -> Bool +checkLogLevel fltr m = + checkLogLevel' fltr (lmSource m) (lmLevel m) + +-- | Check if message level matches given filter. +checkLogLevel' :: LogFilter -> LogSource -> Level -> Bool +checkLogLevel' fltr source level = + case lookup (bestMatch source (map fst fltr)) fltr of + Nothing -> False + Just min -> level <= min + where + bestMatch :: LogSource -> [LogSource] -> LogSource + bestMatch src list = go [] src list + + go :: LogSource -> LogSource -> [LogSource] -> LogSource + go best src [] = best + go best src (x:xs) + | src == x = x + | (x `isPrefixOf` src) && (length x > length best) = go x src xs + | otherwise = go best src xs + +-- | Log a message. This will add current context to context specified +-- in the message. +-- This function checks current context filter. +logMessage :: forall m. (HasLogging m, MonadIO m) => LogMessage -> m () +logMessage msg = do + ok <- checkContextFilterM msg + when ok $ do + context <- getLogContext + logger <- getLogger + liftIO $ logger $ msg {lmContext = context ++ lmContext msg} +