diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,25 @@ # Revision history for heavy-logger -## 0.1.0.0 -- YYYY-mm-dd +## 0.1.0.0 -- 2017-10-15 * First version. Released on an unsuspecting world. + +## 0.2.0.0 -- 2017-10-16 + +* Major rewrite of internal interfaces. Incompatible API changes. + Was not released to Hackage. +* Added the Shortcuts module. + +## 0.3.0.0 -- 2017-10-24 + +* Introduced parallel logging backend. +* Introduced filtering logging backend. +* Logging context stacks support introduced. +* More flexible severity levels system. This is incompatible API change. + Conversion functions are provided for integration with monad-logger's + LogLevel type. +* Internal modules rearrangement. +* Added the TH module. +* Added the IO module. +* Introduced null logging backend. + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,26 +1,85 @@ heavy-logger README =================== -This is Haskell logging library, which prefers functionality and extendability over light weight and simplicity. -It can use [fast-logger][1] as backend and is compatible with [monad-logger][2] interface, so it can be used in [WAI][3] projects. -heavy-logger is integrated with [text-format-heavy][4] string formatting library. +This is Haskell logging library, which prefers functionality and extendability +over light weight and simplicity. +It can use [fast-logger][1] as backend and is compatible with [monad-logger][2] +interface, so it can be used in projects that already use monad-logger. +heavy-logger is integrated with [text-format-heavy][3] string formatting library. Most notable features of heavy-logger are: -* Several backends and possibility to write your own backends. The provided backends are: - * Fast-logger backend. It allows to write messages to stdout, stderr or arbitrary file. +* Several backends and possibility to write your own backends. The provided + backends are: + * Fast-logger backend. It allows to write messages to stdout, stderr or + arbitrary file. * Syslog backend. - * Chan backend. Writes messages to a Chan, so they can be read from the other side. -* Possibility to define log message format in the output file. For example, do you want to - see event severity level first, and then time, or vice versa? -* Possibility to easily set up message filtering based on message source and severity level. - For example, you may want to write only Info messages, but also Debug messages from one module. -* Text formatting library integration. Formatting of messages by `text-format-heavy` is done lazily; - so, you can issue a lot of debug messages, that include data that take time to present as a string; - the formatting will be executed only in the case when debug output for this module is actually enabled - by the filter. + * Chan backend. Writes messages to a Chan, so they can be read from the other + side. +* 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. +* 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 + logging context stack frame contains a set of named variables. These + variables can be writen to the log. +* Possibility to define log message format in the output file. For example, do + you want to see event severity level first, and then time, or vice versa? It + is possible to use variables from logging context stack in the formatting + string. +* Flexible events filtering mechanism. Messages are filtered based on message + source and severity level. For example, you may want to write only Info + messages, but also Debug messages from one module. Filtering can be + performed on two stages: + * Before event is passed to backend. This stage is context-sensitive; for + example, you can enable logging only for events that happened during + transaction. Context-level filters also support negation; for example, it + is possible to explicitly forbid debug messages from one contexts, while + debug is enabled for the whole system. + * In the backend. For example, you can forbid to write any debug into file, + but allow to write all debug into syslog. +* Text formatting library integration. Formatting of messages by + `text-format-heavy` is done lazily; so, you can issue a lot of debug + messages, that include data that take time to present as a string; the + formatting will be executed only in the case when debug output for this + module is actually enabled by the filter. +This package is mostly writen with ideas of "open architecture". It exposes all +internal logical pieces, so they can be combined in other order in specific +applications. + +All functions provided by the package work within any monad, which should be an +instance of one of type classes defined by package: `HasLogger`, `HasLogBackend`, +`HasLogContext`. Each function's signature declares only specific constraint, so +if you do not need all functionality, you can implement instances only of that +classes that you actually need. + +There are, in general, following ways to use this package: + +* Use `LoggingT` monad transformer. It can be the simplest, if you already have + monadic transformers stack of 1-2 transformers and you do not mind to add yet + another. With `LoggingT`, you do not need to write any adapter instances, since + `LoggingT` is already an instance of all required classes. This implementation + automatically solves all threading-related problems, since in fact it does not + have any shared state. +* Use `System.Log.Heavy.IO` module. If you do not have monadic transformers at all, + and your application works in pure IO, this may be the simplest way. However, + this is a bit fragile, because you have to be sure that you always call logging + functions only when logging state is initialized, i.e. within `withLoggingIO` + call. This implementation stores required state in thread-local storage. +* Implement required class instances for monadic stack that you already use in + your application. For example, if you already have something like + `ReaderT StateT ExceptT IO`, it will be probably better to add a couple of + fields to StateT's state to track logging state, than change your stack to + `ReaderT StateT LoggingT ExceptT IO`. If you wish to store logging state in some + kind of shared storage (global IORef or whatever), then you should think about + thread-safety by yourself. + +Please refer to Haddock documentation and examples in the `examples/` directory +for more detailed information. + [1]: https://hackage.haskell.org/package/fast-logger [2]: https://hackage.haskell.org/package/monad-logger -[3]: https://hackage.haskell.org/package/wai -[4]: https://hackage.haskell.org/package/text-format-heavy +[3]: https://hackage.haskell.org/package/text-format-heavy + diff --git a/examples/Test.hs b/examples/Test.hs new file mode 100644 --- /dev/null +++ b/examples/Test.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleContexts #-} + +import Control.Monad.Trans +import System.Environment +import System.IO +import System.Log.Heavy +import System.Log.Heavy.Shortcuts +import Data.Text.Format.Heavy + +logFormat :: Format +logFormat = "{time} [{level}] {appname} {source}: {message}\n" + +selectBackend :: String -> LoggingSettings +selectBackend "syslog" = LoggingSettings $ defaultSyslogSettings {ssFormat = logFormat} +selectBackend "stderr" = LoggingSettings $ defStderrSettings {lsFormat = logFormat} +selectBackend "stdout" = LoggingSettings $ defStdoutSettings {lsFormat = logFormat} +selectBackend "null" = LoggingSettings $ NullLogSettings +selectBackend "parallel" = + LoggingSettings $ ParallelLogSettings [LoggingSettings defStderrSettings, LoggingSettings defaultSyslogSettings] +selectBackend path = LoggingSettings $ defFileSettings path + +main :: IO () +main = do + [bstr] <- getArgs + let settings = selectBackend bstr + let contextVariables = [("appname", Variable ("hello world" :: String))] + withLoggingT settings $ withLogContext (LogContextFrame contextVariables (include defaultLogFilter)) $ do + liftIO $ putStr "Your name? " + liftIO $ hFlush stdout + name <- liftIO $ getLine + info "name was {}" (Single name) + liftIO $ putStrLn $ "Hello, " ++ name + + + + diff --git a/examples/TestIO.hs b/examples/TestIO.hs new file mode 100644 --- /dev/null +++ b/examples/TestIO.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleContexts, TemplateHaskell #-} + +import Control.Monad (forM_, replicateM) +import Control.Concurrent +import System.Environment +import System.IO +import System.Log.Heavy +import System.Log.Heavy.TH +import System.Log.Heavy.IO +import Data.Text.Format.Heavy + +logFormat :: Format +logFormat = "{time} [{level:~t}] Thread #{thread}: {message}\nSource: {file} +{line}\n" + +selectBackend :: String -> LoggingSettings +selectBackend "syslog" = LoggingSettings $ defaultSyslogSettings {ssFormat = logFormat} +selectBackend "stderr" = LoggingSettings $ defStderrSettings {lsFormat = logFormat} +selectBackend "stdout" = LoggingSettings $ defStdoutSettings {lsFormat = logFormat} +selectBackend "null" = LoggingSettings $ NullLogSettings +selectBackend "parallel" = + LoggingSettings $ ParallelLogSettings [ + LoggingSettings defStderrSettings {lsFormat = logFormat}, + LoggingSettings defaultSyslogSettings {ssFormat = logFormat} + ] +selectBackend path = LoggingSettings $ defFileSettings path + +main :: IO () +main = do + [bstr] <- getArgs + let settings = selectBackend bstr + testHello settings + testThreads settings + +testHello :: LoggingSettings -> IO () +testHello settings = do + withLoggingIO settings $ withLogVariable "thread" ("hello" :: String) $ do + putStr "Your name? " + hFlush stdout + name <- getLine + $info "name was {}" (Single name) + putStrLn $ "Hello, " ++ name + +testThreads :: LoggingSettings -> IO () +testThreads settings = do + let startIdxs = [100, 200, 300] :: [Int] + withLoggingIO settings $ withLogVariable "thread" ("test" :: String) $ do + -- MVars are used for synchronization + mvs <- replicateM (length startIdxs) newEmptyMVar + $info "Running {} threads" (Single $ length startIdxs) + forM_ (zip startIdxs mvs) $ \(start, mvar) -> do + forkIO $ + withLoggingIO settings $ withLogVariable "thread" start $ do + $info "Thread started" () + forM_ [start .. start + 30] $ \counter -> do + $info "Counter is {}" (Single counter) + threadDelay $ 500 * 1000 + putMVar mvar () -- mark thread as done + $info "Thread finished" () + forM_ mvs takeMVar -- read for all threads to finish. + $info "All threads finished" () + diff --git a/examples/TestTH.hs b/examples/TestTH.hs new file mode 100644 --- /dev/null +++ b/examples/TestTH.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleContexts, TemplateHaskell #-} + +import Control.Monad (forM_, replicateM) +import Control.Monad.Trans +import Control.Concurrent +import System.Environment +import System.IO +import System.Log.Heavy +import System.Log.Heavy.TH +import Data.Text.Format.Heavy + +logFormat :: Format +logFormat = "{time} [{level:~l}] #{thread} ({file} +{line}): {message}\n" + +selectBackend :: String -> LoggingSettings +selectBackend "syslog" = LoggingSettings $ defaultSyslogSettings {ssFormat = logFormat} +selectBackend "stderr" = LoggingSettings $ defStderrSettings {lsFormat = logFormat} +selectBackend "stdout" = LoggingSettings $ defStdoutSettings {lsFormat = logFormat} +selectBackend "null" = LoggingSettings $ NullLogSettings +selectBackend "parallel" = + LoggingSettings $ ParallelLogSettings [ + LoggingSettings defStderrSettings {lsFormat = logFormat}, + LoggingSettings defaultSyslogSettings {ssFormat = logFormat} + ] +selectBackend path = LoggingSettings $ defFileSettings path + +main :: IO () +main = do + [bstr] <- getArgs + let settings = selectBackend bstr + testHello settings + testThreads settings + +testHello :: LoggingSettings -> IO () +testHello settings = do + withLoggingT settings $ withLogVariable "thread" ("hello" :: String) $ do + liftIO $ putStr "Your name? " + liftIO $ hFlush stdout + name <- liftIO $ getLine + $info "name was {}" (Single name) + liftIO $ putStrLn $ "Hello, " ++ name + +testThreads :: LoggingSettings -> IO () +testThreads settings = do + let startIdxs = [100, 200, 300] :: [Int] + withLoggingT settings $ withLogVariable "thread" ("hello" :: String) $ do + -- MVars are used for synchronization + mvs <- liftIO $ replicateM (length startIdxs) newEmptyMVar + $info "Running {} threads" (Single $ length startIdxs) + forM_ (zip startIdxs mvs) $ \(start, mvar) -> do + liftIO $ forkIO $ + withLoggingT settings $ withLogVariable "thread" start $ do + $info "Thread started" () + forM_ [start .. start + 30] $ \counter -> do + $info "Counter is {}" (Single counter) + liftIO $ threadDelay $ 500 * 1000 + liftIO $ putMVar mvar () -- mark thread as done + $info "Thread finished" () + liftIO $ forM_ mvs takeMVar -- read for all threads to finish. + $info "All threads finished" () + diff --git a/heavy-logger.cabal b/heavy-logger.cabal --- a/heavy-logger.cabal +++ b/heavy-logger.cabal @@ -1,9 +1,9 @@ name: heavy-logger -version: 0.1.0.0 +version: 0.3.0.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 - with monad-logger interface, so it can be used in WAI projects. + with monad-logger interface, so it can be used in projects that already use monad-logger. heavy-logger is also integrated with text-format-heavy string formatting library. license: BSD3 license-file: LICENSE @@ -12,32 +12,43 @@ -- copyright: category: System build-type: Simple -extra-source-files: ChangeLog.md +extra-source-files: ChangeLog.md, examples/Test.hs, examples/TestTH.hs, examples/TestIO.hs extra-doc-files: README.md cabal-version: >=1.18 library exposed-modules: System.Log.Heavy + System.Log.Heavy.Level System.Log.Heavy.Types + System.Log.Heavy.LoggingT System.Log.Heavy.Format System.Log.Heavy.Backends System.Log.Heavy.Shortcuts + System.Log.Heavy.TH + System.Log.Heavy.IO -- other-modules: -- other-extensions: build-depends: base >=4.8 && <5.0, mtl >= 2.2.1, + containers >= 0.5, transformers-base >= 0.4.4, + data-default >= 0.7, monad-control >= 1.0.1.0, + lifted-base >= 0.2.3, template-haskell >= 2.10.0, + th-lift >= 0.7, + th-lift-instances >= 0.1, bytestring >= 0.10.6, text >= 1.2.2.1, attoparsec >= 0.13.1.0, fast-logger >= 2.4.10, monad-logger >= 0.3.22, hsyslog >= 5, - text-format-heavy >= 0.1.2.0 + text-format-heavy >= 0.1.5.0, + thread-local-storage >= 0.1.1 hs-source-dirs: src default-language: Haskell2010 + ghc-options: -fwarn-unused-imports Source-repository head type: git 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 @@ -1,49 +1,141 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances #-} - --- | This is the main module of @heavy-logger@ package. You usually need to import only this module. --- All generally required modules are re-exported. --- --- For simple usage cases, you may also want to import System.Log.Heavy.Shortcuts module. +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, Rank2Types, ScopedTypeVariables #-} +-- | This is the main module of @heavy-logger@ package. In most cases, you need +-- to import this module. You will also need other modules in specific cases. +-- All modules that are required always are re-exported by this module. -- -- Example of usage is: -- -- @ -- import System.Log.Heavy +-- import System.Log.Heavy.Shortcuts -- import Data.Text.Format.Heavy -- ... -- --- withLogging backend id $ do liftIO $ putStr "Your name? " +-- withLoggingT settings $ do +-- liftIO $ putStr "Your name? " -- liftIO $ hFlush stdout -- name <- liftIO $ getLine --- logMessage $ infoMessage "name was {}" (Single name) +-- info "name was {}" (Single name) -- liftIO $ putStrLn $ "Hello, " ++ name -- @ -- --- See also @Test.hs@. +-- Please refer to @examples/@ directory for compiling examples. +-- +-- There are, in general, following ways to use this package: +-- +-- * Use @LoggingT@ monad transformer. It can be the simplest, if you already have +-- monadic transformers stack of 1-2 transformers and you do not mind to add yet +-- another. With @LoggingT@, you do not need to write any adapter instances, since +-- @LoggingT@ is already an instance of all required classes. This implementation +-- automatically solves all threading-related problems, since in fact it does not +-- have any shared state. -- +-- * Use @System.Log.Heavy.IO@ module. If you do not have monadic transformers at all, +-- and your application works in pure IO, this may be the simplest way. However, +-- this is a bit fragile, because you have to be sure that you always call logging +-- functions only when logging state is initialized, i.e. within @withLoggingIO@ +-- call. This implementation stores required state in thread-local storage. +-- +-- * Implement required class instances for monadic stack that you already use in +-- your application. For example, if you already have something like +-- @ReaderT StateT ExceptT IO@, it will be probably better to add a couple of +-- fields to StateT's state to track logging state, than change your stack to +-- @ReaderT StateT LoggingT ExceptT IO@. If you wish to store logging state in some +-- kind of shared storage (global IORef or whatever), then you should think about +-- thread-safety by yourself. +-- +-- When you decided which monadic context you will use, you will call one of +-- @withLogging*@ functions to run the entire thing, and inside that you will construct +-- instances of @LogMessage@ type and call @logMessage@ or @logMessage'@ function on them +-- to actually log a message. You probably will want to use some shortcut functions to +-- construct @LogMessage@ instances and log them. There are some provided +-- by this package: +-- +-- * @System.Log.Heavy.Shortcuts@ module exports simple functions, that can be used +-- in simple cases, when you do not want to write or check message source. +-- +-- * @System.Log.Heavy.TH@ module exports TH macros, which correctly fill message +-- source and location. +-- module System.Log.Heavy ( -- * Reexports module System.Log.Heavy.Types, + module System.Log.Heavy.Level, + module System.Log.Heavy.LoggingT, module System.Log.Heavy.Backends, - withLogging + withLogging, withLoggingF, withLoggingT, + isLevelEnabledByBackend, isLevelEnabled, ) where import Control.Monad.Trans -import Control.Monad.Logger (LogLevel (..)) +import Control.Monad.Trans.Control +import Control.Exception.Lifted (bracket) import qualified Data.Text.Lazy as TL -import qualified Data.Text.Format.Heavy as F import System.Log.Heavy.Types +import System.Log.Heavy.Level +import System.Log.Heavy.LoggingT import System.Log.Heavy.Backends --- | Run LoggingT monad within some kind of IO monad. -withLogging :: MonadIO m - => LogBackend -- ^ Logging backend settings - -> (m a -> IO a) -- ^ Runner to run @m@ within @IO@. - -- For example this may be @runReader@ or @evalState@. - -- Use @id@ for case when @m@ is @IO@. - -> LoggingT m a -- ^ Actions within @LoggingT@ monad. +-- | Execute actions with logging backend. +-- This is mostly an utility function to be used to construct custom +-- logging frameworks for custom monad transformer stacks. +withLoggingF :: (MonadBaseControl IO m, MonadIO m) + => LoggingSettings -- ^ Settings of arbitrary logging backend. + -> (forall b. IsLogBackend b => b -> m a) -- ^ Actions to execute with logging backend. + -- Note that this type declaration binds argument + -- to work with *any* implementation of backend. -> m a -withLogging (LogBackend b) = withLoggingB b +withLoggingF (LoggingSettings settings) actions = withLoggingB settings actions + +-- | Execute actions with logging. +-- This function can be useful for monad stacks that store logging backend +-- in State-like structure. +withLogging :: (MonadBaseControl IO m, MonadIO m, HasLogger m) + => LoggingSettings -- ^ Settings of arbitrary logging backend + -> m a -- ^ Actions to be executed + -> m a +withLogging (LoggingSettings settings) actions = + bracket (liftIO $ initLogBackend settings) + (liftIO . cleanupLogBackend) + (\b -> applyBackend b actions) + +-- | Execute actions with logging. +-- This function is most convinient if you use @LoggingT@ as +-- @HasLogging@ implementation. +withLoggingT :: (MonadBaseControl IO m, MonadIO m) + => LoggingSettings -- ^ Settings of arbitrary logging backend + -> LoggingT m a -- ^ Actions to be executed + -> m a +withLoggingT (LoggingSettings settings) actions = + withLoggingB settings $ \backend -> + let logger = makeLogger backend + in runLoggingT actions $ LoggingTState logger (AnyLogBackend backend) [] + +-- | Check if logging of events of specified level from specified source +-- is enabled by backend. +-- +-- 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 src level = do + backend <- getLogBackend :: m AnyLogBackend + let msg = LogMessage level src undefined TL.empty () [] + return $ wouldWriteMessage backend msg + +-- | Check if logging of events of specified level from specified source +-- is enabled by both context and backend filter. +-- +-- 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 src level = do + let msg = LogMessage level src undefined TL.empty () [] + backend <- getLogBackend :: m AnyLogBackend + let isEnabledByBackend = 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 @@ -1,11 +1,18 @@ {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances #-} - +-- | This module contains implementation of most commonly used logging backends. +-- You can write your own backends, by implementing an instance of @IsLogBackend@ +-- type class. module System.Log.Heavy.Backends ( -- $description -- * Backends - FastLoggerSettings (..), - SyslogSettings (..), + FastLoggerBackend, + SyslogBackend, + ChanLoggerBackend, + ParallelBackend, + NullBackend, + Filtering, filtering, excluding, + LogBackendSettings (..), -- * Default settings defStdoutSettings, defStderrSettings, @@ -13,22 +20,25 @@ defaultSyslogSettings, defaultSyslogFormat, -- * Utilities for other backends implementation - checkLogLevel + checkLogLevel, checkLogLevel', + checkContextFilter, checkContextFilter', checkContextFilterM, + logMessage ) where import Control.Monad import Control.Monad.Trans (liftIO) import Control.Monad.Reader -import Control.Monad.Logger (MonadLogger (..), LogLevel (..)) import Control.Concurrent import Data.List (isPrefixOf) -import qualified Data.Text as T import qualified Data.ByteString.Unsafe as BSU import qualified Data.Text.Format.Heavy as F import qualified System.Posix.Syslog as Syslog import System.Log.FastLogger as FL +import Foreign.C.String (CString, newCString) +import Foreign.Marshal.Alloc (free) import System.Log.Heavy.Types +import System.Log.Heavy.Level import System.Log.Heavy.Format -- $description @@ -45,116 +55,200 @@ -- -- * Chan backend. -- - --- | Settings of fast-logger backend. This mostly reflects settings of fast-logger itself. -data FastLoggerSettings = FastLoggerSettings { - lsFilter :: LogFilter -- ^ Log messages filter - , lsFormat :: F.Format -- ^ Log message format - , lsType :: FL.LogType -- ^ Fast-logger target settings - } +-- * Null backend. This discards all messages. Can be used to disable logging. +-- +-- There are also some backend combinators: +-- +-- * Filtering - passes messages, that match specified filter, +-- to underlying backend. +-- +-- * Parallel - writes messages to several backends in parallel. +-- -- | Default settings for fast-logger stdout output -defStdoutSettings :: FastLoggerSettings -defStdoutSettings = FastLoggerSettings defaultLogFilter defaultLogFormat (FL.LogStdout FL.defaultBufSize) +defStdoutSettings :: LogBackendSettings FastLoggerBackend +defStdoutSettings = FastLoggerSettings defaultLogFormat (FL.LogStdout FL.defaultBufSize) -- | Default settings for fast-logger stderr output -defStderrSettings :: FastLoggerSettings -defStderrSettings = FastLoggerSettings defaultLogFilter defaultLogFormat (FL.LogStderr FL.defaultBufSize) +defStderrSettings :: LogBackendSettings FastLoggerBackend +defStderrSettings = FastLoggerSettings defaultLogFormat (FL.LogStderr FL.defaultBufSize) -- | Default settings for fast-logger file output. -- This implies log rotation when log file size reaches 10Mb. -defFileSettings :: FilePath -> FastLoggerSettings -defFileSettings path = FastLoggerSettings defaultLogFilter defaultLogFormat (FL.LogFile spec FL.defaultBufSize) +defFileSettings :: FilePath -> LogBackendSettings FastLoggerBackend +defFileSettings path = FastLoggerSettings defaultLogFormat (FL.LogFile spec FL.defaultBufSize) where spec = FL.FileLogSpec path (10*1024*1024) 3 -instance IsLogBackend FastLoggerSettings where - -- withLogging :: (MonadIO m) => FastLoggerSettings -> (m a -> IO a) -> LoggingT m a -> m a - withLoggingB settings runner (LoggingT actions) = do - liftIO $ do - tcache <- newTimeCache simpleTimeFormat' - withTimedFastLogger tcache (lsType settings) $ \logger -> - runner $ runReaderT actions $ mkLogger logger settings - where - mkLogger :: TimedFastLogger -> FastLoggerSettings -> Logger - mkLogger logger s m = do - let fltr = lsFilter s - let format = lsFormat s - when (checkLogLevel fltr m) $ do - logger $ formatLogMessage format m - --- | Settings for syslog backend. This mostly reflects syslog API. -data SyslogSettings = SyslogSettings { - ssFilter :: LogFilter -- ^ Log messages filter - , ssFormat :: F.Format -- ^ Log message format. Usually you do not want to put time here, - -- because syslog writes time to log by itself by default. - , ssIdent :: String -- ^ Syslog source identifier. Usually the name of your program. - , ssOptions :: [Syslog.Option] -- ^ Syslog options - , ssFacility :: Syslog.Facility -- ^ Syslog facility. It is usally User, if you are writing user-space - -- program. +-- | Fast-logger logging backend. +data FastLoggerBackend = FastLoggerBackend { + flbSettings :: LogBackendSettings FastLoggerBackend, + flbTimedLogger :: TimedFastLogger, + flbCleanup :: IO () } +instance IsLogBackend FastLoggerBackend where + -- | Settings of fast-logger backend. This mostly reflects settings of fast-logger itself. + data LogBackendSettings FastLoggerBackend = FastLoggerSettings { + lsFormat :: F.Format -- ^ Log message format + , lsType :: FL.LogType -- ^ Fast-logger target settings + } + + initLogBackend settings = do + tcache <- newTimeCache simpleTimeFormat' + (logger, cleanup) <- newTimedFastLogger tcache (lsType settings) + return $ FastLoggerBackend settings logger cleanup + + cleanupLogBackend b = do + flbCleanup b + + makeLogger backend msg = do + let settings = flbSettings backend + let format = lsFormat settings + let logger = flbTimedLogger backend + logger $ formatLogMessage format msg + -- | Default settings for syslog backend -defaultSyslogSettings :: SyslogSettings -defaultSyslogSettings = SyslogSettings defaultLogFilter defaultSyslogFormat "application" [] Syslog.User +defaultSyslogSettings :: LogBackendSettings SyslogBackend +defaultSyslogSettings = SyslogSettings defaultSyslogFormat "application" [] Syslog.User -- | Default log message format fof syslog backend: -- @[{level}] {source}: {message}@ defaultSyslogFormat :: F.Format defaultSyslogFormat = "[{level}] {source}: {message}" -instance IsLogBackend SyslogSettings where - withLoggingB settings runner (LoggingT actions) = do - liftIO $ do - tcache <- newTimeCache simpleTimeFormat' - Syslog.withSyslog (ssIdent settings) (ssOptions settings) (ssFacility settings) $ do - let logger = mkSyslogLogger tcache settings - runner $ runReaderT actions logger - where - mkSyslogLogger :: IO FormattedTime -> SyslogSettings -> Logger - mkSyslogLogger tcache s m = do - let fltr = ssFilter s - format = ssFormat s - facility = ssFacility s - when (checkLogLevel fltr m) $ do - time <- tcache - let str = formatLogMessage format m time - BSU.unsafeUseAsCStringLen (fromLogStr str) $ - Syslog.syslog (Just facility) (levelToPriority $ lmLevel m) +-- | Syslog logging backend. +data SyslogBackend = SyslogBackend { + sbSettings :: LogBackendSettings SyslogBackend, + sbIdent :: CString, + sbTimeCache :: IO FormattedTime + } - levelToPriority :: LogLevel -> Syslog.Priority - levelToPriority LevelDebug = Syslog.Debug - levelToPriority LevelInfo = Syslog.Info - levelToPriority LevelWarn = Syslog.Warning - levelToPriority LevelError = Syslog.Error - levelToPriority (LevelOther level) = - case level of - "Emergency" -> Syslog.Emergency - "Alert" -> Syslog.Alert - "Critical" -> Syslog.Critical - "Notice" -> Syslog.Notice - _ -> error $ "unknown log level: " ++ T.unpack level +instance IsLogBackend SyslogBackend where + -- | Settings for syslog backend. This mostly reflects syslog API. + data LogBackendSettings SyslogBackend = SyslogSettings { + ssFormat :: F.Format -- ^ Log message format. Usually you do not want to put time here, + -- because syslog writes time to log by itself by default. + , ssIdent :: String -- ^ Syslog source identifier. Usually the name of your program. + , ssOptions :: [Syslog.Option] -- ^ Syslog options + , ssFacility :: Syslog.Facility -- ^ Syslog facility. It is usally User, if you are writing user-space + -- program. + } + initLogBackend settings = do + ident <- newCString (ssIdent settings) + tcache <- newTimeCache simpleTimeFormat' + Syslog.openlog ident (ssOptions settings) (ssFacility settings) + return $ SyslogBackend settings ident tcache + + cleanupLogBackend backend = do + free $ sbIdent backend + Syslog.closelog + + makeLogger backend msg = do + let settings = sbSettings backend + let format = ssFormat settings + facility = ssFacility settings + tcache = sbTimeCache backend + time <- tcache + let str = formatLogMessage format msg time + BSU.unsafeUseAsCStringLen (fromLogStr str) $ + Syslog.syslog (Just facility) (levelToPriority $ lmLevel msg) + -- | Logging backend which writes all messages to the @Chan@ -data ChanLoggerSettings = ChanLoggerSettings { - clFilter :: LogFilter -- ^ Log messages filter - , clChan :: Chan LogMessage -- ^ @Chan@ where write messages to +data ChanLoggerBackend = ChanLoggerBackend { + clChan :: Chan LogMessage -- ^ @Chan@ where write messages to } -instance IsLogBackend ChanLoggerSettings where - withLoggingB settings runner (LoggingT actions) = do - runReaderT actions logger - where - logger m = do - let fltr = clFilter settings - when (checkLogLevel fltr m) $ do - liftIO $ writeChan (clChan settings) m +instance IsLogBackend ChanLoggerBackend where + data LogBackendSettings ChanLoggerBackend = + ChanLoggerSettings (Chan LogMessage) + initLogBackend (ChanLoggerSettings chan) = + return $ ChanLoggerBackend chan + + cleanupLogBackend _ = return () + + makeLogger backend msg = do + liftIO $ writeChan (clChan backend) msg + +-- | Logging backend that writes log messages to several other backends in parallel. +data ParallelBackend = ParallelBackend ![AnyLogBackend] + +instance IsLogBackend ParallelBackend where + data LogBackendSettings ParallelBackend = ParallelLogSettings [LoggingSettings] + + wouldWriteMessage (ParallelBackend list) msg = + or [wouldWriteMessage backend msg | backend <- list] + + makeLogger (ParallelBackend list) msg = + forM_ list $ \(AnyLogBackend backend) -> makeLogger backend msg + + initLogBackend (ParallelLogSettings list) = do + backends <- do + forM list $ \(LoggingSettings settings) -> do + backend <- initLogBackend settings + return $ AnyLogBackend backend + return $ ParallelBackend backends + + cleanupLogBackend (ParallelBackend list) = + forM_ (reverse list) $ \(AnyLogBackend backend) -> cleanupLogBackend backend + +-- | Messages filtering backend. This backend passes a message to underlying backend, +-- if this message conforms to specified filter. +data Filtering b = FilteringBackend (LogMessage -> Bool) b + +-- | Specify filter as @LogFilter@. +filtering :: IsLogBackend b => LogFilter -> LogBackendSettings b -> LogBackendSettings (Filtering b) +filtering fltr b = Filtering (checkLogLevel fltr) b + +-- | Exclude messages by filter. +excluding :: IsLogBackend b => LogFilter -> LogBackendSettings b -> LogBackendSettings (Filtering b) +excluding fltr b = Filtering ex b + where + ex msg = not $ checkContextFilter' [LogContextFilter Nothing (Just fltr)] (lmSource msg) (lmLevel msg) + +instance IsLogBackend b => IsLogBackend (Filtering b) where + data LogBackendSettings (Filtering b) = Filtering (LogMessage -> Bool) (LogBackendSettings b) + + wouldWriteMessage (FilteringBackend fltr _) msg = fltr msg + + makeLogger (FilteringBackend fltr backend) msg = do + when (fltr msg) $ do + makeLogger backend msg + + initLogBackend (Filtering fltr settings) = do + backend <- initLogBackend settings + return $ FilteringBackend fltr backend + + cleanupLogBackend (FilteringBackend _ b) = cleanupLogBackend b + +-- | Null logging backend, which discards all messages +-- (passes them to @/dev/null@, if you wish). +-- This can be used to disable logging. +data NullBackend = NullBackend + +instance IsLogBackend NullBackend where + data LogBackendSettings NullBackend = NullLogSettings + + wouldWriteMessage _ _ = False + + makeLogger _ _ = return () + + initLogBackend _ = return NullBackend + + cleanupLogBackend _ = return () + -- | Check if message level matches given filter. checkLogLevel :: LogFilter -> LogMessage -> Bool checkLogLevel fltr m = - case lookup (bestMatch (lmSource m) (map fst fltr)) fltr of + 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 level -> lmLevel m >= level + Just min -> level <= min where bestMatch :: LogSource -> [LogSource] -> LogSource bestMatch src list = go [] src list @@ -164,4 +258,51 @@ | 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/Format.hs b/src/System/Log/Heavy/Format.hs --- a/src/System/Log/Heavy/Format.hs +++ b/src/System/Log/Heavy/Format.hs @@ -4,16 +4,36 @@ -- -- Log message format is defined by using @text-format-heavy@ syntax. Variables available are: -- --- * level - message severity level +-- * level - message severity level. Variable format can be specified in form of +-- @selector[~convert]@, where: -- +-- * @selector@ is @name@ for level name, @value@ for level integer value, +-- @syslog@ for name of syslog equivalent of the level. +-- +-- * @convert@ is @u@ for upper case, @l@ for lower case, @t@ for title case +-- (all words capitalized). +-- +-- Default format corresponds to @name@. For example, use @{level:~l}@ to +-- output level name in lower case. +-- -- * source - message source (module name) -- --- * location - location from where message was logged (line in source file) +-- * location - location from where message was logged (in form of @(line, column)@). -- +-- * line - source file line number from where message was logged. +-- +-- * file - source file name from where message was logged. +-- +-- * package - name of the package from where message was logged. +-- -- * time - message time -- -- * message - message string itself -- +-- * fullcontext - full set of current context variable values, in @name=value; name=value;@ form. +-- +-- * Also all variables from context are available. +-- module System.Log.Heavy.Format ( defaultLogFormat, formatLogMessage @@ -21,22 +41,112 @@ import Control.Applicative import Control.Monad -import Control.Monad.Logger (MonadLogger (..), LogLevel (..)) -import Data.List (intersperse, intercalate) -import Data.String -import Data.Char +import Data.List (intercalate) import Data.Maybe -import qualified Data.Text as T +import Data.Monoid +import Data.Default +import qualified Data.Map as M import qualified Data.Text.Lazy as TL -import qualified Data.ByteString as B --- import Data.Attoparsec.ByteString +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Text.Lazy.Builder.Int as Builder import System.Log.FastLogger import qualified Data.Text.Format.Heavy as F import qualified Data.Text.Format.Heavy.Parse as PF +import Data.Text.Format.Heavy.Formats (Conversion (..)) +import Data.Text.Format.Heavy.Build (convertText) +import Data.Attoparsec.Text +import Language.Haskell.TH.Syntax (Loc (..)) import Prelude hiding (takeWhile) import System.Log.Heavy.Types +import System.Log.Heavy.Level +data LogMessageWithTime = LogMessageWithTime FormattedTime LogMessage + +data LevelFormatSelector = ShowLevelName | ShowLevelValue | ShowSyslog + deriving (Eq, Show) + +data LevelFormat = LevelFormat { + lfSelector :: LevelFormatSelector + , lfConvert :: Maybe Conversion + } + deriving (Eq, Show) + +instance Default LevelFormat where + def = LevelFormat ShowLevelName Nothing + +instance F.IsVarFormat LevelFormat where + parseVarFormat text = either (Left . show) Right $ doParse $ TL.toStrict text + where + pFormat :: Parser LevelFormat + pFormat = do + mbSelector <- optionMaybe (pSelector "level detail selector") + let selector = fromMaybe ShowLevelName mbSelector + mbConvert <- optionMaybe (pConvert "conversion specification") + return $ LevelFormat selector mbConvert + + optionMaybe p = option Nothing (Just <$> p) + + pSelector :: Parser LevelFormatSelector + pSelector = + try (string "value" >> return ShowLevelValue) <|> + try (string "syslog" >> return ShowSyslog) <|> + (string "name" >> return ShowLevelName) + + pConvert :: Parser Conversion + pConvert = do + char '~' + conv <- satisfy (`elem` ['u', 'l', 't']) + case conv of + 'u' -> return UpperCase + 'l' -> return LowerCase + 't' -> return TitleCase + + doParse text = parseOnly pFormat text + +instance F.Formatable Level where + formatVar Nothing level = Right $ Builder.fromText (levelName level) + formatVar (Just fmt) level = do + lf <- F.parseVarFormat fmt + let text = case lfSelector lf of + ShowLevelName -> Builder.fromText (levelName level) + ShowLevelValue -> Builder.decimal (levelInt level) + ShowSyslog -> Builder.fromString (show $ levelToPriority level) + Right $ convertText (lfConvert lf) text + +instance F.VarContainer LogMessageWithTime where + lookupVar name (LogMessageWithTime ftime (LogMessage {..})) = + case lookup name stdVariables of + Just value -> Just value + Nothing -> Just $ fromMaybe (F.Variable TL.empty) $ msum $ map (lookup name) contextVariables + where + stdVariables :: [(TL.Text, F.Variable)] + stdVariables = [("level", F.Variable lmLevel), + ("source", F.Variable $ intercalate "." lmSource), + ("location", F.Variable $ show $ loc_start lmLocation), + ("line", F.Variable $ fst $ loc_start lmLocation), + ("file", F.Variable $ loc_filename lmLocation), + ("package", F.Variable $ loc_package lmLocation), + ("time", F.Variable ftime), + ("message", F.Variable formattedMessage), + ("fullcontext", F.Variable fullContext)] + + contextVariables :: [[(TL.Text, F.Variable)]] + contextVariables = map lcfVariables lmContext + + fullContext :: TL.Text + fullContext = TL.concat $ map showContextVar $ M.assocs $ M.fromList $ concat contextVariables + + showContextVar :: (TL.Text, F.Variable) -> TL.Text + showContextVar (name, value) = name <> "=" <> formatVar value <> "; " + + formatVar :: F.Variable -> TL.Text + formatVar var = either error Builder.toLazyText $ F.formatVar Nothing var + + formattedMessage = + let fmt = PF.parseFormat' lmFormatString + in F.format fmt lmFormatVars + -- | Default log message format. -- Corresponds to: @{time} [{level}] {source}: {message}\\n@ defaultLogFormat :: F.Format @@ -44,23 +154,5 @@ -- | Format log message for output. formatLogMessage :: F.Format -> LogMessage -> FormattedTime -> LogStr -formatLogMessage fmt (LogMessage {..}) ftime = - toLogStr $ F.format fmt variables - where - variables :: [(TL.Text, F.Variable)] - variables = [("level", F.Variable $ showLevel lmLevel), - ("source", F.Variable $ intercalate "." lmSource), - ("location", F.Variable $ show lmLocation), - ("time", F.Variable ftime), - ("message", F.Variable formattedMessage)] - - formattedMessage = - let fmt = PF.parseFormat' lmFormatString - in F.format fmt lmFormatVars - - showLevel LevelDebug = "debug" - showLevel LevelInfo = "info" - showLevel LevelWarn = "warning" - showLevel LevelError = "error" - showLevel (LevelOther x) = T.unpack x +formatLogMessage fmt msg ftime = toLogStr $ F.format fmt $ LogMessageWithTime ftime msg diff --git a/src/System/Log/Heavy/IO.hs b/src/System/Log/Heavy/IO.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Heavy/IO.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, AllowAmbiguousTypes, ScopedTypeVariables, FunctionalDependencies, FlexibleContexts, ConstraintKinds #-} +-- | This module contains implementation of @HasLogger@, @HasLogBackend@, @HasLogContext@ instances for IO monad. +-- This implementation uses thread-local storage, so each thread will have it's own logging state (context and logger). +-- +-- This module is not automatically re-exported by System.Log.Heavy, because in many cases it is more convinient to maintain +-- logging state within monadic context, than in global variable. +-- +-- Note: implementations of @HasLogger@, @HasLogBackend@, @HasLogContext@ for IO, provided by this module, work only inside +-- @withLoggingIO@ call. If you try to call logging functions outside, you will get runtime error. +-- +module System.Log.Heavy.IO + ( withLoggingIO + ) where + +import Control.Exception +import Data.IORef +import Data.TLS.GHC + +import System.IO.Unsafe (unsafePerformIO) + +import System.Log.Heavy.Types + +-- | Logging state stored in TLS (thread-local storage) +data LoggingIOState = LoggingIOState { + liosLogger :: SpecializedLogger + , liosBackend :: AnyLogBackend + , liosContext :: LogContext + } + +-- | This global variable stores logging state. +-- Nothing inside IORef means that logging state is not initialized yet +-- or is already deinitialized. +loggingTLS :: TLS (IORef (Maybe LoggingIOState)) +loggingTLS = unsafePerformIO $ mkTLS $ do + newIORef Nothing +{-# NOINLINE loggingTLS #-} + +-- | Execute IO actions with logging. +-- +-- Note 1: logging methods calls in IO monad are only valid inside @withLoggingIO@. +-- If you try to call them outside of this function, you will receive runtime error. +-- +-- Note 2: if you will for some reason call @withLoggingIO@ inside @withLoggingIO@ within one +-- thread, you will receive runtime error. +-- +-- Note 3: You can call @withLoggingIO@ syntactically inside @withLoggingIO@, but within other +-- thread. I.e., the construct like following is valid: +-- +-- @ +-- withLoggingIO settings $ do +-- \$info "message" () +-- ... +-- forkIO $ do +-- withLoggingIO settings $ do +-- \$info "message" () +-- ... +-- @ +-- +withLoggingIO :: LoggingSettings -- ^ Settings of arbitrary logging backend + -> IO a -- ^ Actions to be executed with logging + -> IO a +withLoggingIO (LoggingSettings settings) actions = + bracket (init settings) + (cleanup) + (\tls -> withBackend tls actions) + where + init settings = do + ioref <- getTLS loggingTLS + mbState <- readIORef ioref + case mbState of + Just _ -> fail "Logging IO state is already initialized. withLoggingIO was called twice?" + Nothing -> do + backend <- initLogBackend settings + let logger = makeLogger backend + let st = LoggingIOState logger (AnyLogBackend backend) [] + writeIORef ioref (Just st) + return st + + cleanup st = do + ioref <- getTLS loggingTLS + freeAllTLS loggingTLS + writeIORef ioref Nothing + + withBackend st actions = actions + +-- | Get current logging state. Fail if it is not initialized yet. +getLogginngIOState :: IO LoggingIOState +getLogginngIOState = do + ioref <- getTLS loggingTLS + mbState <- readIORef ioref + case mbState of + Nothing -> fail "get: Logging IO state is not initialized. See withLoggingIO." + Just st -> return st + +-- | Modify logging state with pure function. +-- Fail if logging state is not initialized yet. +modifyLoggingIOState :: (LoggingIOState -> LoggingIOState) -> IO () +modifyLoggingIOState fn = do + ioref <- getTLS loggingTLS + modifyIORef ioref $ \mbState -> + case mbState of + Nothing -> error "modify: Logging IO state is not initialized. See withLoggingIO." + Just st -> Just (fn st) + +instance HasLogBackend AnyLogBackend IO where + getLogBackend = do + st <- getLogginngIOState + return $ liosBackend st + +instance HasLogger IO where + getLogger = do + st <- getLogginngIOState + return $ liosLogger st + + localLogger logger actions = do + oldLogger <- getLogger + modifyLoggingIOState $ \st -> st {liosLogger = logger} + result <- actions + modifyLoggingIOState $ \st -> st {liosLogger = oldLogger} + return result + +instance HasLogContext IO where + getLogContext = do + st <- getLogginngIOState + return $ liosContext st + + withLogContext frame actions = do + oldContext <- getLogContext + modifyLoggingIOState $ \st -> st {liosContext = frame:oldContext} + result <- actions + modifyLoggingIOState $ \st -> st {liosContext = oldContext} + return result + diff --git a/src/System/Log/Heavy/Level.hs b/src/System/Log/Heavy/Level.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Heavy/Level.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, AllowAmbiguousTypes, ScopedTypeVariables, FunctionalDependencies, FlexibleContexts, ConstraintKinds #-} + +-- | This module contains types and functions for log message severities. +module System.Log.Heavy.Level + ( -- * Data types + Level (..), + -- * Utility functions + levelToLogLevel, logLevelToLevel, + parseLevel, + -- * Standard severity levels + trace_level, debug_level, info_level, warn_level, error_level, fatal_level, + disable_logging + ) where + +import Control.Monad.Logger (LogLevel (..)) +import qualified Data.Text as T +import qualified System.Posix.Syslog as Syslog + +-- | Logging message severity level data type +data Level = Level { + levelName :: T.Text -- ^ Level name, like @"debug"@ or @"info"@ + , levelInt :: Int -- ^ Integer level identifier. Comparation is based on these identifiers. + , levelToPriority :: Syslog.Priority -- ^ Syslog equivalent of this level. + } deriving (Eq) + +instance Show Level where + show l = T.unpack (levelName l) + +instance Ord Level where + compare l1 l2 = compare (levelInt l1) (levelInt l2) + +-- | TRACE level is supposed to be used for development-stage debugging. +trace_level :: Level +trace_level = Level "TRACE" 600 Syslog.Debug + +-- | DEBUG level is supposed to be used for debug logging that can be +-- enabled on production. +debug_level :: Level +debug_level = Level "DEBUG" 500 Syslog.Debug + +-- | INFO level: some event occured. +info_level :: Level +info_level = Level "INFO" 400 Syslog.Info + +-- | WARN level: something went wrong, but for now it will not affect +-- system's stability. +warn_level :: Level +warn_level = Level "WARN" 300 Syslog.Warning + +-- | ERROR level: something went wrong. +error_level :: Level +error_level = Level "ERROR" 200 Syslog.Error + +-- | FATAL level: something went terribly wrong, application is to be stopped. +fatal_level :: Level +fatal_level = Level "FATAL" 100 Syslog.Emergency + +-- | DISABLED level. This has integer identifier of 0, which is supposed to +-- be less than any other level. This value can be used to disable logging at +-- all. +disable_logging :: Level +disable_logging = Level "DISABLED" 0 Syslog.Emergency + +-- | Conversion function +levelToLogLevel :: Level -> LogLevel +levelToLogLevel l = + case levelName l of + "DEBUG" -> LevelDebug + "INFO" -> LevelInfo + "WARN" -> LevelWarn + "ERROR" -> LevelError + name -> LevelOther name + +-- | Convertion function. Note that @LevelOther@ is +-- translated to integer level 210 and Syslog's Alert priority, +-- since in @monad-logger@ semantics any LevelOther is more severe +-- than LevelError. +logLevelToLevel :: LogLevel -> Level +logLevelToLevel LevelDebug = debug_level +logLevelToLevel LevelInfo = info_level +logLevelToLevel LevelWarn = warn_level +logLevelToLevel LevelError = error_level +logLevelToLevel (LevelOther name) = Level name 210 Syslog.Alert + +-- | Detect @Level@ from it's name. This function +-- is not case-sensitive. +parseLevel :: [Level] -- ^ List of recognized levels + -> T.Text -- ^ Level name to find + -> Maybe Level -- ^ Nothing if no match found +parseLevel knownLevels str = go knownLevels + where + go [] = Nothing + go (l:ls) + | T.toCaseFold (levelName l) == needle = Just l + | otherwise = go ls + + needle = T.toCaseFold str + diff --git a/src/System/Log/Heavy/LoggingT.hs b/src/System/Log/Heavy/LoggingT.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Heavy/LoggingT.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, AllowAmbiguousTypes, ScopedTypeVariables, FunctionalDependencies, FlexibleContexts, ConstraintKinds #-} +-- | This module contains default implementation of @HasLogBackend@, +-- @HasLogContext@, @HasLogger@ instances, based on @ReaderT@ - @LoggingT@ +-- monad transformer. +module System.Log.Heavy.LoggingT + ( + LoggingT (LoggingT), LoggingTState (..), + runLoggingT + ) where + +import Control.Monad.Reader +import Control.Monad.Base +import Control.Monad.Trans.Control + +import System.Log.Heavy.Types + +-- | State of @LoggingT@ monad +data LoggingTState = LoggingTState { + ltsLogger :: SpecializedLogger + , ltsBackend :: AnyLogBackend + , ltsContext :: LogContext + } + +-- | Logging monad transformer. +-- This is just a default implementation of @HasLogging@ interface. +-- Applications are free to use this or another implementation. +newtype LoggingT m a = LoggingT { + runLoggingT_ :: ReaderT LoggingTState m a + } + deriving (Functor, Applicative, Monad, MonadReader LoggingTState, MonadTrans) + +deriving instance MonadIO m => MonadIO (LoggingT m) + +instance MonadIO m => MonadBase IO (LoggingT m) where + liftBase = liftIO + +instance MonadTransControl LoggingT where + type StT LoggingT a = StT (ReaderT LoggingTState) a + liftWith = defaultLiftWith LoggingT runLoggingT_ + restoreT = defaultRestoreT LoggingT + +instance (MonadBaseControl IO m, MonadIO m) => MonadBaseControl IO (LoggingT m) where + type StM (LoggingT m) a = ComposeSt LoggingT m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + +instance Monad m => HasLogger (LoggingT m) where + getLogger = asks ltsLogger + localLogger l actions = LoggingT $ ReaderT $ \lts -> runReaderT (runLoggingT_ actions) $ lts {ltsLogger = l} + +instance (Monad m) => HasLogContext (LoggingT m) where + getLogContext = asks ltsContext + + withLogContext frame actions = + LoggingT $ ReaderT $ \lts -> runReaderT (runLoggingT_ actions) $ lts {ltsContext = frame: ltsContext lts} + +-- | Run logging monad +runLoggingT :: LoggingT m a -> LoggingTState -> m a +runLoggingT actions context = runReaderT (runLoggingT_ actions) context + +instance Monad m => HasLogBackend AnyLogBackend (LoggingT m) where + getLogBackend = asks ltsBackend + 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 #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, AllowAmbiguousTypes, FlexibleContexts #-} -- | This module contains some shortcut functions that can be of use in simple usage cases. module System.Log.Heavy.Shortcuts @@ -10,46 +10,46 @@ ) where import Control.Monad.Trans -import Control.Monad.Logger (LogLevel (..)) import qualified Data.Text.Lazy as TL import qualified Data.Text.Format.Heavy as F import System.Log.Heavy.Types +import System.Log.Heavy.Level import System.Log.Heavy.Backends -- | Message stub with Info severity. infoMessage :: F.VarContainer vars => TL.Text -> vars -> LogMessage -infoMessage fmt vars = LogMessage LevelInfo [] undefined fmt vars +infoMessage fmt vars = LogMessage info_level [] undefined fmt vars [] -- | Message stub with Debug severity. debugMessage :: F.VarContainer vars => TL.Text -> vars -> LogMessage -debugMessage fmt vars = LogMessage LevelDebug [] undefined fmt vars +debugMessage fmt vars = LogMessage debug_level [] undefined fmt vars [] -- | Message stub with Error severity. errorMessage :: F.VarContainer vars => TL.Text -> vars -> LogMessage -errorMessage fmt vars = LogMessage LevelError [] undefined fmt vars +errorMessage fmt vars = LogMessage error_level [] undefined fmt vars [] -- | Message stub with Warning severity. warnMessage :: F.VarContainer vars => TL.Text -> vars -> LogMessage -warnMessage fmt vars = LogMessage LevelWarn [] undefined fmt vars +warnMessage fmt vars = LogMessage warn_level [] undefined fmt vars [] -- | Log debug message. -- Note: this message will not contain source information. -debug :: (F.VarContainer vars, MonadIO m) => TL.Text -> vars -> LoggingT m () +debug :: forall m vars. (F.VarContainer vars, MonadIO m, HasLogging m) => TL.Text -> vars -> m () debug fmt vars = logMessage $ debugMessage fmt vars -- | Log info message. -- Note: this message will not contain source information. -info :: (F.VarContainer vars, MonadIO m) => TL.Text -> vars -> LoggingT m () +info :: forall m vars. (F.VarContainer vars, MonadIO m, HasLogging m) => TL.Text -> vars -> m () info fmt vars = logMessage $ infoMessage fmt vars -- | Log error message. -- Note: this message will not contain source information. -reportError :: (F.VarContainer vars, MonadIO m) => TL.Text -> vars -> LoggingT m () +reportError :: forall m vars. (F.VarContainer vars, MonadIO m, HasLogging m) => TL.Text -> vars -> m () reportError fmt vars = logMessage $ errorMessage fmt vars -- | Log warning message. -- Note: this message will not contain source information. -warning :: (F.VarContainer vars, MonadIO m) => TL.Text -> vars -> LoggingT m () +warning :: forall m vars. (F.VarContainer vars, MonadIO m, HasLogging m) => TL.Text -> vars -> m () warning fmt vars = logMessage $ warnMessage fmt vars diff --git a/src/System/Log/Heavy/TH.hs b/src/System/Log/Heavy/TH.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Heavy/TH.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | This module contains TemplateHaskell macros, that can be useful in many applications. +-- In more complex applications, however, you probably will have to write your own adapter macros, +-- which better suits your needs. +module System.Log.Heavy.TH + (putMessage, + trace, debug, info, warning, reportError, fatal, + here, thisModule + ) where + +import Control.Monad.Logger (liftLoc) +-- import Language.Haskell.TH +import Language.Haskell.TH.Syntax hiding (reportError) +import Language.Haskell.TH.Lift +import Instances.TH.Lift () -- import instances only +import qualified System.Posix.Syslog as Syslog + +import System.Log.Heavy.Types +import System.Log.Heavy.Level + +deriveLift ''Syslog.Priority +deriveLift ''Level + +-- | TH macro to put message to log. Usage: +-- +-- @ +-- \$putMessage info_level "Received message #{}" (Single messageId) +-- @ +-- +-- Use @()@ as last argument if you do not have variables. +-- +-- This code will work in any monad that implements @HasLogging@ constraint. +-- +putMessage :: Level -> Q Exp +putMessage level = [| \msg vars -> do + let loc = $(qLocation >>= liftLoc) + src = splitDots (loc_module loc) + message = LogMessage $(lift level) src loc msg vars [] + logMessage message + |] + +-- | TH macro to obtain current location in haskell source file. +-- Can be useful to construct @LogMessage@ structures 'by hand'. +here :: Q Exp +here = qLocation >>= liftLoc + +-- | TH macro to obtain current module name in form of @LogSource@. +-- Can be useful to construct @LogMessage@ structures 'by hand'. +thisModule :: Q Exp +thisModule = do + loc <- qLocation + lift $ splitDots (loc_module loc) + +-- | TH macro to log a message with TRACE level. Usage: +-- +-- @ +-- \$trace "hello, {}!" (Single name) +-- @ +-- +trace :: Q Exp +trace = putMessage trace_level + +-- | TH macro to log a message with DEBUG level. Usage: +-- +-- @ +-- \$debug "hello, {}!" (Single name) +-- @ +-- +debug :: Q Exp +debug = putMessage debug_level + +-- | TH macro to log a message with INFO level. Usage: +-- +-- @ +-- \$info "hello, {}!" (Single name) +-- @ +-- +info :: Q Exp +info = putMessage info_level + +-- | TH macro to log a message with WARN level. Usage: +-- +-- @ +-- \$warning "Beware the {}!" (Single name) +-- @ +-- +warning :: Q Exp +warning = putMessage warn_level + +-- | TH macro to log a message with ERROR level. Usage: +-- +-- @ +-- \$reportError "Transaction #{} was declined." (Single transactionId) +-- @ +-- +reportError :: Q Exp +reportError = putMessage error_level + +-- | TH macro to log a message with FATAL level. Usage: +-- +-- @ +-- \$fatal "Cannot establish database connection" () +-- @ +-- +fatal :: Q Exp +fatal = putMessage fatal_level + 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 @@ -1,108 +1,233 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, AllowAmbiguousTypes, ScopedTypeVariables, FunctionalDependencies, FlexibleContexts, ConstraintKinds #-} -- | This module contains generic types definition, along with some utilities. module System.Log.Heavy.Types ( - LogSource, LogMessage (..), LogFilter, - IsLogBackend (..), LogBackend (..), Logger, - LoggingT (LoggingT), runLoggingT, + -- * Data types + LogSource, LogMessage (..), LogFilter, LogContextFrame (..), LogContext, + IsLogBackend (..), LogBackendSettings (..), LoggingSettings (..), + AnyLogBackend (..), LogContextFilter (..), + include, exclude, noChange, + Logger,SpecializedLogger, + HasLogBackend (..), HasLogContext (..), HasLogging, + HasLogger (..), + -- * Main functions + logMessage', + applyBackend, defaultLogFilter, + withLogVariable, + -- * Utility functions splitString, splitDots, - logMessage ) where import Control.Monad.Reader -import Control.Monad.Logger (MonadLogger (..), LogLevel (..)) -import Control.Monad.Base +import Control.Monad.Logger (MonadLogger (..)) import Control.Monad.Trans.Control -import Data.String +import Control.Exception.Lifted (bracket) import Language.Haskell.TH import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL -import System.Log.FastLogger import qualified Data.Text.Format.Heavy as F +import System.Log.FastLogger +import System.Log.Heavy.Level + -- | Log message source. This is usually a list of program module names, -- for example @[\"System\", \"Log\", \"Heavy\", \"Types\"]@. type LogSource = [String] --- | Log message structure +-- | Log message structure. You usually will want to use some sort +-- of shortcut function to create messages. There are some provided +-- by this package: +-- +-- * @System.Log.Heavy.Shortcuts@ module exports simple functions, that can be used +-- in simple cases, when you do not want to write or check message source. +-- +-- * @System.Log.Heavy.TH@ module exports TH macros, which correctly fill message +-- source and location. +-- data LogMessage = forall vars. F.VarContainer vars => LogMessage { - lmLevel :: LogLevel -- ^ Log message level + lmLevel :: Level -- ^ Log message level , lmSource :: LogSource -- ^ Log message source (module) , lmLocation :: Loc -- ^ Log message source (exact location). You usually -- will want to use TH quotes to fill this. , lmFormatString :: TL.Text -- ^ Log message string format (in @Data.Text.Format.Heavy@ syntax) , lmFormatVars :: vars -- ^ Log message substitution variables. Use @()@ if you do not have variables. + , lmContext :: LogContext -- ^ Logging context. Authomatically filled by @logMessage@. } -- | Log messages filter by source and level. -- -- Semantics under this is that @(source, severity)@ pair allows to write -- messages from @source@ of @severity@ (and all more important messages) to log. -type LogFilter = [(LogSource, LogLevel)] +type LogFilter = [(LogSource, Level)] -- | Default log messages filter. This says pass all messages -- of level Info or higher. defaultLogFilter :: LogFilter -defaultLogFilter = [([], LevelInfo)] +defaultLogFilter = [([], info_level)] +-- | One frame in logging context stack. +data LogContextFrame = LogContextFrame { + lcfVariables :: [(TL.Text, F.Variable)] -- ^ Context variables + , lcfFilter :: LogContextFilter -- ^ Context events filter + } + deriving (Show) + +-- | Events filter for specific logging context. +data LogContextFilter = + LogContextFilter { + setInclude :: Maybe LogFilter -- ^ Positive filter (include specified messages) + , setExclude :: Maybe LogFilter -- ^ Negative filter (exclude specified messages) + } + deriving (Eq, Show) + +-- | Do not affect context filter settings +noChange :: LogContextFilter +noChange = LogContextFilter Nothing Nothing + +-- | Create filter which includes only specified messages +include :: LogFilter -> LogContextFilter +include f = LogContextFilter (Just f) Nothing + +-- | Create filter which just excludes specified messages +exclude :: LogFilter -> LogContextFilter +exclude f = LogContextFilter Nothing (Just f) + +-- | Logging context stack +type LogContext = [LogContextFrame] + -- | Logging backend class. class IsLogBackend b where - -- | Run LoggingT within some kind of IO monad - withLoggingB :: (MonadIO m) - => b -- ^ Backend settings - -> (m a -> IO a) -- ^ Runner that allows to run this @m@ within @IO@ - -> LoggingT m a -- ^ Actions within @LoggingT@ monad - -> m a + -- | Logging backend settings data type + data LogBackendSettings b + -- | Create logger from backend + makeLogger :: Logger b + + -- | Initialize logging backend from settings + initLogBackend :: LogBackendSettings b -> IO b + + -- | 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 + + -- | Cleanup logging backend (release resources and so on) + cleanupLogBackend :: b -> IO () + + -- | Bracket function. Concrete implementations usually + -- do not have to override default implementation. + withLoggingB :: (MonadBaseControl IO m, MonadIO m) + => LogBackendSettings b + -> (b -> m a) + -> m a + withLoggingB settings actions = do + bracket (liftIO $ initLogBackend settings) + (liftIO . cleanupLogBackend) + (actions) + +-- | Container data type for representing arbitrary logging backend. +data AnyLogBackend = forall b. IsLogBackend b => AnyLogBackend b + +instance IsLogBackend AnyLogBackend where + data LogBackendSettings AnyLogBackend = + AnyLogBackendSettings LoggingSettings + + makeLogger (AnyLogBackend backend) = makeLogger backend + + wouldWriteMessage (AnyLogBackend backend) msg = + wouldWriteMessage backend msg + + initLogBackend (AnyLogBackendSettings (LoggingSettings settings)) = + AnyLogBackend `fmap` initLogBackend settings + + cleanupLogBackend (AnyLogBackend backend) = cleanupLogBackend backend + +-- | Constraint for monads in which it is possible to obtain logging backend. +class IsLogBackend b => HasLogBackend b m where + getLogBackend :: m b + -- | A container for arbitrary logging backend. -- You usually will use this similar to: -- -- @ --- getLoggingSettings :: String -> LogBackend --- getLoggingSettings "syslog" = LogBackend defaultsyslogsettings +-- getLoggingSettings :: String -> LoggingSettings +-- getLoggingSettings "syslog" = LoggingSettings defaultsyslogsettings -- @ -data LogBackend = forall b. IsLogBackend b => LogBackend b +data LoggingSettings = forall b. IsLogBackend b => LoggingSettings (LogBackendSettings b) --- | Logging monad transformer. -newtype LoggingT m a = LoggingT { - runLoggingT_ :: ReaderT Logger m a - } - deriving (Functor, Applicative, Monad, MonadReader Logger, MonadTrans) +-- | Logging function +type Logger backend = backend -> LogMessage -> IO () -deriving instance MonadIO m => MonadIO (LoggingT m) +-- | Logging function applied to concrete backend +type SpecializedLogger = LogMessage -> IO () -instance MonadIO m => MonadBase IO (LoggingT m) where - liftBase = liftIO +-- | Type class for monads that can write logs +class Monad m => HasLogger m where + getLogger :: m SpecializedLogger + + -- | Change logger to specified one locally + localLogger :: SpecializedLogger -> m a -> m a -instance MonadTransControl LoggingT where - type StT LoggingT a = StT (ReaderT Logger) a - liftWith = defaultLiftWith LoggingT runLoggingT_ - restoreT = defaultRestoreT LoggingT +-- instance (Monad m, MonadReader SpecializedLogger m) => HasLogger m where +-- getLogger = ask +-- localLogger l = local (const l) -instance (MonadBaseControl IO m, MonadIO m) => MonadBaseControl IO (LoggingT m) where - type StM (LoggingT m) a = ComposeSt LoggingT m a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM +-- | Apply logging backend locally. +applyBackend :: (IsLogBackend b, HasLogger m) => b -> m a -> m a +applyBackend b actions = do + let logger = makeLogger b + localLogger logger actions --- | Run logging monad -runLoggingT :: LoggingT m a -> Logger -> m a -runLoggingT actions logger = runReaderT (runLoggingT_ actions) logger +-- | Type class for monads that store logging context +class Monad m => HasLogContext m where + -- | Execute actions within logging context frame + withLogContext :: LogContextFrame -> m a -> m a --- | Logging function -type Logger = LogMessage -> IO () + -- | Obtain currently active logging context stack + getLogContext :: m LogContext -textFromLogStr :: ToLogStr str => str -> TL.Text -textFromLogStr str = TL.fromStrict $ TE.decodeUtf8 $ fromLogStr $ toLogStr str +-- GHC will not be able to select instance for LoggingT. +-- instance (Monad m, HasLogBackend b m) => HasLogBackend AnyLogBackend m where +-- getLogBackend = do +-- backend <- getLogBackend :: m b +-- return $ AnyLogBackend backend -instance MonadIO m => MonadLogger (LoggingT m) where - monadLoggerLog loc src level msg = - logMessage $ LogMessage level src' loc (textFromLogStr msg) () +-- | Convinience constraint synonym. +type HasLogging m = (HasLogger m, HasLogContext m) + +-- | Shortcut function to execute actions within logging context frame, +-- which contains only one variable +withLogVariable :: (HasLogContext m, F.Formatable v) + => TL.Text -- ^ Variable name + -> v -- ^ Variable value + -> m a -- ^ Actions to execute within context frame + -> m a +withLogVariable name value = + withLogContext (LogContextFrame [(name, F.Variable value)] noChange) + +-- | Compatibility instance. +instance (Monad m, MonadIO m, HasLogging m) => MonadLogger m where + monadLoggerLog loc src level msg = do + logger <- getLogger + context <- getLogContext + liftIO $ logger $ LogMessage { + lmLevel = logLevelToLevel level, + lmSource = src', + lmLocation = loc, + lmFormatString = textFromLogStr msg, + lmFormatVars = (), + lmContext = context + } where src' = splitDots $ T.unpack src + textFromLogStr :: ToLogStr str => str -> TL.Text + textFromLogStr str = TL.fromStrict $ TE.decodeUtf8 $ fromLogStr $ toLogStr str + instance F.Formatable LogStr where formatVar fmt str = F.formatVar fmt $ fromLogStr str @@ -118,9 +243,9 @@ splitDots :: String -> [String] splitDots = splitString '.' --- | Log a message -logMessage :: (MonadIO m) => LogMessage -> LoggingT m () -logMessage m = do - logger <- ask - liftIO $ logger m +-- | Log a message. This version is for monads that do not know about logging contexts. +logMessage' :: forall m. (HasLogger m, MonadIO m) => LogMessage -> m () +logMessage' msg = do + logger <- getLogger + liftIO $ logger msg