log-warper 1.2.3.1 → 1.3.0

raw patch · 7 files changed

+105/−55 lines, 7 filesdep +fmtPVP ok

version bump matches the API change (PVP)

Dependencies added: fmt

API changes (from Hackage documentation)

Files

• CHANGES.md +13/−0
• log-warper.cabal +2/−1
• src/System/Wlog/Formatter.hs +57/−37
• src/System/Wlog/Launcher.hs +13/−7
• src/System/Wlog/LoggerConfig.hs +8/−5
• src/System/Wlog/Wrapper.hs +11/−4
• test/Test/Wlog/RollingSpec.hs +1/−1

@@ -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 ===== 

@@ -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

@@ -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+-}

@@ -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.

@@ -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

@@ -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 ()

@@ -83,7 +83,7 @@ writeConcurrentLogs :: RotationParameters -> LinesToLog -> IO () writeConcurrentLogs rp@RotationParameters{..} (getNumberOfLinesToLog -> linesNum) =     bracket_-        (setupLogging $ testLoggerConfig rp)+        (setupLogging Nothing $ testLoggerConfig rp)         releaseAllHandlers         concurrentWriting   where