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: 0.5.0 +version: 0.5.1 synopsis: Flexible, configurable, monadic and pretty logging homepage: https://github.com/serokell/log-warper license: MIT diff --git a/src/System/Wlog/CanLog.hs b/src/System/Wlog/CanLog.hs --- a/src/System/Wlog/CanLog.hs +++ b/src/System/Wlog/CanLog.hs @@ -57,7 +57,7 @@ import Universum -import System.Wlog.Formatter (formatLogMessageColors) +import System.Wlog.Formatter (formatLogMessageColors, getRoundedTime) import System.Wlog.LoggerName (LoggerName (..)) import System.Wlog.LoggerNameBox (HasLoggerName (..), LoggerNameBox (..)) import System.Wlog.MemoryQueue (MemoryQueue) @@ -87,14 +87,14 @@ -- TODO: dirty hack to have in-memory logs. Maybe will be refactored -- later. Maybe not. -memoryLogs :: MVar (Maybe LogMemoryQueue) +memoryLogs :: MVar (Maybe (LogMemoryQueue,Maybe Int)) memoryLogs = unsafePerformIO $ newMVar Nothing {-# NOINLINE memoryLogs #-} -- | Retrieves memory logs in reversed order (newest are head). readMemoryLogs :: (MonadIO m) => m [Text] readMemoryLogs = do - liftIO (readMVar memoryLogs) <&> maybe (pure []) MQ.toList + liftIO (readMVar memoryLogs) <&> maybe (pure []) (MQ.toList . fst) instance CanLog IO where dispatchMessage @@ -165,7 +165,12 @@ name <- getLoggerName dispatchMessage name severity t !() <- pure $ unsafePerformIO $ do - curTime <- getCurrentTime - let formatted = formatLogMessageColors name severity curTime t - modifyMVar_ memoryLogs (pure . (MQ.pushFront formatted <$>)) + let formatted r = do + curTime <- maybe getCurrentTime getRoundedTime r + pure $ formatLogMessageColors name severity curTime t + let modif _ Nothing = pure Nothing + modif x (Just s) = Just <$> x s + modifyMVar_ memoryLogs $ modif $ \(q,rv) -> do + f <- formatted rv + pure $ (MQ.pushFront f q, rv) pure () 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,12 +15,15 @@ , formatLogMessageColors , setStderrFormatter , setStdoutFormatter + , stdoutFormatterTimeRounded + , getRoundedTime ) where import Data.Monoid (mconcat) import Data.String (IsString) import Data.Text (Text, pack, unpack) -import Data.Time.Clock (UTCTime) +import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Data.Time.Format (defaultTimeLocale, formatTime) import Formatting (Format, sformat, shown, stext, (%)) import System.Log.Formatter (LogFormatter, simpleLogFormatter) @@ -37,10 +40,17 @@ timeFmt = "[$time] " timeFmtStdout :: IsString s => Bool -> s -timeFmtStdout isShowTime = if isShowTime - then timeFmt - else "" +timeFmtStdout = bool "" timeFmt +getRoundedTime :: Int -> IO UTCTime +getRoundedTime roundN = do + UTCTime{..} <- liftIO $ getCurrentTime + let newSec = fromIntegral $ roundBy (round $ toRational utctDayTime :: Int) + pure $ UTCTime { utctDayTime = newSec, .. } + where + roundBy :: (Num a, Integral a) => a -> a + roundBy x = let y = x `div` fromIntegral roundN in y * fromIntegral roundN + stderrFormatter :: LogFormatter a stderrFormatter = simpleLogFormatter $ @@ -53,6 +63,16 @@ stdoutFormatter :: Bool -> LogFormatter a stdoutFormatter isShowTime handle r@(pr, _) = simpleLogFormatter (stdoutFmt pr isShowTime) handle r + +stdoutFormatterTimeRounded :: Int -> LogFormatter a +stdoutFormatterTimeRounded roundN a r@(pr,_) s = do + t <- getRoundedTime roundN + simpleLogFormatter (fmt t) a r s + where + fmt time = mconcat $ + [ colorizer pr "[$loggername:$prio:$tid] [" + , formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S %Z" time + , "] $msg"] setStdoutFormatter :: LogHandler h => Bool -> h -> h setStdoutFormatter isShowTime = (`setFormatter` stdoutFormatter isShowTime) 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 @@ -45,6 +45,7 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.HashMap.Strict as HM hiding (HashMap) +import Data.List (isSuffixOf) import Data.Monoid ((<>)) import Data.Text (unpack) import Data.Yaml (decodeFileEither) @@ -52,12 +53,13 @@ import System.Directory (createDirectoryIfMissing) import System.FilePath (()) import System.Log (Priority) -import System.Log.Handler (LogHandler) +import System.Log.Handler (LogHandler (setFormatter)) import System.Log.Handler.Simple (fileHandler) import System.Log.Logger (addHandler, updateGlobalLogger) import System.Wlog.CanLog (memoryLogs) -import System.Wlog.Formatter (setStdoutFormatter) +import System.Wlog.Formatter (setStdoutFormatter, + stdoutFormatterTimeRounded) import System.Wlog.LoggerConfig (LoggerConfig (..), LoggerTree (..)) import System.Wlog.LoggerName (LoggerName (..)) import System.Wlog.MemoryQueue (newMemoryQueue) @@ -79,7 +81,7 @@ whenJust _lcMemModeLimit $ \limit -> do putText "Initializing logs" let cpj = const . pure . Just -- just for lulz - liftIO $ modifyMVar_ memoryLogs $ cpj $ newMemoryQueue limit + liftIO $ modifyMVar_ memoryLogs $ cpj $ (newMemoryQueue limit, _lcRoundVal) processLoggers mempty _lcTree where handlerPrefix = _lcFilePrefix ?: "." @@ -104,7 +106,12 @@ case handlerFabric of HandlerFabric fabric -> do let handlerCreator = fabric handlerPath filePriority - thisLoggerHandler <- setStdoutFormatter isShowTime <$> handlerCreator + let defFmt = setStdoutFormatter isShowTime + let roundFmt r = (`setFormatter` stdoutFormatterTimeRounded r) + let fmt = maybe defFmt (\r -> if ".pub" `isSuffixOf` fileName + then roundFmt r + else defFmt) _lcRoundVal + thisLoggerHandler <- fmt <$> handlerCreator updateGlobalLogger (loggerName parent) $ addHandler thisLoggerHandler for_ (HM.toList _ltSubloggers) $ \(name, loggerConfig) -> do 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 @@ -38,6 +38,7 @@ , lcShowTime , lcTermSeverity , lcTree + , lcRoundVal , zoomLogger -- ** Builders for 'LoggerConfig' @@ -183,6 +184,9 @@ -- | Hierarchical tree of loggers. , _lcTree :: LoggerTree + + -- | If rounding is enabled, to how many secs to round. + , _lcRoundVal :: Maybe Int } makeLenses ''LoggerConfig @@ -198,6 +202,7 @@ , _lcFilePrefix = mempty , _lcMemModeLimit = Nothing , _lcTree = mempty + , _lcRoundVal = Nothing } lc1 `mappend` lc2 = LoggerConfig @@ -209,10 +214,12 @@ , _lcFilePrefix = _lcFilePrefix lc1 <|> _lcFilePrefix lc2 , _lcMemModeLimit = _lcMemModeLimit lc1 <|> _lcMemModeLimit lc2 , _lcTree = _lcTree lc1 <> _lcTree lc2 + , _lcRoundVal = _lcRoundVal lc1 `max` _lcRoundVal lc2 } topLevelParams :: [Text] -topLevelParams = ["rotation", "showTime", "printOutput", "filePrefix", "memModeLimit"] +topLevelParams = + ["rotation", "showTime", "printOutput", "filePrefix", "memModeLimit"] instance FromJSON LoggerConfig where parseJSON = withObject "rotation params" $ \o -> do @@ -223,6 +230,7 @@ _lcFilePrefix <- o .:? "filePrefix" _lcMemModeLimit <- o .:? "memModeLimit" _lcTree <- parseJSON $ Object $ filterObject topLevelParams o + _lcRoundVal <- o .:? "roundTime" let _lcMapper = mempty return LoggerConfig{..}