diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,8 @@ +1.4.0 +===== + +* Add ability to specify custom logging action. + 1.3.4 ==== diff --git a/examples/Playground.hs b/examples/Playground.hs --- a/examples/Playground.hs +++ b/examples/Playground.hs @@ -7,11 +7,11 @@ import Data.Monoid ((<>)) import Data.Yaml.Pretty (defConfig, encodePretty) -import System.Wlog (CanLog, buildAndSetupYamlLogging, dispatchEvents, - logDebug, logError, logInfo, logNotice, logWarning, - modifyLoggerName, parseLoggerConfig, prefixB, - productionB, releaseAllHandlers, runPureLog, - usingLoggerName) +import System.Wlog (CanLog, Severity (Debug), buildAndSetupYamlLogging, + dispatchEvents, logDebug, logError, logInfo, logNotice, + logWarning, modifyLoggerName, parseLoggerConfig, + prefixB, productionB, releaseAllHandlers, runPureLog, + termSeverityB, usingLoggerName) testLoggerConfigPath :: FilePath testLoggerConfigPath = "logger-config-example.yaml" @@ -46,7 +46,7 @@ main :: IO () main = do testToJsonConfigOutput - let config = (productionB <> prefixB "logs") + let config = (productionB <> prefixB "logs" <> termSeverityB Debug) bracket_ (buildAndSetupYamlLogging config testLoggerConfigPath) releaseAllHandlers 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.3.4 +version: 1.4.0 synopsis: Flexible, configurable, monadic and pretty logging homepage: https://github.com/serokell/log-warper license: MIT diff --git a/src/System/Wlog/Handler/Simple.hs b/src/System/Wlog/Handler/Simple.hs --- a/src/System/Wlog/Handler/Simple.hs +++ b/src/System/Wlog/Handler/Simple.hs @@ -17,10 +17,12 @@ -} module System.Wlog.Handler.Simple - ( streamHandler + ( GenericHandler(..) + , defaultHandleAction + + -- * Custom handlers , fileHandler - , GenericHandler(..) - , verboseStreamHandler + , streamHandler ) where import Control.Concurrent (modifyMVar_, withMVar) @@ -31,18 +33,15 @@ import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) import System.IO (Handle, IOMode (ReadWriteMode), - SeekMode (SeekFromEnd), hClose, - hFlush, hSeek) + SeekMode (SeekFromEnd), hClose, hFlush, hSeek) import Universum -import System.Wlog.Formatter (LogFormatter, nullFormatter, - simpleLogFormatter) +import System.Wlog.Formatter (LogFormatter, nullFormatter) import System.Wlog.Handler (LogHandler (..), LogHandlerTag (..)) import System.Wlog.MemoryQueue (MemoryQueue) import System.Wlog.MemoryQueue as MQ import System.Wlog.Severity (Severity (..)) - -- | A helper data type. data GenericHandler a = GenericHandler { severity :: !Severity @@ -64,39 +63,57 @@ emit sh bldr _ = (writeFunc sh) (privData sh) (toText . B.toLazyText $ bldr) close sh = (closeFunc sh) (privData sh) +-- | Default action which just prints to handle using given message. +defaultHandleAction :: Handle -> Text -> IO () +defaultHandleAction h message = + TIO.hPutStrLn h message `catch` handleWriteException + where + handleWriteException :: SomeException -> IO () + handleWriteException e = do + let errorMessage = "Error writing log message: " + <> show e <> " (original message: " <> message <> ")" + TIO.hPutStrLn h errorMessage + +-- | Creates custom write action and memory queue where write action +-- updates memory queue as well. +createWriteFuncWrapper + :: (Handle -> Text -> IO ()) + -> MVar () + -> IO ( Handle -> Text -> IO () + , MVar (MemoryQueue Text) + ) +createWriteFuncWrapper action lock = do + memoryQueue <- newMVar $ MQ.newMemoryQueue $ 2 * 1024 * 1024 -- 2 MB + + let customWriteFunc :: Handle -> Text -> IO () + customWriteFunc hdl msg = withMVar lock $ const $ do + action hdl msg + + -- Important to force the queue here, else a massive closure will + -- be retained until the queue is actually used. + modifyMVar_ memoryQueue $ \mq -> pure $! pushFront msg mq + + hFlush hdl + + return (customWriteFunc, memoryQueue) + -- | Create a stream log handler. Log messages sent to this handler -- will be sent to the stream used initially. Note that the 'close' -- method will have no effect on stream handlers; it does not actually -- close the underlying stream. -streamHandler :: Handle -> Severity -> IO (GenericHandler Handle) -streamHandler h sev = do - lock <- newMVar () - mq <- newMVar $ MQ.newMemoryQueue $ 2 * 1024 * 1024 -- 2 MB - let mywritefunc hdl msg = withMVar lock $ const $ do - writeToHandle hdl msg - -- Important to force the queue here, else a massive closure will - -- be retained until the queue is actually used. - modifyMVar_ mq $ \mq' -> pure $! pushFront msg mq' - hFlush hdl - return - GenericHandler - { severity = sev - , formatter = nullFormatter - , privData = h - , writeFunc = mywritefunc +streamHandler :: Handle + -> (Handle -> Text -> IO ()) + -> MVar () + -> Severity + -> IO (GenericHandler Handle) +streamHandler privData writeAction lock severity = do + (writeFunc, readBackBuffer) <- createWriteFuncWrapper writeAction lock + return GenericHandler + { formatter = nullFormatter , closeFunc = const $ pure () - , readBackBuffer = mq - , ghTag = HandlerOther "GenericHandler/StreamHandler" + , ghTag = HandlerOther "GenericHandler/StreamHandler" + , .. } - where - writeToHandle hdl msg = - TIO.hPutStrLn hdl msg `catch` (handleWriteException hdl msg) - handleWriteException :: Handle -> Text -> SomeException -> IO () - handleWriteException hdl msg e = - let msg' = - "Error writing log message: " <> - show e <> " (original message: " <> msg <> ")" - in TIO.hPutStrLn hdl msg' -- | Create a file log handler. Log messages sent to this handler -- will be sent to the filename specified, which will be opened in @@ -106,15 +123,9 @@ createDirectoryIfMissing True (takeDirectory fp) h <- openFile fp ReadWriteMode hSeek h SeekFromEnd 0 - sh <- streamHandler h sev + + lock <- newMVar () + sh <- streamHandler h defaultHandleAction lock sev pure $ sh { closeFunc = hClose , ghTag = HandlerFilelike fp } - --- | Like 'streamHandler', but note the priority and logger name along --- with each message. -verboseStreamHandler :: Handle -> Severity -> IO (GenericHandler Handle) -verboseStreamHandler h sev = - let fmt = simpleLogFormatter "[$loggername/$prio] $msg" - in do hndlr <- streamHandler h sev - return $ setFormatter hndlr fmt 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 @@ -32,6 +32,8 @@ , setupLogging ) where +import Universum + import Control.Error.Util ((?:)) import Control.Exception (throwIO) import qualified Data.HashMap.Strict as HM hiding (HashMap) @@ -40,7 +42,6 @@ import Data.Yaml (decodeFileEither) import System.Directory (createDirectoryIfMissing) import System.FilePath (()) -import Universum import System.Wlog.Formatter (centiUtcTimeF, stdoutFormatter, stdoutFormatterTimeRounded) @@ -64,8 +65,9 @@ setupLogging mTimeFunction LoggerConfig{..} = do liftIO $ createDirectoryIfMissing True handlerPrefix - when consoleOutput $ + whenJust consoleAction $ \customTerminalAction -> initTerminalLogging timeF + customTerminalAction isShowTime isShowTid _lcTermSeverity @@ -78,7 +80,7 @@ timeF = fromMaybe centiUtcTimeF mTimeFunction isShowTime = getAny _lcShowTime isShowTid = getAny _lcShowTid - consoleOutput = getAny _lcConsoleOutput + consoleAction = getLast _lcConsoleAction handlerFabric :: HandlerFabric handlerFabric = case _lcRotation of @@ -88,7 +90,7 @@ processLoggers :: MonadIO m => LoggerName -> LoggerTree -> m () processLoggers parent LoggerTree{..} = do -- This prevents logger output to appear in terminal - unless (parent == mempty && not consoleOutput) $ + unless (parent == mempty && isNothing consoleAction) $ setSeverityMaybe parent _ltSeverity forM_ _ltFiles $ \HandlerWrap{..} -> liftIO $ 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 @@ -33,7 +33,7 @@ , LoggerConfig (..) -- ** Lenses - , lcConsoleOutput + , lcConsoleAction , lcFilePrefix , lcMapper , lcRotation @@ -44,34 +44,37 @@ , zoomLogger -- ** Builders for 'LoggerConfig' - , consoleOutB + , consoleActionB + , customConsoleActionB , mapperB , maybePrefixB , prefixB , productionB , showTidB , showTimeB + , termSeverityB ) where import Universum -import Control.Lens (at, makeLenses, zoom, _Just) -import Control.Monad.State (put) -import Data.Aeson (withObject) -import qualified Data.HashMap.Strict as HM hiding (HashMap) -import Data.Monoid (Any (..)) -import Data.Text (Text) -import qualified Data.Text.Buildable as Buildable -import Data.Traversable (for) -import Data.Word (Word64) -import Data.Yaml (FromJSON (..), ToJSON (..), Value (Object), - object, (.!=), (.:), (.:?), (.=)) -import Formatting (bprint, shown) -import GHC.Generics (Generic) -import System.FilePath (normalise) +import Control.Lens (at, makeLenses, zoom, _Just) +import Control.Monad.State (put) +import Data.Aeson (withObject) +import qualified Data.HashMap.Strict as HM hiding (HashMap) +import Data.Monoid (Any (..)) +import Data.Text (Text) +import qualified Data.Text.Buildable as Buildable +import Data.Traversable (for) +import Data.Word (Word64) +import Data.Yaml (FromJSON (..), ToJSON (..), Value (Object), + object, (.!=), (.:), (.:?), (.=)) +import Formatting (bprint, shown) +import GHC.Generics (Generic) +import System.FilePath (normalise) -import System.Wlog.LoggerName (LoggerName) -import System.Wlog.Wrapper (Severity) +import System.Wlog.Handler.Simple (defaultHandleAction) +import System.Wlog.LoggerName (LoggerName) +import System.Wlog.Severity (Severity) ---------------------------------------------------------------------------- -- Utilites & helpers @@ -199,8 +202,8 @@ -- | Show 'ThreadId' for current logging thread. , _lcShowTid :: Any - -- | @True@ if we should also print output into console. - , _lcConsoleOutput :: Any + -- | Specifies action for printing to console. + , _lcConsoleAction :: Last (Handle -> Text -> IO ()) -- | Defines how to transform logger names in config. , _lcMapper :: Endo LoggerName @@ -221,7 +224,7 @@ , _lcTermSeverity = Nothing , _lcShowTime = mempty , _lcShowTid = mempty - , _lcConsoleOutput = mempty + , _lcConsoleAction = mempty , _lcMapper = mempty , _lcFilePrefix = Nothing , _lcTree = mempty @@ -232,7 +235,7 @@ , _lcTermSeverity = orCombiner _lcTermSeverity , _lcShowTime = andCombiner _lcShowTime , _lcShowTid = andCombiner _lcShowTid - , _lcConsoleOutput = andCombiner _lcConsoleOutput + , _lcConsoleAction = andCombiner _lcConsoleAction , _lcMapper = andCombiner _lcMapper , _lcFilePrefix = orCombiner _lcFilePrefix , _lcTree = andCombiner _lcTree @@ -258,10 +261,12 @@ _lcTermSeverity <- o .:? "termSeverity" _lcShowTime <- Any <$> o .:? "showTime" .!= False _lcShowTid <- Any <$> o .:? "showTid" .!= False - _lcConsoleOutput <- Any <$> o .:? "printOutput" .!= False _lcFilePrefix <- o .:? "filePrefix" _lcTree <- parseJSON $ Object $ filterObject topLevelParams o - let _lcMapper = mempty + + printConsoleFlag <- o .:? "printOutput" .!= False + let _lcConsoleAction = Last $ bool Nothing (Just defaultHandleAction) printConsoleFlag + let _lcMapper = mempty return LoggerConfig{..} -- | This instances violates @fromJSON . toJSON = identity@ rule but doesn't matter @@ -272,13 +277,18 @@ , "termSeverity" .= _lcTermSeverity , "showTime" .= getAny _lcShowTime , "showTid" .= getAny _lcShowTid - , "printOutput" .= getAny _lcConsoleOutput + , "printOutput" .= maybe False (const True) (getLast _lcConsoleAction) , "filePrefix" .= _lcFilePrefix , ("logTree", toJSON _lcTree) ] - +---------------------------------------------------------------------------- -- Builders for 'LoggerConfig'. +---------------------------------------------------------------------------- +-- | Setup 'lcTermSeverity' to specified severity inside 'LoggerConfig'. +termSeverityB :: Severity -> LoggerConfig +termSeverityB severity = mempty { _lcTermSeverity = Just severity } + -- | Setup 'lcShowTime' to 'True' inside 'LoggerConfig'. showTimeB :: LoggerConfig showTimeB = mempty { _lcShowTime = Any True } @@ -287,13 +297,16 @@ showTidB :: LoggerConfig showTidB = mempty { _lcShowTid = Any True } +consoleActionB :: (Handle -> Text -> IO ()) -> LoggerConfig +consoleActionB action = mempty { _lcConsoleAction = Last $ Just action } + -- | Setup 'lcConsoleOutput' inside 'LoggerConfig'. -consoleOutB :: LoggerConfig -consoleOutB = mempty { _lcConsoleOutput = Any True } +customConsoleActionB :: Maybe (Handle -> Text -> IO ()) -> LoggerConfig +customConsoleActionB action = mempty { _lcConsoleAction = Last action } -- | Adds sensible predefined set of parameters to logger. productionB :: LoggerConfig -productionB = showTimeB <> consoleOutB +productionB = showTimeB <> customConsoleActionB (Just defaultHandleAction) -- | Setup 'lcMapper' inside 'LoggerConfig'. mapperB :: (LoggerName -> LoggerName) -> LoggerConfig diff --git a/src/System/Wlog/Wrapper.hs b/src/System/Wlog/Wrapper.hs --- a/src/System/Wlog/Wrapper.hs +++ b/src/System/Wlog/Wrapper.hs @@ -23,7 +23,6 @@ import Universum -import Control.Concurrent.MVar (withMVar) import Data.Time (UTCTime) import System.IO (Handle, stderr, stdout) @@ -38,12 +37,13 @@ -- | Like `streamHandler`, but syncronized using given `MVar` as lock -- (it should be filled before this function call). -streamHandlerWithLock :: MVar () -> Handle -> Severity -> IO (GenericHandler Handle) -streamHandlerWithLock lock h sev = do - GenericHandler {..} <- streamHandler h sev - pure - GenericHandler - {writeFunc = \a s -> withMVar lock $ const $ writeFunc a s, ..} +streamHandlerWithLock :: (Handle -> Text -> IO ()) + -> MVar () + -> Handle + -> Severity + -> IO (GenericHandler Handle) +streamHandlerWithLock customTerminalAction lock handle severity = + streamHandler handle customTerminalAction lock severity -- | This function initializes global logging system for terminal output. -- At high level, it sets severity which will be used by all loggers by default, @@ -63,21 +63,23 @@ -- `setSeverity` directly. initTerminalLogging :: MonadIO m => (UTCTime -> Text) + -> (Handle -> Text -> IO ()) -> Bool -- ^ Show time? -> Bool -- ^ Show ThreadId? -> Maybe Severity -> m () initTerminalLogging timeF + customConsoleAction isShowTime isShowTid (fromMaybe Warning -> defaultSeverity) = liftIO $ do lock <- liftIO $ newMVar () stdoutHandler <- setStdoutFormatter <$> - streamHandlerWithLock lock stdout defaultSeverity + streamHandlerWithLock customConsoleAction lock stdout defaultSeverity stderrHandler <- setStderrFormatter <$> - streamHandlerWithLock lock stderr Error + streamHandlerWithLock customConsoleAction lock stderr Error updateGlobalLogger rootLoggerName $ setHandlers [stderrHandler, stdoutHandler] updateGlobalLogger rootLoggerName $