diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for heavy-logger + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Ilya Portnov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ilya Portnov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,26 @@ +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. + +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. + * 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. + +[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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/heavy-logger.cabal b/heavy-logger.cabal new file mode 100644 --- /dev/null +++ b/heavy-logger.cabal @@ -0,0 +1,45 @@ +name: heavy-logger +version: 0.1.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. + heavy-logger is also integrated with text-format-heavy string formatting library. +license: BSD3 +license-file: LICENSE +author: Ilya Portnov +maintainer: portnov84@rambler.ru +-- copyright: +category: System +build-type: Simple +extra-source-files: ChangeLog.md +extra-doc-files: README.md +cabal-version: >=1.18 + +library + exposed-modules: System.Log.Heavy + System.Log.Heavy.Types + System.Log.Heavy.Format + System.Log.Heavy.Backends + System.Log.Heavy.Shortcuts + -- other-modules: + -- other-extensions: + build-depends: base >=4.8 && <5.0, + mtl >= 2.2.1, + transformers-base >= 0.4.4, + monad-control >= 1.0.1.0, + template-haskell >= 2.10.0, + 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 + hs-source-dirs: src + default-language: Haskell2010 + +Source-repository head + type: git + location: https://github.com/portnov/heavy-logger.git + diff --git a/src/System/Log/Heavy.hs b/src/System/Log/Heavy.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Heavy.hs @@ -0,0 +1,49 @@ +{-# 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. +-- +-- Example of usage is: +-- +-- @ +-- import System.Log.Heavy +-- import Data.Text.Format.Heavy +-- ... +-- +-- withLogging backend id $ do liftIO $ putStr "Your name? " +-- liftIO $ hFlush stdout +-- name <- liftIO $ getLine +-- logMessage $ infoMessage "name was {}" (Single name) +-- liftIO $ putStrLn $ "Hello, " ++ name +-- @ +-- +-- See also @Test.hs@. +-- +module System.Log.Heavy + ( + -- * Reexports + module System.Log.Heavy.Types, + module System.Log.Heavy.Backends, + withLogging + ) 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.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. + -> m a +withLogging (LogBackend b) = withLoggingB b + diff --git a/src/System/Log/Heavy/Backends.hs b/src/System/Log/Heavy/Backends.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Heavy/Backends.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances #-} + +module System.Log.Heavy.Backends + ( + -- $description + -- * Backends + FastLoggerSettings (..), + SyslogSettings (..), + -- * Default settings + defStdoutSettings, + defStderrSettings, + defFileSettings, + defaultSyslogSettings, + defaultSyslogFormat, + -- * Utilities for other backends implementation + checkLogLevel + ) 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 System.Log.Heavy.Types +import System.Log.Heavy.Format + +-- $description +-- +-- This module contains several implementation of logging backend. +-- A backend is some kind of target, where your messages will go. +-- Each backend has its own specific settings. +-- +-- Backends provided are: +-- +-- * Fast-logger backend. It allows to write messages to stdout, stderr or arbitrary file. +-- +-- * Syslog backend. +-- +-- * 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 + } + +-- | Default settings for fast-logger stdout output +defStdoutSettings :: FastLoggerSettings +defStdoutSettings = FastLoggerSettings defaultLogFilter defaultLogFormat (FL.LogStdout FL.defaultBufSize) + +-- | Default settings for fast-logger stderr output +defStderrSettings :: FastLoggerSettings +defStderrSettings = FastLoggerSettings defaultLogFilter 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) + 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. + } + +-- | Default settings for syslog backend +defaultSyslogSettings :: SyslogSettings +defaultSyslogSettings = SyslogSettings defaultLogFilter 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) + + 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 + +-- | 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 + } + +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 + +-- | Check if message level matches given filter. +checkLogLevel :: LogFilter -> LogMessage -> Bool +checkLogLevel fltr m = + case lookup (bestMatch (lmSource m) (map fst fltr)) fltr of + Nothing -> False + Just level -> lmLevel m >= level + 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 + diff --git a/src/System/Log/Heavy/Format.hs b/src/System/Log/Heavy/Format.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Heavy/Format.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, RecordWildCards #-} + +-- | This module contains definitions for formatting log message to write it to output. +-- +-- Log message format is defined by using @text-format-heavy@ syntax. Variables available are: +-- +-- * level - message severity level +-- +-- * source - message source (module name) +-- +-- * location - location from where message was logged (line in source file) +-- +-- * time - message time +-- +-- * message - message string itself +-- +module System.Log.Heavy.Format + ( defaultLogFormat, + formatLogMessage + ) where + +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.Maybe +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.ByteString as B +-- import Data.Attoparsec.ByteString +import System.Log.FastLogger +import qualified Data.Text.Format.Heavy as F +import qualified Data.Text.Format.Heavy.Parse as PF +import Prelude hiding (takeWhile) + +import System.Log.Heavy.Types + +-- | Default log message format. +-- Corresponds to: @{time} [{level}] {source}: {message}\\n@ +defaultLogFormat :: F.Format +defaultLogFormat = PF.parseFormat' "{time} [{level}] {source}: {message}\n" + +-- | 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 + diff --git a/src/System/Log/Heavy/Shortcuts.hs b/src/System/Log/Heavy/Shortcuts.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Heavy/Shortcuts.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances #-} + +-- | This module contains some shortcut functions that can be of use in simple usage cases. +module System.Log.Heavy.Shortcuts + ( + -- * Log a message + reportError, warning, info, debug, + -- * Creating a message + errorMessage, warnMessage, infoMessage, debugMessage + ) 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.Backends + +-- | Message stub with Info severity. +infoMessage :: F.VarContainer vars => TL.Text -> vars -> LogMessage +infoMessage fmt vars = LogMessage LevelInfo [] undefined fmt vars + +-- | Message stub with Debug severity. +debugMessage :: F.VarContainer vars => TL.Text -> vars -> LogMessage +debugMessage fmt vars = LogMessage LevelDebug [] undefined fmt vars + +-- | Message stub with Error severity. +errorMessage :: F.VarContainer vars => TL.Text -> vars -> LogMessage +errorMessage fmt vars = LogMessage LevelError [] undefined fmt vars + +-- | Message stub with Warning severity. +warnMessage :: F.VarContainer vars => TL.Text -> vars -> LogMessage +warnMessage fmt vars = LogMessage LevelWarn [] 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 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 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 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 fmt vars = logMessage $ warnMessage fmt vars + diff --git a/src/System/Log/Heavy/Types.hs b/src/System/Log/Heavy/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Log/Heavy/Types.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances #-} + +-- | This module contains generic types definition, along with some utilities. +module System.Log.Heavy.Types + ( + LogSource, LogMessage (..), LogFilter, + IsLogBackend (..), LogBackend (..), Logger, + LoggingT (LoggingT), runLoggingT, + defaultLogFilter, + splitString, splitDots, + logMessage + ) where + +import Control.Monad.Reader +import Control.Monad.Logger (MonadLogger (..), LogLevel (..)) +import Control.Monad.Base +import Control.Monad.Trans.Control +import Data.String +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 + +-- | Log message source. This is usually a list of program module names, +-- for example @[\"System\", \"Log\", \"Heavy\", \"Types\"]@. +type LogSource = [String] + +-- | Log message structure +data LogMessage = forall vars. F.VarContainer vars => LogMessage { + lmLevel :: LogLevel -- ^ 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. + } + +-- | 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)] + +-- | Default log messages filter. This says pass all messages +-- of level Info or higher. +defaultLogFilter :: LogFilter +defaultLogFilter = [([], LevelInfo)] + +-- | 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 + +-- | A container for arbitrary logging backend. +-- You usually will use this similar to: +-- +-- @ +-- getLoggingSettings :: String -> LogBackend +-- getLoggingSettings "syslog" = LogBackend defaultsyslogsettings +-- @ +data LogBackend = forall b. IsLogBackend b => LogBackend b + +-- | Logging monad transformer. +newtype LoggingT m a = LoggingT { + runLoggingT_ :: ReaderT Logger m a + } + deriving (Functor, Applicative, Monad, MonadReader Logger, 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 Logger) 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 + +-- | Run logging monad +runLoggingT :: LoggingT m a -> Logger -> m a +runLoggingT actions logger = runReaderT (runLoggingT_ actions) logger + +-- | Logging function +type Logger = LogMessage -> IO () + +textFromLogStr :: ToLogStr str => str -> TL.Text +textFromLogStr str = TL.fromStrict $ TE.decodeUtf8 $ fromLogStr $ toLogStr str + +instance MonadIO m => MonadLogger (LoggingT m) where + monadLoggerLog loc src level msg = + logMessage $ LogMessage level src' loc (textFromLogStr msg) () + where + src' = splitDots $ T.unpack src + +instance F.Formatable LogStr where + formatVar fmt str = F.formatVar fmt $ fromLogStr str + +-- | Simple implementation of splitting string by character. +splitString :: Char -> String -> [String] +splitString _ "" = [] +splitString c s = let (l, s') = break (== c) s + in l : case s' of + [] -> [] + (_:s'') -> splitString c s'' + +-- | Split string by dots +splitDots :: String -> [String] +splitDots = splitString '.' + +-- | Log a message +logMessage :: (MonadIO m) => LogMessage -> LoggingT m () +logMessage m = do + logger <- ask + liftIO $ logger m +