diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,16 @@ +1.2.4 +===== + +* Add ability to specify time format for logs. +* Some space leaks elimination: + + The `MemoryQueue` has been partially reworked to get rid of the "inline" State manipulation; + + Strings have been dropped almost everywhere in favour of `Text`; + + A `LogFormatter` has been reworked to yield a `IO Builder`; + + `replaceVarM` has been reworked to be pure _and_ to work with builders rather than plain Text/Strings; + + The pure logger has been reworked to use strict's `StateT` instead of WriterT; + + The pure logger have been polished to drop instances which required the `UndecidableInstances` pragma; + + The `Sized` instance for `Text` has been reworked and multiplied by a constant factor of 16 (see below). + 1.2.3 ===== diff --git a/log-warper.cabal b/log-warper.cabal --- a/log-warper.cabal +++ b/log-warper.cabal @@ -1,5 +1,5 @@ name: log-warper -version: 1.2.3.1 +version: 1.3.0 synopsis: Flexible, configurable, monadic and pretty logging homepage: https://github.com/serokell/log-warper license: MIT @@ -46,6 +46,7 @@ , exceptions >= 0.8.3 , extra >= 1.4.10 , filepath >= 1.4.1 + , fmt >= 0.5.0.0 , formatting >= 6.2.2 , hashable >= 1.2.4.0 , lens >= 4.14 diff --git a/src/System/Wlog/Formatter.hs b/src/System/Wlog/Formatter.hs --- a/src/System/Wlog/Formatter.hs +++ b/src/System/Wlog/Formatter.hs @@ -15,11 +15,10 @@ -- Please see "System.WLog.Logger" for extensive documentation on the -- logging system. module System.Wlog.Formatter - ( formatLogMessage - , formatLogMessageColors - , stdoutFormatter + ( stdoutFormatter , stderrFormatter , stdoutFormatterTimeRounded + , centiUtcTimeF , getRoundedTime -- * Taken from @hslogger@. @@ -30,15 +29,18 @@ , varFormatter ) where +import Universum + import Control.Concurrent (myThreadId) import Data.Monoid (mconcat) import qualified Data.Text as T +import Data.Text.Lazy.Builder as B import Data.Time (formatTime, getCurrentTime, getZonedTime) import Data.Time.Clock (UTCTime (..)) import Data.Time.Format (FormatTime) -import Data.Text.Lazy.Builder as B -import Formatting (Format, sformat, shown, stext, (%)) -import Universum +import Fmt (fmt, padRightF, (+|), (|+), (|++|)) +import Fmt.Time (dateDashF, hmsF, subsecondF, tzNameF) + #ifndef mingw32_HOST_OS import System.Posix.Process (getProcessID) #endif @@ -49,9 +51,7 @@ #endif import System.Wlog.Color (colorizer) -import System.Wlog.LoggerName (LoggerName, loggerNameF) -import System.Wlog.Severity (LogRecord(..), Severity (..)) - +import System.Wlog.Severity (LogRecord (..), Severity (..)) ---------------------------------------------------------------------------- -- Basic formatting functionality (initially taken from hslogger) @@ -159,11 +159,16 @@ -- Log-warper functionality ---------------------------------------------------------------------------- -timeFmt :: Text -timeFmt = "[$time] " - -timeFmtStdout :: Bool -> Text -timeFmtStdout = bool mempty timeFmt +-- | Formats UTC time in next format: "%Y-%m-%d %H:%M:%S%Q %Z" +-- but %Q part show only in centiseconds (always 2 digits). +centiUtcTimeF :: UTCTime -> Text +centiUtcTimeF t = + dateDashF t |+ " " + +| hmsF t |++| + centiSecondF t |+ " " + +| tzNameF t |+ "" + where + centiSecondF = padRightF 3 '0' . T.take 3 . fmt . subsecondF getRoundedTime :: Int -> IO UTCTime getRoundedTime roundN = do @@ -174,34 +179,48 @@ roundBy :: (Num a, Integral a) => a -> a roundBy x = let y = x `div` fromIntegral roundN in y * fromIntegral roundN -stderrFormatter :: Bool -> LogFormatter a -stderrFormatter isShowTid = simpleLogFormatter $ - mconcat $! [colorizer Error $ "[$loggername:$prio" <> tid <> "] ", timeFmt, "$msg"] - where - tid = if isShowTid then ":$tid" else "" +stdoutFormatter :: (UTCTime -> Text) -> Bool -> Bool -> LogFormatter a +stdoutFormatter timeF isShowTime isShowTid handle record message = do + time <- getCurrentTime + createLogFormatter isShowTime isShowTid timeF time handle record message -stdoutFmt :: Severity -> Bool -> Bool -> Text -stdoutFmt pr isShowTime isShowTid = mconcat $! - [colorizer pr $ "[$loggername:$prio" <> tid <> "] ", timeFmtStdout isShowTime, "$msg"] - where - tid = if isShowTid then ":$tid" else mempty +stderrFormatter :: (UTCTime -> Text) -> Bool -> LogFormatter a +stderrFormatter timeF isShowTid handle (LR _ x) message = do + time <- getCurrentTime + createLogFormatter True isShowTid timeF time handle (LR Error x) message -stdoutFormatter :: Bool -> Bool -> LogFormatter a -stdoutFormatter isShowTime isShowTid handle r@(LR pr _) = - simpleLogFormatter (stdoutFmt pr isShowTime isShowTid) handle r +stdoutFormatterTimeRounded :: (UTCTime -> Text) -> Int -> LogFormatter a +stdoutFormatterTimeRounded timeF roundN handle record message = do + time <- getRoundedTime roundN + createLogFormatter True True timeF time handle record message -stdoutFormatterTimeRounded :: Int -> LogFormatter a -stdoutFormatterTimeRounded roundN a r@(LR pr _) s = do - t <- getRoundedTime roundN - simpleLogFormatter (fmt t) a r s +createLogFormatter + :: Bool + -> Bool + -> (UTCTime -> Text) + -> UTCTime + -> LogFormatter a +createLogFormatter + isShowTime + isShowTid + timeF + time + handle + record@(LR priority _) + = + simpleLogFormatter format handle record where - fmt time = mconcat $! - [ colorizer pr "[$loggername:$prio:$tid]" - , " [" - , T.pack $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S %Z" time - , "] $msg"] + format = mconcat $! + [ colorizer priority $ "[$loggername:$prio" <> tidShower <> "] " + , timeShower + , "$msg" + ] --- TODO: do we need coloring here? + timeShower, tidShower :: Text + timeShower = if isShowTime then "[" <> timeF time <> "] " else mempty + tidShower = if isShowTid then ":$tid" else mempty + +{- TODO: not used anymore, but probably should formatLogMessage :: LoggerName -> Severity -> UTCTime -> Text -> Text formatLogMessage = sformat ("["%loggerNameF%":"%shown%"] ["%utcTimeF%"] "%stext) where @@ -216,3 +235,4 @@ prefix = sformat ("["%loggerNameF%":"%shown%"] ["%utcTimeF%"]") lname severity time utcTimeF :: Format r (UTCTime -> r) utcTimeF = shown +-} diff --git a/src/System/Wlog/Launcher.hs b/src/System/Wlog/Launcher.hs --- a/src/System/Wlog/Launcher.hs +++ b/src/System/Wlog/Launcher.hs @@ -36,12 +36,14 @@ import Control.Exception (throwIO) import qualified Data.HashMap.Strict as HM hiding (HashMap) import qualified Data.Text as T +import Data.Time (UTCTime) import Data.Yaml (decodeFileEither) import System.Directory (createDirectoryIfMissing) import System.FilePath (()) import Universum -import System.Wlog.Formatter (stdoutFormatter, stdoutFormatterTimeRounded) +import System.Wlog.Formatter (centiUtcTimeF, stdoutFormatter, + stdoutFormatterTimeRounded) import System.Wlog.Handler (LogHandler (setFormatter)) import System.Wlog.Handler.Roller (rotationFileHandler) import System.Wlog.Handler.Simple (fileHandler) @@ -58,18 +60,22 @@ -- | This function traverses 'LoggerConfig' initializing all subloggers -- with 'Severity' and redirecting output in file handlers. -- See 'LoggerConfig' for more details. -setupLogging :: MonadIO m => LoggerConfig -> m () -setupLogging LoggerConfig{..} = do +setupLogging :: MonadIO m => Maybe (UTCTime -> Text) -> LoggerConfig -> m () +setupLogging mTimeFunction LoggerConfig{..} = do liftIO $ createDirectoryIfMissing True handlerPrefix when consoleOutput $ - initTerminalLogging isShowTime isShowTid _lcTermSeverity + initTerminalLogging timeF + isShowTime + isShowTid + _lcTermSeverity liftIO $ setPrefix _lcFilePrefix processLoggers mempty _lcTree where handlerPrefix = _lcFilePrefix ?: "." logMapper = appEndo _lcMapper + timeF = fromMaybe centiUtcTimeF mTimeFunction isShowTime = getAny _lcShowTime isShowTid = getAny _lcShowTid consoleOutput = getAny _lcConsoleOutput @@ -91,8 +97,8 @@ case handlerFabric of HandlerFabric fabric -> do let handlerCreator = fabric handlerPath fileSeverity - let defFmt = (`setFormatter` stdoutFormatter isShowTime isShowTid) - let roundFmt r = (`setFormatter` stdoutFormatterTimeRounded r) + let defFmt = (`setFormatter` stdoutFormatter timeF isShowTime isShowTid) + let roundFmt r = (`setFormatter` stdoutFormatterTimeRounded timeF r) let fmt = maybe defFmt roundFmt _hwRounding thisLoggerHandler <- fmt <$> handlerCreator updateGlobalLogger (loggerName parent) $ addHandler thisLoggerHandler @@ -112,7 +118,7 @@ buildAndSetupYamlLogging configBuilder loggerConfigPath = do cfg@LoggerConfig{..} <- parseLoggerConfig loggerConfigPath let builtConfig = cfg <> configBuilder - setupLogging builtConfig + setupLogging Nothing builtConfig -- | Initialize logger hierarchy from configuration file. -- See this module description. diff --git a/src/System/Wlog/LoggerConfig.hs b/src/System/Wlog/LoggerConfig.hs --- a/src/System/Wlog/LoggerConfig.hs +++ b/src/System/Wlog/LoggerConfig.hs @@ -46,6 +46,7 @@ -- ** Builders for 'LoggerConfig' , consoleOutB , mapperB + , maybePrefixB , prefixB , productionB , showTidB @@ -80,7 +81,6 @@ filterObject :: [Text] -> HashMap Text a -> HashMap Text a filterObject excluded = HM.filterWithKey $ \k _ -> k `notElem` excluded - ---------------------------------------------------------------------------- -- LoggerTree ---------------------------------------------------------------------------- @@ -106,7 +106,6 @@ makeLenses ''LoggerTree - -- TODO: QuickCheck tests on monoid laws instance Monoid LoggerTree where mempty = LoggerTree @@ -225,7 +224,7 @@ , _lcShowTid = mempty , _lcConsoleOutput = mempty , _lcMapper = mempty - , _lcFilePrefix = mempty + , _lcFilePrefix = Nothing , _lcTree = mempty } @@ -295,6 +294,10 @@ mapperB :: (LoggerName -> LoggerName) -> LoggerConfig mapperB loggerNameMapper = mempty { _lcMapper = Endo loggerNameMapper } --- | Setup 'lcFilePrefix' inside 'LoggerConfig'. +-- | Setup 'lcFilePrefix' inside 'LoggerConfig' to optional prefix. +maybePrefixB :: Maybe FilePath -> LoggerConfig +maybePrefixB prefix = mempty { _lcFilePrefix = prefix } + +-- | Setup 'lcFilePrefix' inside 'LoggerConfig' to specific prefix. prefixB :: FilePath -> LoggerConfig -prefixB filePrefix = mempty { _lcFilePrefix = Just filePrefix } +prefixB = maybePrefixB . Just diff --git a/src/System/Wlog/Wrapper.hs b/src/System/Wlog/Wrapper.hs --- a/src/System/Wlog/Wrapper.hs +++ b/src/System/Wlog/Wrapper.hs @@ -24,6 +24,7 @@ import Universum import Control.Concurrent.MVar (withMVar) +import Data.Time (UTCTime) import System.IO (Handle, stderr, stdout) import System.Wlog.Formatter (stderrFormatter, stdoutFormatter) @@ -61,11 +62,17 @@ -- 3. Applies `setSeverity` to given loggers. It can be done later using -- `setSeverity` directly. initTerminalLogging :: MonadIO m - => Bool -- ^ Show time? + => (UTCTime -> Text) + -> Bool -- ^ Show time? -> Bool -- ^ Show ThreadId? -> Maybe Severity -> m () -initTerminalLogging isShowTime isShowTid (fromMaybe Warning -> defaultSeverity) = liftIO $ do +initTerminalLogging + timeF + isShowTime + isShowTid + (fromMaybe Warning -> defaultSeverity) + = liftIO $ do lock <- liftIO $ newMVar () -- We set Debug here, to allow all messages by stdout handler. -- They will be filtered by loggers. @@ -78,8 +85,8 @@ updateGlobalLogger rootLoggerName $ setLevel defaultSeverity where - setStdoutFormatter = (`setFormatter` stdoutFormatter isShowTime isShowTid) - setStderrFormatter = (`setFormatter` stderrFormatter isShowTid) + setStdoutFormatter = (`setFormatter` stdoutFormatter timeF isShowTime isShowTid) + setStderrFormatter = (`setFormatter` stderrFormatter timeF isShowTid) -- | Set severity for given logger. By default parent's severity is used. setSeverity :: MonadIO m => LoggerName -> Severity -> m () diff --git a/test/Test/Wlog/RollingSpec.hs b/test/Test/Wlog/RollingSpec.hs --- a/test/Test/Wlog/RollingSpec.hs +++ b/test/Test/Wlog/RollingSpec.hs @@ -83,7 +83,7 @@ writeConcurrentLogs :: RotationParameters -> LinesToLog -> IO () writeConcurrentLogs rp@RotationParameters{..} (getNumberOfLinesToLog -> linesNum) = bracket_ - (setupLogging $ testLoggerConfig rp) + (setupLogging Nothing $ testLoggerConfig rp) releaseAllHandlers concurrentWriting where