diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,9 @@ +1.8.0 +===== + +* [#55](https://github.com/serokell/log-warper/issues/55): + Return back `lcFilePrefix` field in `LoggerConfig`, rename to `lcLogsDirectory`. + 1.7.6 ===== 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.7.6 +version: 1.8.0 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 @@ -46,6 +46,7 @@ -- ** Saving Your Changes , saveGlobalLogger , updateGlobalLogger + , setPrefix , retrieveLogContent ) where @@ -54,6 +55,7 @@ import Control.Concurrent.MVar (modifyMVar, modifyMVar_, withMVar) import Control.Lens (makeLenses) import Data.Maybe (fromJust) +import System.FilePath (()) import System.IO.Unsafe (unsafePerformIO) import System.Wlog.LoggerName (LoggerName (..)) @@ -85,8 +87,9 @@ type LogTree = Map LoggerName Logger -newtype LogInternalState = LogInternalState +data LogInternalState = LogInternalState { liTree :: LogTree + , liPrefix :: Maybe FilePath } deriving (Generic) --------------------------------------------------------------------------- @@ -111,6 +114,7 @@ Logger { _lLevel = Just warningPlus , _lName = "" , _lHandlers = []} + liPrefix = Nothing newMVar $ LogInternalState {..} {- | Given a name, return all components of it, starting from the root. @@ -163,7 +167,7 @@ -- Add logger(s). Then call myself to retrieve it. let newlt = createLoggers (componentsOfName lname) liTree let result = fromJust $ M.lookup lname newlt - return (LogInternalState newlt, result) + return (LogInternalState newlt liPrefix, result) where createLoggers :: [LoggerName] -> LogTree -> LogTree createLoggers [] lt = lt -- No names to add; return tree unmodified @@ -209,6 +213,12 @@ when (handlerFilter $ getTag x) $ System.Wlog.LogHandler.logHandlerMessage x lr loggername +-- | Sets file prefix to 'LogInternalState'. +setPrefix :: MonadIO m => Maybe FilePath -> m () +setPrefix p = liftIO + $ modifyMVar_ logInternalState + $ \li -> pure $ li { liPrefix = p } + -- | Add handler to 'Logger'. Returns a new 'Logger'. addHandler :: LogHandler a => a -> Logger -> Logger addHandler h = lHandlers %~ (HandlerT h:) @@ -265,7 +275,7 @@ saveGlobalLogger :: MonadIO m => Logger -> m () saveGlobalLogger l = liftIO $ modifyMVar_ logInternalState $ \LogInternalState{..} -> - pure $ LogInternalState (M.insert (view lName l) l liTree) + pure $ LogInternalState (M.insert (view lName l) l liTree) liPrefix -- | Helps you make changes on the given logger. Takes a function -- that makes changes and writes those changes back to the global @@ -289,14 +299,15 @@ let allHandlers = M.foldr (\l r -> concat [r, view lHandlers l]) [] liTree mapM_ (\(HandlerT h) -> close h) allHandlers let newTree = map (lHandlers .~ []) liTree - return $ LogInternalState newTree + return $ LogInternalState newTree liPrefix ---------------------------------------------------------------------------- -- Retrieving logs ad-hoc ---------------------------------------------------------------------------- --- | Retrieves content of log file(s) given path. Example: there's @component.log@ --- in config, but this function will return @[component.log.122, +-- | Retrieves content of log file(s) given path (w/o '_lcFilePrefix', +-- as specified in your config). Example: there's @component.log@ in +-- config, but this function will return @[component.log.122, -- component.log.123]@ if you want to. Content is file lines newest -- first. -- @@ -306,13 +317,14 @@ retrieveLogContent :: (MonadIO m) => FilePath -> Maybe Int -> m [Text] retrieveLogContent filePath linesNum = liftIO $ withMVar logInternalState $ \LogInternalState{..} -> do + let filePathFull = fromMaybe "" liPrefix filePath let appropriateHandlers = - filter (\(HandlerT h) -> getTag h == HandlerFilelike filePath) $ + filter (\(HandlerT h) -> getTag h == HandlerFilelike filePathFull) $ concatMap _lHandlers $ M.elems liTree let takeMaybe = maybe identity take linesNum case appropriateHandlers of [HandlerT h] -> liftIO $ readBack h 12345 -- all of them - [] -> takeMaybe . reverse . T.lines <$> TIO.readFile filePath + [] -> takeMaybe . reverse . T.lines <$> TIO.readFile filePathFull xs -> error $ "Found more than one (" <> show (length xs) <> "handle with the same filePath tag, impossible." 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 @@ -42,9 +42,12 @@ import Control.Lens (zoom, (.=), (?=)) import Data.Time (UTCTime) import Data.Yaml (decodeFileEither) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) import System.Wlog.Formatter (centiUtcTimeF, stdoutFormatter, stdoutFormatterTimeRounded) -import System.Wlog.IOLogger (addHandler, removeAllHandlers, setSeveritiesMaybe, updateGlobalLogger) +import System.Wlog.IOLogger (addHandler, removeAllHandlers, setPrefix, setSeveritiesMaybe, + updateGlobalLogger) import System.Wlog.LoggerConfig (HandlerWrap (..), LoggerConfig (..), LoggerTree (..), fromScratch, lcConsoleAction, lcShowTime, lcTree, ltSeverity, productionB, zoomLogger) @@ -66,6 +69,8 @@ -- See 'LoggerConfig' for more details. setupLogging :: MonadIO m => Maybe (UTCTime -> Text) -> LoggerConfig -> m () setupLogging mTimeFunction LoggerConfig{..} = do + liftIO $ createDirectoryIfMissing True handlerPrefix + whenJust consoleAction $ \customTerminalAction -> initTerminalLogging timeF customTerminalAction @@ -74,8 +79,10 @@ _lcTermSeverityOut _lcTermSeverityErr + liftIO $ setPrefix _lcLogsDirectory processLoggers mempty _lcTree where + handlerPrefix = _lcLogsDirectory ?: "." logMapper = appEndo _lcMapper timeF = fromMaybe centiUtcTimeF mTimeFunction isShowTime = getAny _lcShowTime @@ -95,7 +102,7 @@ forM_ _ltFiles $ \HandlerWrap{..} -> liftIO $ do let fileSeverities = (_ltSeverity) ?: debugPlus - let handlerPath = _hwFilePath + let handlerPath = handlerPrefix _hwFilePath case handlerFabric of HandlerFabric fabric -> do let handlerCreator = fabric handlerPath fileSeverities @@ -169,6 +176,7 @@ - Error _ltFiles: [] termSeveritiesOut: null +filePrefix: null termSeveritiesErr: null @ 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 @@ -33,6 +33,7 @@ -- ** Lenses , lcConsoleAction + , lcLogsDirectory , lcMapper , lcRotation , lcShowTime @@ -46,6 +47,8 @@ , consoleActionB , customConsoleActionB , mapperB + , maybeLogsDirB + , logsDirB , productionB , showTidB , showTimeB @@ -241,6 +244,11 @@ -- | Defines how to transform logger names in config. , _lcMapper :: Endo LoggerName + -- | Specifies directory for log files. This can be useful to avoid + -- prefixes if you have a lot of loggers. Another use case: different logger + -- directories on different platforms. + , _lcLogsDirectory :: Maybe FilePath + -- | Hierarchical tree of loggers. , _lcTree :: LoggerTree } @@ -256,6 +264,7 @@ , _lcShowTid = andCombiner _lcShowTid , _lcConsoleAction = andCombiner _lcConsoleAction , _lcMapper = andCombiner _lcMapper + , _lcLogsDirectory = orCombiner _lcLogsDirectory , _lcTree = andCombiner _lcTree } where @@ -273,6 +282,7 @@ , _lcShowTid = mempty , _lcConsoleAction = mempty , _lcMapper = mempty + , _lcLogsDirectory = Nothing , _lcTree = mempty } @@ -285,6 +295,7 @@ _lcTermSeverityErr <- parseSeverities o "termSeveritiesErr" _lcShowTime <- Any <$> o .:? "showTime" .!= False _lcShowTid <- Any <$> o .:? "showTid" .!= False + _lcLogsDirectory <- o .:? "filePrefix" -- TODO: this field should be named "logsDirectory" but we keep previous name for backwards compatibility _lcTree <- o .:? "loggerTree" .!= mempty printConsoleFlag <- o .:? "printOutput" .!= False @@ -302,6 +313,7 @@ , "showTime" .= getAny _lcShowTime , "showTid" .= getAny _lcShowTid , "printOutput" .= maybe False (const True) (getLast _lcConsoleAction) + , "filePrefix" .= _lcLogsDirectory , ("logTree", toJSON _lcTree) ] ---------------------------------------------------------------------------- @@ -338,3 +350,11 @@ -- | Setup 'lcMapper' inside 'LoggerConfig'. mapperB :: (LoggerName -> LoggerName) -> LoggerConfig mapperB loggerNameMapper = mempty { _lcMapper = Endo loggerNameMapper } + +-- | Setup 'lcLogsDirectory' inside 'LoggerConfig' to optional prefix. +maybeLogsDirB :: Maybe FilePath -> LoggerConfig +maybeLogsDirB prefix = mempty { _lcLogsDirectory = prefix } + +-- | Setup 'lcLogsDirectory' inside 'LoggerConfig' to specific prefix. +logsDirB :: FilePath -> LoggerConfig +logsDirB = maybeLogsDirB . Just 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,9 +20,10 @@ import Test.QuickCheck.Monadic (PropertyM, monadicIO, run) import System.Wlog (HandlerWrap (..), InvalidRotation (..), LoggerConfig (..), - RotationParameters (..), debugPlus, fromScratch, isValidRotation, lcRotation, - lcTree, logDebug, logIndex, ltFiles, ltSeverity, removeAllHandlers, - rotationFileHandler, setupLogging, usingLoggerName, whenExist, zoomLogger) + RotationParameters (..), debugPlus, fromScratch, isValidRotation, + lcLogsDirectory, lcRotation, lcTree, logDebug, logIndex, ltFiles, ltSeverity, + removeAllHandlers, rotationFileHandler, setupLogging, usingLoggerName, + whenExist, zoomLogger) spec :: Spec spec = do @@ -61,11 +62,12 @@ arbitrary = LinesToLog <$> choose (1, 500) testLogFile :: FilePath -testLogFile = "logs/patak.log" +testLogFile = "patak.log" testLoggerConfig :: RotationParameters -> LoggerConfig testLoggerConfig rotParam = fromScratch $ do - lcRotation ?= rotParam + lcRotation ?= rotParam + lcLogsDirectory ?= "logs" zoom lcTree $ do ltSeverity ?= debugPlus zoomLogger "test" $