diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,9 @@ +1.8.11 +====== + +* Resolve LW-34 bug, which was causing improper message handling in + nonexisting loggers + 1.8.10.1 ====== diff --git a/examples/Playground.hs b/examples/Playground.hs --- a/examples/Playground.hs +++ b/examples/Playground.hs @@ -18,9 +18,10 @@ import Time (sec, threadDelay) #endif -import System.Wlog (CanLog, atLogger, defaultConfig, infoPlus, launchFromFile, launchWithConfig, - logDebug, logError, logInfo, logNotice, logWarning, ltSeverity, - modifyLoggerName, parseLoggerConfig, productionB, usingLoggerName) +import System.Wlog (CanLog, atLogger, consoleActionB, debugPlus, defaultConfig, infoPlus, + launchFromFile, launchWithConfig, logDebug, logError, logInfo, logNotice, + logWarning, ltSeverity, modifyLoggerName, parseLoggerConfig, productionB, + usingLoggerName) #if ( __GLASGOW_HASKELL__ >= 802 ) import System.Wlog (WithLoggerIO, launchSimpleLogging, logWarningWaitInf) #endif @@ -36,23 +37,34 @@ testLogging :: (CanLog m) => m () testLogging = usingLoggerName "node" $ do - logDebug "skovoroda" - logInfo "patak" - logNotice "boroda" - logWarning "haha" + logDebug "debug" + logInfo "info" + logNotice "notice" + logWarning "warning" modifyLoggerName (<> "server") $ do - logDebug "provoda" - logNotice "Ggurda" + logDebug "server-debug" + logInfo "server-info" + logNotice "server-warning" + modifyLoggerName (<> "missing") $ do + logInfo "should be in node.server" + modifyLoggerName (<> "missing") $ do + logInfo "should be in node" + logError "BARDAQ" showSomeLog :: (CanLog m, MonadIO m) => m () -showSomeLog = do - putTextLn "Other log:" - usingLoggerName "naked" $ do - logWarning "Some warning" - logDebug "Some debug" +showSomeLog = usingLoggerName "naked" $ do + logDebug "Some debug" + logInfo "Some info" + logNotice "Some notice" + logWarning "Some warning" + modifyLoggerName (<> "nested") $ do + logDebug "Some nested debug" + logInfo "Some nested info" + logNotice "Some nested notice" + logWarning "Some nested warning" main :: IO () main = do @@ -60,14 +72,21 @@ let runPlayLog = testLogging >> showSomeLog putTextLn "Default configurations with modification.." - launchWithConfig (defaultConfig "node" & atLogger "node" . ltSeverity ?~ infoPlus) + launchWithConfig (defaultConfig "node" & atLogger "node" . ltSeverity ?~ infoPlus + & atLogger "node.server" . ltSeverity ?~ debugPlus) "node" runPlayLog putTextLn "\nFrom file configurations.." launchFromFile testLoggerConfigPath "node" runPlayLog + putTextLn "\nShould be silent..." + launchWithConfig (defaultConfig "node" <> consoleActionB (\_ _ -> return ())) + "node" + runPlayLog + #if ( __GLASGOW_HASKELL__ >= 802 ) + putTextLn "\nConcurrent..." launchSimpleLogging "concurrent" concurrentActions concurrentActions :: forall m . (WithLoggerIO m, MonadBaseControl IO m) => m () 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.8.10.1 +version: 1.8.11 synopsis: Flexible, configurable, monadic and pretty logging homepage: https://github.com/serokell/log-warper license: MIT diff --git a/src/System/Wlog/IOLogger.hs b/src/System/Wlog/IOLogger.hs --- a/src/System/Wlog/IOLogger.hs +++ b/src/System/Wlog/IOLogger.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} @@ -61,7 +62,7 @@ import System.Wlog.LoggerName (LoggerName (..)) import System.Wlog.LogHandler (LogHandler (getTag), LogHandlerTag (HandlerFilelike), close, readBack) -import System.Wlog.Severity (LogRecord (..), Severities, Severity (..), debugPlus, warningPlus) +import System.Wlog.Severity (LogRecord (..), Severities, Severity (..), warningPlus) import qualified Data.Map as M @@ -117,21 +118,24 @@ liPrefix = Nothing newMVar LogInternalState {..} -{- | Given a name, return all components of it, starting from the root. +{- +Given a name, return all components of it, starting from the root. + Example return value: ->["", "MissingH", "System.Cmd.Utils", "System.Cmd.Utils.pOpen"] +λ> componentsOfName (LoggerName "a.b.c") +[LoggerName {getLoggerName = ""}, + LoggerName {getLoggerName = "a"}, + LoggerName {getLoggerName = "a.b"}, + LoggerName {getLoggerName = "a.b.c"}] -} componentsOfName :: LoggerName -> [LoggerName] componentsOfName (LoggerName name) = - rootLoggerName : (LoggerName <$> joinComp (T.splitOn "." name) "") + rootLoggerName : (LoggerName <$> joinComp (T.splitOn "." name)) where - joinComp [] _ = [] - joinComp (x:xs) "" = x : joinComp xs x - joinComp (x:xs) accum = - let newlevel = accum <> "." <> x - in newlevel : joinComp xs newlevel + joinComp :: [Text] -> [Text] + joinComp = map (T.intercalate ".") . drop 1 . inits --------------------------------------------------------------------------- -- Logging With Location @@ -156,63 +160,68 @@ -- Public Logger Interaction Support --------------------------------------------------------------------------- --- | Returns the logger for the given name. If no logger with that name --- exists, creates new loggers and any necessary parent loggers, with --- no connected handlers. +-- | Returns the logger for the given name. If no logger with that +-- name exists, creates new loggers and any necessary parent loggers, +-- with no connected handlers. getLogger :: MonadIO m => LoggerName -> m Logger getLogger lname = liftIO $ modifyMVar logInternalState $ \lt@LogInternalState{..} -> case M.lookup lname liTree of Just x -> return (lt, x) -- A logger exists; return it and leave tree Nothing -> do -- Add logger(s). Then call myself to retrieve it. - let newlt = createLoggers (componentsOfName lname) liTree + let newlt = createLoggers liTree let result = fromJust $ M.lookup lname newlt return (LogInternalState newlt liPrefix, result) where - createLoggers :: [LoggerName] -> LogTree -> LogTree - createLoggers xs lt = flipfoldl' addLoggerToTree lt xs -- Add logger to tree - - addLoggerToTree :: LoggerName -> LogTree ->LogTree - addLoggerToTree x lt = - if M.member x lt - then lt - else M.insert x (defaultLogger & lName .~ x) lt + createLoggers :: LogTree -> LogTree + createLoggers lt = foldl' addLoggerToTree lt (componentsOfName lname) - defaultLogger :: Logger - defaultLogger = Logger Nothing [] (error "log-warper has some strange code") -- ???!??! + addLoggerToTree :: LogTree -> LoggerName -> LogTree + addLoggerToTree lt x = if M.member x lt then lt else M.insert x (Logger Nothing [] x) lt -- | Returns the root logger. getRootLogger :: MonadIO m => m Logger getRootLogger = getLogger rootLoggerName -- | Handle a log request. -handle :: MonadIO m => Logger -> LogRecord -> (LogHandlerTag -> Bool) -> m () -handle l lrecord@(LR sev _) handlerFilter = do - lp <- getLoggerSeverities nm - when (sev `Set.member` lp) $ do - ph <- concatMap (view lHandlers) <$> parentLoggers nm - forM_ ph $ callHandler lrecord nm +-- +-- 1. Find the deepest logger that has non-zero handlers to handle log message. +-- 2. Validate if message severity matches this logger severity +-- 3. Handle it by all parent handlers. +handle :: forall m. MonadIO m => Logger -> LogRecord -> (LogHandlerTag -> Bool) -> m () +handle l lr@(LR sev _) handlerFilter = + traverseAndLog False =<< parentLoggers nm where nm :: LoggerName nm = view lName l - parentLoggers :: MonadIO m => LoggerName -> m [Logger] - parentLoggers = mapM getLogger . componentsOfName + -- Returns all loggers, root logger last + parentLoggers :: LoggerName -> m [Logger] + parentLoggers = fmap reverse . mapM getLogger . componentsOfName - -- Get the severity we should use. Find the first logger in the - -- tree, starting here, with a set severity. If even root doesn't - -- have one, assume "Debug". - getLoggerSeverities :: MonadIO m => LoggerName -> m Severities - getLoggerSeverities name = do - pl <- parentLoggers name - case mapMaybe (view lLevel) (l : pl) of - [] -> pure debugPlus - (x:_) -> pure x + -- Tries to log the message into handlers. sevFiltPassed variable + -- denotes the "has log message passed through the first severity + -- filter". We only apply severity filter once, the first time we + -- encounter it. + traverseAndLog :: Bool -> [Logger] -> m () + traverseAndLog sevFiltPassed lgs = whenNotNull lgs $ \(x:|xs) -> do + let doLog n = do + forM_ (x ^. lHandlers) callHandler + traverseAndLog n xs + if sevFiltPassed + then doLog sevFiltPassed + else case x ^. lLevel of + -- We haven't yet met severity filter, so we still traverse + Nothing -> doLog sevFiltPassed + -- If we didn't pass the first encountered filter check, we + -- don't proceed with logging. If we pass, we set + -- sevFiltPassed to true for next iterations. + (Just lp) -> when (sev `Set.member` lp) $ doLog True - callHandler :: MonadIO m => LogRecord -> LoggerName -> HandlerT -> m () - callHandler lr loggername (HandlerT x) = + callHandler :: HandlerT -> m () + callHandler (HandlerT x) = when (handlerFilter $ getTag x) $ - System.Wlog.LogHandler.logHandlerMessage x lr loggername + System.Wlog.LogHandler.logHandlerMessage x lr nm -- | Sets file prefix to 'LogInternalState'. setPrefix :: MonadIO m => Maybe FilePath -> m ()