log-warper 0.5.0 → 0.5.1
raw patch · 5 files changed
+56/−16 lines, 5 files
Files
- log-warper.cabal +1/−1
- src/System/Wlog/CanLog.hs +11/−6
- src/System/Wlog/Formatter.hs +24/−4
- src/System/Wlog/Launcher.hs +11/−4
- src/System/Wlog/LoggerConfig.hs +9/−1
log-warper.cabal view
@@ -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
src/System/Wlog/CanLog.hs view
@@ -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 ()
src/System/Wlog/Formatter.hs view
@@ -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)
src/System/Wlog/Launcher.hs view
@@ -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
src/System/Wlog/LoggerConfig.hs view
@@ -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{..}