diff --git a/util/src/Pos/Util/Wlog/Compatibility.hs b/util/src/Pos/Util/Wlog/Compatibility.hs index 20f185252f4..a859c9cdccd 100644 --- a/util/src/Pos/Util/Wlog/Compatibility.hs +++ b/util/src/Pos/Util/Wlog/Compatibility.hs @@ -58,7 +58,7 @@ import qualified Pos.Util.Log.Internal as Internal import Pos.Util.Log.LoggerConfig (LogHandler (..), LogSecurityLevel (..), LoggerConfig (..), defaultInteractiveConfiguration, defaultTestConfiguration, - lcLoggerTree, lhName, ltHandlers) + lcLoggerTree, lhName, ltHandlers, ltMinSeverity) import System.IO.Unsafe (unsafePerformIO) import Universum @@ -90,12 +90,17 @@ instance CanLog IO where mayEnv <- Internal.getLogEnv lh case mayEnv of Nothing -> error "logging not yet initialized. Abort." - Just env -> Log.logItem' () - (K.Namespace (T.split (=='.') name)) - env - Nothing - (Internal.sev2klog severity) - (K.logStr msg) + Just env -> do + mayConfig <- Internal.getConfig lh + case mayConfig of + Nothing -> error "no logging configuration. Abort." + Just lc -> when (severity >= lc ^. lcLoggerTree ^. ltMinSeverity) + $ Log.logItem' () + (K.Namespace (T.split (=='.') name)) + env + Nothing + (Internal.sev2klog severity) + (K.logStr msg) type WithLogger m = (CanLog m, HasLoggerName m) @@ -262,7 +267,9 @@ logItemS lhandler a ns loc sev cond msg = do let cfg = case maycfg of Nothing -> error "No Configuration for logging found. Abort." Just c -> c - liftIO $ do + let sevmin = Internal.sev2klog $ cfg ^. lcLoggerTree ^. ltMinSeverity + when (sev >= sevmin) + $ liftIO $ do item <- K.Item <$> pure (K._logEnvApp le) <*> pure (K._logEnvEnv le) diff --git a/util/test/Test/Pos/Util/WlogSpec.hs b/util/test/Test/Pos/Util/WlogSpec.hs index 08f24c5671e..cc66e5ac3b8 100644 --- a/util/test/Test/Pos/Util/WlogSpec.hs +++ b/util/test/Test/Pos/Util/WlogSpec.hs @@ -61,12 +61,13 @@ run_logging _ n n0 n1= do logWarning msg logError msg endTime <- getPOSIXTime - threadDelay $ fromIntegral (5000 * n0) + threadDelay $ fromIntegral (8000 * n0) let diffTime = nominalDiffTimeToMicroseconds (endTime - startTime) putStrLn $ " time for " ++ (show (n0*n1)) ++ " iterations: " ++ (show diffTime) lineslogged1 <- getLinesLogged let lineslogged = lineslogged1 - lineslogged0 putStrLn $ " lines logged :" ++ (show lineslogged) + threadDelay 0500000 -- wait for empty queue return (diffTime, lineslogged) where msg :: Text msg = replicate n "abcdefghijklmnopqrstuvwxyz" @@ -102,6 +103,19 @@ spec = describe "Logging" $ do lc = lc0 & lcLoggerTree .~ newlt setupLogging "test" lc + modifyMaxSuccess (const 2) $ modifyMaxSize (const 2) $ + it "change minimum severity filter for a specific context" $ + monadicIO $ do + lineslogged0 <- lift $ getLinesLogged + lift $ usingLoggerName "silent" $ do { logWarning "you won't see this!" } + lift $ threadDelay 0300000 + lift $ usingLoggerName "verbose" $ do { logWarning "now you read this!" } + lift $ threadDelay 0300000 + lineslogged1 <- lift $ getLinesLogged + let lineslogged = lineslogged1 - lineslogged0 + putStrLn $ "lines logged: " ++ (show lineslogged) + assert (lineslogged == 1) + modifyMaxSuccess (const 1) $ modifyMaxSize (const 1) $ it "demonstrate logging" $ monadicIO $ lift $ someLogging @@ -118,16 +132,3 @@ spec = describe "Logging" $ do it "lines counted as logged must be equal to how many was intended to be written" $ property prop_lines - modifyMaxSuccess (const 2) $ modifyMaxSize (const 2) $ - it "change minimum severity filter for a specific context" $ - monadicIO $ do - lineslogged0 <- lift $ getLinesLogged - lift $ usingLoggerName "silent" $ do { logWarning "you won't see this!" } - lift $ threadDelay 0300000 - lift $ usingLoggerName "verbose" $ do { logWarning "now you read this!" } - lift $ threadDelay 0300000 - lineslogged1 <- lift $ getLinesLogged - let lineslogged = lineslogged1 - lineslogged0 - putStrLn $ "lines logged: " ++ (show lineslogged) - assert (lineslogged == 1) -