diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,20 @@ +1.7.0 +===== + +* [#48](https://github.com/serokell/log-warper/issues/48): + Output for severities is now configured in config file with `termSeveritiesOut` + and `termSeveritiesErr` for writing into `stdout` and `stderr` accordingly. + Default behavior: `Errors` into `stderr`, all other into `stdout`. +* In yaml config file added new keywords for dealing with `Severities`: + 'All' -- all severities, 'X+' -- severities greater or equal to X. +* Changed .yaml format: logger severity receives set of severities (`Severities`). +* [#32](https://github.com/serokell/log-warper/issues/32): + Changed .yaml format: `LoggerTree` should be written under 'loggerTree:'. +* [#49](https://github.com/serokell/log-warper/issues/49): + Add `WithLoggerIO` constraint. +* [#50](https://github.com/serokell/log-warper/issues/50): + Add `liftLogIO` function into `CanLog` module. + 1.6.0 ===== diff --git a/examples/Playground.hs b/examples/Playground.hs --- a/examples/Playground.hs +++ b/examples/Playground.hs @@ -7,10 +7,9 @@ import Data.Monoid ((<>)) import Data.Yaml.Pretty (defConfig, encodePretty) -import System.Wlog (CanLog, Severity (Debug), buildAndSetupYamlLogging, dispatchEvents, logDebug, - logError, logInfo, logNotice, logWarning, modifyLoggerName, parseLoggerConfig, - prefixB, productionB, removeAllHandlers, runPureLog, termSeverityB, - usingLoggerName) +import System.Wlog (CanLog, buildAndSetupYamlLogging, dispatchEvents, logDebug, logError, logInfo, + logNotice, logWarning, modifyLoggerName, parseLoggerConfig, prefixB, + productionB, removeAllHandlers, runPureLog, usingLoggerName) testLoggerConfigPath :: FilePath testLoggerConfigPath = "logger-config-example.yaml" @@ -45,7 +44,7 @@ main :: IO () main = do testToJsonConfigOutput - let config = (productionB <> prefixB "logs" <> termSeverityB Debug) + let config = (productionB <> prefixB "logs") bracket_ (buildAndSetupYamlLogging config testLoggerConfigPath) removeAllHandlers 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.6.0 +version: 1.7.0 synopsis: Flexible, configurable, monadic and pretty logging homepage: https://github.com/serokell/log-warper license: MIT @@ -64,6 +64,7 @@ , transformers-base >= 0.4.4 , universum >= 0.7 , unordered-containers >= 0.2.7.1 + , vector >= 0.12 , yaml >= 0.8.20 if !os(windows) build-depends: unix 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 @@ -11,6 +11,7 @@ module System.Wlog.CanLog ( CanLog (..) , WithLogger + , WithLoggerIO -- * Logging functions , logDebug @@ -19,6 +20,8 @@ , logNotice , logWarning , logMessage + + , liftLogIO ) where import Universum @@ -29,7 +32,7 @@ import System.Wlog.HasLoggerName (HasLoggerName (..)) import System.Wlog.IOLogger (logM) import System.Wlog.LoggerName (LoggerName (..)) -import System.Wlog.LoggerNameBox (LoggerNameBox (..)) +import System.Wlog.LoggerNameBox (LoggerNameBox (..), usingLoggerName) import System.Wlog.Severity (Severity (..)) import qualified Control.Monad.RWS as RWSLazy @@ -42,6 +45,10 @@ -- but in practice we usually use them both. type WithLogger m = (CanLog m, HasLoggerName m) +-- | Type alias for constraints 'WithLogger' and 'MonadIO'. +-- It is a very common situation to use both of them together. +type WithLoggerIO m = (MonadIO m, WithLogger m) + -- | Instances of this class should explain how they add messages to their log. class Monad m => CanLog m where dispatchMessage :: LoggerName -> Severity -> Text -> m () @@ -85,3 +92,63 @@ logMessage severity t = do name <- askLoggerName dispatchMessage name severity t + +{- | It's very common situation when we need to write log messages +inside functions that work in 'IO'. + +To do so we need to configure logger name each time inside work of this function. + +@liftLogIO@ is the easiest way to deal with such kind of situations. + +==== __Usage Example__ + +We have some function + +@ +clientStart :: HostName -> .. -> IO ClientComponentMap +clientStart hostName .. = do + ... + forkIO $ routeIncoming endPoint msgs + ... +@ + +We need to log 'Error' messages in @routeIncoming@ function. +To do that we firstly need @clientStart@ to work in 'MonadIO' + +@ +clientStart :: (MonadIO m) => HostName -> .. -> m ClientComponentMap +clientStart hostName .. = do + ... + liftIO $ forkIO $ routeIncoming endPoint msgs + ... +@ + +After we added some 'logError' into @routeIncoming@ @clientStart@ should +now work in 'WithLogger'. Thus we can use 'WithLoggerIO' which is combination of 'MonadIO' and 'WithLogger'. +Taking into consideration all above +we get: + +@ +clientStart :: WithLoggerIO m => HostName -> .. -> m ClientComponentMap +clientStart hostName .. = do + ... + logName <- askLoggerName + liftIO $ forkIO $ usingLoggerName logName $ routeIncoming endPoint msgs + ... +@ + +So, here we see how useful this function can be. + +@ +clientStart :: WithLoggerIO m => HostName -> .. -> m ClientComponentMap +clientStart hostName .. = do + ... + liftLogIO forkIO $ routeIncoming endPoint msgs + ... +@ + +-} +liftLogIO :: WithLoggerIO m => (IO a -> IO b) -> LoggerNameBox IO a -> m b +liftLogIO ioFunc action = do + logName <- askLoggerName + liftIO $ ioFunc $ usingLoggerName logName $ action 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,7 +15,6 @@ -- logging system. module System.Wlog.Formatter ( stdoutFormatter - , stderrFormatter , stdoutFormatterTimeRounded , centiUtcTimeF , getRoundedTime @@ -49,7 +48,7 @@ #endif import System.Wlog.Color (colorizer) -import System.Wlog.Severity (LogRecord (..), Severity (..)) +import System.Wlog.Severity (LogRecord (..)) import qualified Data.Text as T @@ -183,11 +182,6 @@ stdoutFormatter timeF isShowTime isShowTid handle record message = do time <- getCurrentTime createLogFormatter isShowTime isShowTid timeF time handle record message - -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 stdoutFormatterTimeRounded :: (UTCTime -> Text) -> Int -> LogFormatter a stdoutFormatterTimeRounded timeF roundN handle record message = do 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 @@ -47,7 +47,7 @@ import System.Wlog.LogHandler (LogHandler (setFormatter)) import System.Wlog.LogHandler.Roller (rotationFileHandler) import System.Wlog.LogHandler.Simple (fileHandler) -import System.Wlog.Severity (Severities, debugPlus, severityPlus) +import System.Wlog.Severity (Severities, debugPlus) import System.Wlog.Terminal (initTerminalLogging) import qualified Data.HashMap.Strict as HM hiding (HashMap) @@ -67,7 +67,8 @@ customTerminalAction isShowTime isShowTid - (severityPlus <$> _lcTermSeverity) + _lcTermSeverityOut + _lcTermSeverityErr liftIO $ setPrefix _lcFilePrefix processLoggers mempty _lcTree @@ -88,10 +89,10 @@ processLoggers parent LoggerTree{..} = do -- This prevents logger output to appear in terminal unless (parent == mempty && isNothing consoleAction) $ - setSeveritiesMaybe parent (severityPlus <$> _ltSeverity) + setSeveritiesMaybe parent (_ltSeverity) forM_ _ltFiles $ \HandlerWrap{..} -> liftIO $ do - let fileSeverities = (severityPlus <$> _ltSeverity) ?: debugPlus + let fileSeverities = (_ltSeverity) ?: debugPlus let handlerPath = handlerPrefix _hwFilePath case handlerFabric of HandlerFabric fabric -> 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,7 +38,8 @@ , lcRotation , lcShowTime , lcShowTid - , lcTermSeverity + , lcTermSeverityOut + , lcTermSeverityErr , lcTree , zoomLogger @@ -51,7 +52,8 @@ , productionB , showTidB , showTimeB - , termSeverityB + , termSeveritiesOutB + , termSeveritiesErrB ) where import Universum @@ -63,17 +65,22 @@ import Data.Text (Text) import Data.Traversable (for) import Data.Word (Word64) -import Data.Yaml (FromJSON (..), ToJSON (..), Value (Object), object, (.!=), (.:), (.:?), (.=)) +import Data.Yaml (FromJSON (..), Object, Parser, ToJSON (..), Value (..), object, (.!=), (.:), + (.:?), (.=)) import Formatting (bprint, shown) import GHC.Generics (Generic) import System.FilePath (normalise) import System.Wlog.LoggerName (LoggerName) import System.Wlog.LogHandler.Simple (defaultHandleAction) -import System.Wlog.Severity (Severity) +import System.Wlog.Severity (Severities, allSeverities, debugPlus, errorPlus, infoPlus, noticePlus, + warningPlus) import qualified Data.HashMap.Strict as HM hiding (HashMap) +import qualified Data.Set as Set +import qualified Data.Text as T import qualified Data.Text.Buildable as Buildable +import qualified Data.Vector as Vector ---------------------------------------------------------------------------- -- Utilites & helpers @@ -82,6 +89,22 @@ filterObject :: [Text] -> HashMap Text a -> HashMap Text a filterObject excluded = HM.filterWithKey $ \k _ -> k `notElem` excluded +parseSeverities :: Object -> Text -> Parser (Maybe Severities) +parseSeverities o term = do + case HM.lookup term o of + Just value -> case value of + String word -> case word of + "All" -> pure $ Just allSeverities + "Debug+" -> pure $ Just debugPlus + "Info+" -> pure $ Just infoPlus + "Notice+" -> pure $ Just noticePlus + "Warning+" -> pure $ Just warningPlus + "Error+" -> pure $ Just errorPlus + _ -> fail $ T.unpack $ "Unknown severity: " <> word + Array sevs -> Just . Set.fromList . Vector.toList <$> Vector.mapM parseJSON sevs + _ -> fail "Incorrect severities format" + Nothing -> pure $ Nothing + ---------------------------------------------------------------------------- -- LoggerTree ---------------------------------------------------------------------------- @@ -102,7 +125,7 @@ data LoggerTree = LoggerTree { _ltSubloggers :: !LoggerMap , _ltFiles :: ![HandlerWrap] - , _ltSeverity :: !(Maybe Severity) + , _ltSeverity :: !(Maybe Severities) } deriving (Generic, Show) makeLenses ''LoggerTree @@ -142,7 +165,7 @@ map (\fp -> HandlerWrap fp Nothing) $ maybe [] (:[]) singleFile ++ manyFiles let _ltFiles = fileHandlers <> handlers - _ltSeverity <- o .:? "severity" + _ltSeverity <- parseSeverities o "severity" _ltSubloggers <- for (filterObject nonLoggers o) parseJSON return LoggerTree{..} @@ -189,29 +212,35 @@ -- | Logger configuration which keeps 'RotationParameters' and 'LoggerTree'. data LoggerConfig = LoggerConfig { -- | Rotation parameters for logger config. See 'System.Wlog.Roller'. - _lcRotation :: Maybe RotationParameters + _lcRotation :: Maybe RotationParameters - -- | Severity for terminal output. If @Nothing@ then 'Warning' is used. - , _lcTermSeverity :: Maybe Severity + -- | Severity for terminal `stdout` output. If @Nothing@ along + -- with '_lcTermSeverityErr' then 'Warning' and greater + -- excluding 'Error' are used. + , _lcTermSeverityOut :: Maybe Severities + -- | Severity for terminal `stderr` output. If @Nothing@ along + -- with '_lcTermSeverityOut' then 'Error' is used. + , _lcTermSeverityErr :: Maybe Severities + -- | Show time for non-error messages. -- Note that error messages always have timestamp. - , _lcShowTime :: Any + , _lcShowTime :: Any -- | Show 'ThreadId' for current logging thread. - , _lcShowTid :: Any + , _lcShowTid :: Any -- | Specifies action for printing to console. - , _lcConsoleAction :: Last (Handle -> Text -> IO ()) + , _lcConsoleAction :: Last (Handle -> Text -> IO ()) -- | Defines how to transform logger names in config. - , _lcMapper :: Endo LoggerName + , _lcMapper :: Endo LoggerName -- | Path prefix to add for each logger file - , _lcFilePrefix :: Maybe FilePath + , _lcFilePrefix :: Maybe FilePath -- | Hierarchical tree of loggers. - , _lcTree :: LoggerTree + , _lcTree :: LoggerTree } makeLenses ''LoggerConfig @@ -219,49 +248,41 @@ -- TODO: QuickCheck tests on monoid laws instance Monoid LoggerConfig where mempty = LoggerConfig - { _lcRotation = Nothing - , _lcTermSeverity = Nothing - , _lcShowTime = mempty - , _lcShowTid = mempty - , _lcConsoleAction = mempty - , _lcMapper = mempty - , _lcFilePrefix = Nothing - , _lcTree = mempty + { _lcRotation = Nothing + , _lcTermSeverityOut = Nothing + , _lcTermSeverityErr = Nothing + , _lcShowTime = mempty + , _lcShowTid = mempty + , _lcConsoleAction = mempty + , _lcMapper = mempty + , _lcFilePrefix = Nothing + , _lcTree = mempty } lc1 `mappend` lc2 = LoggerConfig - { _lcRotation = orCombiner _lcRotation - , _lcTermSeverity = orCombiner _lcTermSeverity - , _lcShowTime = andCombiner _lcShowTime - , _lcShowTid = andCombiner _lcShowTid - , _lcConsoleAction = andCombiner _lcConsoleAction - , _lcMapper = andCombiner _lcMapper - , _lcFilePrefix = orCombiner _lcFilePrefix - , _lcTree = andCombiner _lcTree + { _lcRotation = orCombiner _lcRotation + , _lcTermSeverityOut = orCombiner _lcTermSeverityOut + , _lcTermSeverityErr = orCombiner _lcTermSeverityErr + , _lcShowTime = andCombiner _lcShowTime + , _lcShowTid = andCombiner _lcShowTid + , _lcConsoleAction = andCombiner _lcConsoleAction + , _lcMapper = andCombiner _lcMapper + , _lcFilePrefix = orCombiner _lcFilePrefix + , _lcTree = andCombiner _lcTree } where orCombiner field = field lc1 <|> field lc2 andCombiner field = field lc1 <> field lc2 - -topLevelParams :: [Text] -topLevelParams = - [ "rotation" - , "termSeverity" - , "showTime" - , "showTid" - , "printOutput" - , "filePrefix" - ] - instance FromJSON LoggerConfig where parseJSON = withObject "rotation params" $ \o -> do - _lcRotation <- o .:? "rotation" - _lcTermSeverity <- o .:? "termSeverity" - _lcShowTime <- Any <$> o .:? "showTime" .!= False - _lcShowTid <- Any <$> o .:? "showTid" .!= False - _lcFilePrefix <- o .:? "filePrefix" - _lcTree <- parseJSON $ Object $ filterObject topLevelParams o + _lcRotation <- o .:? "rotation" + _lcTermSeverityOut <- parseSeverities o "termSeveritiesOut" + _lcTermSeverityErr <- parseSeverities o "termSeveritiesErr" + _lcShowTime <- Any <$> o .:? "showTime" .!= False + _lcShowTid <- Any <$> o .:? "showTid" .!= False + _lcFilePrefix <- o .:? "filePrefix" + _lcTree <- o .:? "loggerTree" .!= mempty printConsoleFlag <- o .:? "printOutput" .!= False let _lcConsoleAction = Last $ bool Nothing (Just defaultHandleAction) printConsoleFlag @@ -272,12 +293,13 @@ -- because it is used only for debugging. instance ToJSON LoggerConfig where toJSON LoggerConfig{..} = object - [ "rotation" .= _lcRotation - , "termSeverity" .= _lcTermSeverity - , "showTime" .= getAny _lcShowTime - , "showTid" .= getAny _lcShowTid - , "printOutput" .= maybe False (const True) (getLast _lcConsoleAction) - , "filePrefix" .= _lcFilePrefix + [ "rotation" .= _lcRotation + , "termSeveritiesOut" .= _lcTermSeverityOut + , "termSeveritiesErr" .= _lcTermSeverityErr + , "showTime" .= getAny _lcShowTime + , "showTid" .= getAny _lcShowTid + , "printOutput" .= maybe False (const True) (getLast _lcConsoleAction) + , "filePrefix" .= _lcFilePrefix , ("logTree", toJSON _lcTree) ] ---------------------------------------------------------------------------- @@ -285,8 +307,12 @@ ---------------------------------------------------------------------------- -- | Setup 'lcTermSeverity' to specified severity inside 'LoggerConfig'. -termSeverityB :: Severity -> LoggerConfig -termSeverityB severity = mempty { _lcTermSeverity = Just severity } +termSeveritiesOutB :: Severities -> LoggerConfig +termSeveritiesOutB severities = mempty { _lcTermSeverityOut = Just severities } + +-- | Setup 'lcTermSeverity' to specified severity inside 'LoggerConfig'. +termSeveritiesErrB :: Severities -> LoggerConfig +termSeveritiesErrB severities = mempty { _lcTermSeverityErr = Just severities } -- | Setup 'lcShowTime' to 'True' inside 'LoggerConfig'. showTimeB :: LoggerConfig diff --git a/src/System/Wlog/Terminal.hs b/src/System/Wlog/Terminal.hs --- a/src/System/Wlog/Terminal.hs +++ b/src/System/Wlog/Terminal.hs @@ -21,11 +21,11 @@ import Data.Time (UTCTime) import System.IO (Handle, stderr, stdout) -import System.Wlog.Formatter (stderrFormatter, stdoutFormatter) +import System.Wlog.Formatter (stdoutFormatter) import System.Wlog.IOLogger (rootLoggerName, setHandlers, setLevel, updateGlobalLogger) import System.Wlog.LogHandler (LogHandler (setFormatter)) import System.Wlog.LogHandler.Simple (streamHandler) -import System.Wlog.Severity (Severities, errorPlus, excludeError, warningPlus) +import System.Wlog.Severity (Severities, debugPlus, errorPlus, excludeError) -- | This function initializes global logging system for terminal output. @@ -50,23 +50,31 @@ -> Bool -- ^ Show time? -> Bool -- ^ Show ThreadId? -> Maybe Severities + -> Maybe Severities -> m () initTerminalLogging timeF customConsoleAction isShowTime isShowTid - (fromMaybe (warningPlus) -> defaultSeverity) + maybeSevOut + maybeSevErr = liftIO $ do lock <- liftIO $ newMVar () + let (severitiesOut, severitiesErr) = + case (maybeSevOut, maybeSevErr) of + (Nothing, Nothing) -> (excludeError debugPlus, errorPlus) + (Just out, Nothing) -> (out, mempty) + (Nothing, Just err) -> (mempty, err) + (Just out, Just err) -> (out, err) stdoutHandler <- setStdoutFormatter <$> - streamHandler stdout customConsoleAction lock (excludeError defaultSeverity) + streamHandler stdout customConsoleAction lock severitiesOut stderrHandler <- setStderrFormatter <$> - streamHandler stderr customConsoleAction lock errorPlus + streamHandler stderr customConsoleAction lock severitiesErr updateGlobalLogger rootLoggerName $ setHandlers [stderrHandler, stdoutHandler] updateGlobalLogger rootLoggerName $ - setLevel defaultSeverity + setLevel $ severitiesOut <> severitiesErr where setStdoutFormatter = (`setFormatter` stdoutFormatter timeF isShowTime isShowTid) - setStderrFormatter = (`setFormatter` stderrFormatter timeF isShowTid) + setStderrFormatter = (`setFormatter` stdoutFormatter timeF True isShowTid) diff --git a/test/Test/Wlog/RollingSpec.hs b/test/Test/Wlog/RollingSpec.hs --- a/test/Test/Wlog/RollingSpec.hs +++ b/test/Test/Wlog/RollingSpec.hs @@ -20,10 +20,9 @@ import Test.QuickCheck.Monadic (PropertyM, monadicIO, run) import System.Wlog (HandlerWrap (..), InvalidRotation (..), LoggerConfig (..), - RotationParameters (..), Severity (..), fromScratch, isValidRotation, - lcFilePrefix, lcRotation, lcTree, logDebug, logIndex, ltFiles, ltSeverity, - removeAllHandlers, rotationFileHandler, setupLogging, usingLoggerName, - whenExist, zoomLogger) + RotationParameters (..), debugPlus, fromScratch, isValidRotation, lcFilePrefix, + lcRotation, lcTree, logDebug, logIndex, ltFiles, ltSeverity, removeAllHandlers, + rotationFileHandler, setupLogging, usingLoggerName, whenExist, zoomLogger) spec :: Spec spec = do @@ -69,7 +68,7 @@ lcRotation ?= rotParam lcFilePrefix ?= "logs" zoom lcTree $ do - ltSeverity ?= Debug + ltSeverity ?= debugPlus zoomLogger "test" $ ltFiles .= [HandlerWrap testLogFile Nothing]