log-warper 1.6.0 → 1.7.0
raw patch · 9 files changed
+198/−86 lines, 9 filesdep +vector
Dependencies added: vector
Files
- CHANGES.md +17/−0
- examples/Playground.hs +4/−5
- log-warper.cabal +2/−1
- src/System/Wlog/CanLog.hs +68/−1
- src/System/Wlog/Formatter.hs +1/−7
- src/System/Wlog/Launcher.hs +5/−4
- src/System/Wlog/LoggerConfig.hs +82/−56
- src/System/Wlog/Terminal.hs +15/−7
- test/Test/Wlog/RollingSpec.hs +4/−5
CHANGES.md view
@@ -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 =====
examples/Playground.hs view
@@ -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
log-warper.cabal view
@@ -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
src/System/Wlog/CanLog.hs view
@@ -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
src/System/Wlog/Formatter.hs view
@@ -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
src/System/Wlog/Launcher.hs view
@@ -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
src/System/Wlog/LoggerConfig.hs view
@@ -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
src/System/Wlog/Terminal.hs view
@@ -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)
test/Test/Wlog/RollingSpec.hs view
@@ -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]