log-warper 1.3.4 → 1.4.0

raw patch · 7 files changed

+126/−93 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES.md +5/−0
• examples/Playground.hs +6/−6
• log-warper.cabal +1/−1
• src/System/Wlog/Handler/Simple.hs +55/−44
• src/System/Wlog/Launcher.hs +6/−4
• src/System/Wlog/LoggerConfig.hs +42/−29
• src/System/Wlog/Wrapper.hs +11/−9

@@ -1,3 +1,8 @@+1.4.0+=====++* Add ability to specify custom logging action.+ 1.3.4 ==== 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 $