log-warper 1.0.4 → 1.1.0

raw patch · 17 files changed

+376/−323 lines, 17 filesdep −bytestringdep ~universumPVP ok

version bump matches the API change (PVP)

Dependencies removed: bytestring

Dependency ranges changed: universum

API changes (from Hackage documentation)

Files

• examples/Playground.hs +25/−13
• log-warper.cabal +8/−12
• src/System/Wlog.hs +6/−2
• src/System/Wlog/CanLog.hs +0/−33
• src/System/Wlog/Handler.hs +19/−7
• src/System/Wlog/Handler/Roller.hs +119/−0
• src/System/Wlog/Handler/Simple.hs +27/−19
• src/System/Wlog/Handler/Syslog.hs +3/−2
• src/System/Wlog/Launcher.hs +8/−26
• src/System/Wlog/Logger.hs +114/−57
• src/System/Wlog/LoggerConfig.hs +30/−25
• src/System/Wlog/LoggerName.hs +1/−0
• src/System/Wlog/LoggerNameBox.hs +1/−0
• src/System/Wlog/MemoryQueue.hs +2/−4
• src/System/Wlog/Roller.hs +0/−106
• src/System/Wlog/Wrapper.hs +4/−9
• test/Test/Wlog/RollingSpec.hs +9/−8

@@ -2,16 +2,26 @@  module Main where -import           Control.Exception (bracket_)+import           Universum -import           Data.Monoid       ((<>))-import qualified Data.Text         as T (pack)+import           Data.Monoid      ((<>))+import           Data.Yaml.Pretty (defConfig, encodePretty) -import           System.Wlog       (CanLog, buildAndSetupYamlLogging, dispatchEvents,-                                    logDebug, logError, logInfo, logNotice, logWarning,-                                    modifyLoggerName, prefixB, productionB,-                                    releaseAllHandlers, runPureLog, usingLoggerName)+import           System.Wlog      (CanLog, buildAndSetupYamlLogging, dispatchEvents,+                                   logDebug, logError, logInfo, logNotice, logWarning,+                                   modifyLoggerName, parseLoggerConfig, prefixB,+                                   productionB, releaseAllHandlers, runPureLog,+                                   usingLoggerName) +testLoggerConfigPath :: FilePath+testLoggerConfigPath = "logger-config-example.yaml"++testToJsonConfigOutput :: MonadIO m => m ()+testToJsonConfigOutput = do+    cfg             <- parseLoggerConfig testLoggerConfigPath+    let builtConfig  = cfg <> productionB <> prefixB "logs"+    putStrLn $ encodePretty defConfig builtConfig+ testLogging :: (CanLog m) => m () testLogging = usingLoggerName "node" $ do     logDebug   "skovoroda"@@ -28,13 +38,15 @@ showPureLog :: IO () showPureLog = do     (res, pureLog) <- runPureLog testLogging-    putStrLn "Pure log:"+    putText "Pure log:"     usingLoggerName "naked" $ do-        logWarning $ "Pure log for result = " <> (T.pack $ show res) <> ":"+        logWarning $ "Pure log for result = " <> show res <> ":"         dispatchEvents pureLog  main :: IO ()-main = bracket_-           (buildAndSetupYamlLogging (productionB <> prefixB "logs") "logger-config-example.yaml")-           releaseAllHandlers-           (testLogging >> showPureLog)+main = do+    testToJsonConfigOutput+    bracket_+        (buildAndSetupYamlLogging (productionB <> prefixB "logs") testLoggerConfigPath)+        releaseAllHandlers+        (testLogging >> showPureLog)

@@ -1,22 +1,18 @@ name:                log-warper-version:             1.0.4+version:             1.1.0 synopsis:            Flexible, configurable, monadic and pretty logging homepage:            https://github.com/serokell/log-warper license:             MIT license-file:        LICENSE author:              Serokell maintainer:          Serokell <hi@serokell.io>-copyright:           2016-2016 Serokell+copyright:           2016-2017 Serokell category:            Interfaces stability:           experimental build-type:          Simple cabal-version:       >=1.18 description:-    This package contains nice wrapper around hslogger library.--Flag PatakDebugSkovorodaBARDAQ-    default:     False-    description: Enable debug support+    This package implements nice and featureful wrapper around hslogger library.  library   exposed-modules:     System.Wlog@@ -24,6 +20,7 @@                        System.Wlog.FileUtils                        System.Wlog.Formatter                        System.Wlog.Handler+                       System.Wlog.Handler.Roller                        System.Wlog.Handler.Simple                        System.Wlog.Handler.Syslog                        System.Wlog.Launcher@@ -31,7 +28,6 @@                        System.Wlog.LoggerConfig                        System.Wlog.LoggerName                        System.Wlog.LoggerNameBox-                       System.Wlog.Roller                        System.Wlog.Severity                        System.Wlog.Wrapper @@ -41,7 +37,6 @@   build-depends:       aeson                >= 0.11.2.1                      , ansi-terminal        >= 0.6.2.3                      , base                 >= 4.7 && < 5-                     , bytestring           >= 0.10.8.1                      , containers           >= 0.5.7.0                      , directory            >= 1.2.6.2                      , dlist                >= 0.8.0.2@@ -76,13 +71,11 @@   default-extensions:  GeneralizedNewtypeDeriving                        DeriveDataTypeable                        DeriveGeneric+                       NoImplicitPrelude                        OverloadedStrings                        TypeApplications                        RecordWildCards -  if flag(PatakDebugSkovorodaBARDAQ)-      cpp-options:     -DPatakDebugSkovorodaBARDAQ- executable play-log   main-is:             Playground.hs @@ -90,6 +83,8 @@                      , exceptions >= 0.8.2.1                      , log-warper                      , text       >= 1.2.2.1+                     , universum  >= 0.3+                     , yaml       >= 0.8.20    hs-source-dirs:      examples   default-language:    Haskell2010@@ -98,6 +93,7 @@   default-extensions:  GeneralizedNewtypeDeriving                        DeriveDataTypeable                        DeriveGeneric+                       NoImplicitPrelude                        OverloadedStrings                        TypeApplications                        RecordWildCards

@@ -14,23 +14,27 @@ module System.Wlog        ( module System.Wlog.CanLog        , module System.Wlog.FileUtils+       , module System.Wlog.Handler.Roller+       , module System.Wlog.Handler.Simple+       , module System.Wlog.Handler.Syslog        , module System.Wlog.Launcher        , module System.Wlog.Logger        , module System.Wlog.LoggerConfig        , module System.Wlog.LoggerName        , module System.Wlog.LoggerNameBox-       , module System.Wlog.Roller        , module System.Wlog.Severity        , module System.Wlog.Wrapper        ) where  import           System.Wlog.CanLog import           System.Wlog.FileUtils+import           System.Wlog.Handler.Roller+import           System.Wlog.Handler.Simple+import           System.Wlog.Handler.Syslog import           System.Wlog.Launcher import           System.Wlog.Logger import           System.Wlog.LoggerConfig import           System.Wlog.LoggerName import           System.Wlog.LoggerNameBox-import           System.Wlog.Roller import           System.Wlog.Severity import           System.Wlog.Wrapper

@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns          #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DefaultSignatures     #-} {-# LANGUAGE FlexibleInstances     #-}@@ -17,8 +16,6 @@ module System.Wlog.CanLog        ( CanLog (..)        , WithLogger-       , memoryLogs-       , readMemoryLogs           -- * Pure logging manipulation        , PureLogger (..)@@ -40,7 +37,6 @@        , logMessage        ) where -import           Control.Concurrent         (modifyMVar_) import           Control.Monad.Base         (MonadBase) import           Control.Monad.Except       (ExceptT, MonadError) import           Control.Monad.Morph        (MFunctor (..))@@ -49,20 +45,14 @@ import qualified Control.Monad.State.Strict as StateStrict import           Control.Monad.Trans        (MonadTrans (lift)) import           Control.Monad.Writer       (MonadWriter (tell), WriterT (runWriterT))- import qualified Data.DList                 as DL (DList) import           Data.SafeCopy              (base, deriveSafeCopySimple)-import           Data.Time                  (getCurrentTime)-import           System.IO.Unsafe           (unsafePerformIO) import           Universum -import           System.Wlog.Formatter      (formatLogMessageColors, getRoundedTime) import           System.Wlog.Logger         (logM) import           System.Wlog.LoggerName     (LoggerName (..)) import           System.Wlog.LoggerNameBox  (HasLoggerName (..), LoggerNameBox (..),                                              usingLoggerName)-import           System.Wlog.MemoryQueue    (MemoryQueue)-import qualified System.Wlog.MemoryQueue    as MQ import           System.Wlog.Severity       (Severity (..))  @@ -84,19 +74,6 @@                             -> t n ()     dispatchMessage name sev t = lift $ dispatchMessage name sev t -type LogMemoryQueue = MemoryQueue Text---- TODO: dirty hack to have in-memory logs. Maybe will be refactored--- later.  Maybe not.-memoryLogs :: MVar (Maybe (LogMemoryQueue,Maybe Int))-memoryLogs = unsafePerformIO $ newMVar Nothing-{-# NOINLINE memoryLogs #-}---- | Retrieves memory logs in reversed order (newest are head).-readMemoryLogs :: (MonadIO m) => m [Text]-readMemoryLogs = do-    liftIO (readMVar memoryLogs) <&> maybe (pure []) (MQ.toList . fst)- instance CanLog IO where     dispatchMessage (loggerName -> name) prior msg = logM name prior msg @@ -211,13 +188,3 @@ logMessage severity t = do     name <- getLoggerName     dispatchMessage name severity t-    !() <- pure $ unsafePerformIO $ do-        let formatted r = do-                curTime <- maybe getCurrentTime getRoundedTime r-                pure $ formatLogMessageColors name severity curTime t-        let modif _ Nothing  = pure Nothing-            modif x (Just s) = Just <$> x s-        modifyMVar_ memoryLogs $ modif $ \(q,rv) -> do-            f <- formatted rv-            pure $ (MQ.pushFront f q, rv)-    pure ()

@@ -22,18 +22,26 @@ -} module System.Wlog.Handler        ( -- * Basic Types-         LogHandler(..)+         LogHandlerTag(..)+       , LogHandler(..)        ) where  import           System.Wlog.Formatter (LogFormatter, nullFormatter) import           System.Wlog.Severity  (LogRecord, Severity)+import           Universum +-- | Tag identifying handlers.+data LogHandlerTag+    = HandlerFilelike FilePath+    | HandlerOther String+    deriving (Show, Eq)+ -- | This is the base class for the various log handlers.  They should -- all adhere to this class. class LogHandler a where     -- TODO it should be data/type family like in 'System.Exception'-    -- | Tag of handler. Is arbitrary. Made for identication.-    getTag :: a -> String+    -- | Tag of handler. Is arbitrary. Made for identification.+    getTag :: a -> LogHandlerTag      -- | Sets the log level. 'handle' will drop items beneath this     -- level.@@ -51,14 +59,18 @@     -- given by the most recent call to 'setLevel'.     handle :: a -> LogRecord -> String -> IO ()     handle h (pri, msg) logname =-        if pri >= (getLevel h)-        then do formattedMsg <- (getFormatter h) h (pri,msg) logname-                emit h (pri, formattedMsg) logname-        else return ()+        when (pri >= (getLevel h)) $ do+            formattedMsg <- (getFormatter h) h (pri,msg) logname+            emit h (pri, formattedMsg) logname      -- | Forces an event to be logged regardless of     -- the configured level.     emit :: a -> LogRecord -> String -> IO ()++    -- | Read back from logger (e.g. file), newest first. You specify+    -- the number of (newest) logging entries. Logger can return @pure+    -- []@ if this behaviour can't be emulated or store buffer.+    readBack :: a -> Int -> IO [Text]      -- | Closes the logging system, causing it to close     -- any open files, etc.

@@ -0,0 +1,119 @@+-- | Custom implementation of 'LogHandler' with log rotation support.++module System.Wlog.Handler.Roller+       ( InvalidRotation (..)+       , RollerHandler   (..)+       , logIndex+       , rotationFileHandler+       ) where++import           Control.Concurrent         (modifyMVar, modifyMVar_, withMVar)+import qualified Data.Text                  as T+import qualified Data.Text.IO               as TIO+import           Formatting                 (sformat, shown, (%))+import           Universum++import           System.Directory           (removeFile, renameFile)+import           System.FilePath            ((<.>))+import           System.IO                  (Handle, IOMode (ReadWriteMode),+                                             SeekMode (AbsoluteSeek, SeekFromEnd), hClose,+                                             hFileSize, hFlush, hSeek)+import           System.Wlog.FileUtils      (whenExist)+import           System.Wlog.Formatter      (LogFormatter, nullFormatter)+import           System.Wlog.Handler        (LogHandler (..),+                                             LogHandlerTag (HandlerFilelike))+import           System.Wlog.Handler.Simple (GenericHandler (..), fileHandler)+import           System.Wlog.LoggerConfig   (RotationParameters (..), isValidRotation)+import           System.Wlog.Severity       (Severity (..))++-- | Similar to 'GenericHandler'. But holds file 'Handle' inside+-- mutable variable ('MVar') to be able to rotate loggers.+data RollerHandler = RollerHandler+    { rhSeverity    :: !Severity+    , rhFormatter   :: !(LogFormatter RollerHandler)+    , rhFileHandle  :: !(MVar Handle)+    , rhWriteAction :: !(Handle -> Text -> IO ())+    , rhCloseAction :: !(Handle -> IO ())+    , rhFileName    :: !FilePath+    }++instance LogHandler RollerHandler where+    getTag rh         = HandlerFilelike $ rhFileName rh+    setLevel     rh p = rh { rhSeverity  = p }+    setFormatter rh f = rh { rhFormatter = f }+    getLevel          = rhSeverity+    getFormatter      = rhFormatter+    readBack          = rollerReadback++    emit rh (_, msg) _      = rhWriteAction rh (error "Handler is used internally") msg+    close RollerHandler{..} = withMVar rhFileHandle rhCloseAction++data InvalidRotation = InvalidRotation !Text+    deriving (Show, Eq)++instance Exception InvalidRotation++logIndex :: FilePath -> Int -> FilePath+logIndex handlerPath i = handlerPath <.> show i++rollerReadback :: RollerHandler -> Int -> IO [Text]+rollerReadback RollerHandler{..} logsNum = do+    modifyMVar rhFileHandle $ \h -> do+        hFlush h+        hSeek h AbsoluteSeek 0+        contents <- T.lines <$> TIO.hGetContents h+        hClose h+        h' <- openFile rhFileName ReadWriteMode+        hSeek h' SeekFromEnd 0+        pure (h', take logsNum $ reverse contents)++-- TODO: correct exceptions handling here is too smart for me+rollerWriting+    :: RotationParameters+    -> FilePath+    -> (Handle -> Text -> IO ())+    -> MVar Handle+    -> Handle+    -> Text+    -> IO ()+rollerWriting RotationParameters{..} handlerPath loggingAction varHandle _ msg =+    modifyMVar_ varHandle $ \landle -> do+        loggingAction landle msg+        logFileSize <- fromIntegral <$> hFileSize landle+        if logFileSize < rpLogLimit+        then return landle+         -- otherwise should rename all files and create new handle putting in MVar+        else do+            hClose landle+            let lastIndex = fromIntegral $ rpKeepFiles - 1+            for_ [lastIndex - 1,lastIndex - 2 .. 0] $ \i -> do+                let oldLogFile = logIndex handlerPath i+                let newLogFile = logIndex handlerPath (i + 1)+                whenExist oldLogFile $ (`renameFile` newLogFile)+            let zeroIndex = logIndex handlerPath 0+            renameFile handlerPath zeroIndex+            let lastLogFile = logIndex handlerPath lastIndex+            whenExist lastLogFile removeFile+            h <- openFile handlerPath ReadWriteMode+            hSeek h SeekFromEnd 0+            pure h++-- | Create rotation logging handler.+rotationFileHandler+    :: MonadIO m+    => RotationParameters+    -> FilePath+    -> Severity+    -> m RollerHandler+rotationFileHandler rp@RotationParameters{..} _ _+    | not $ isValidRotation rp = liftIO $ throwM $ InvalidRotation $+      sformat ("Rotation parameters must be positive: "%shown) rp+rotationFileHandler rp@RotationParameters{..} handlerPath rhSeverity = liftIO $ do+    GenericHandler{..} <- fileHandler handlerPath rhSeverity+    rhFileHandle       <- newMVar privData+    let rhWriteAction   = rollerWriting rp handlerPath writeFunc rhFileHandle+    pure RollerHandler { rhFormatter   = nullFormatter+                       , rhCloseAction = closeFunc+                       , rhFileName = handlerPath+                       , ..+                       }

@@ -23,35 +23,39 @@        , verboseStreamHandler        ) where -import           Control.Concurrent    (withMVar)-import           Control.Exception     (SomeException)-import           Data.Maybe            (fromMaybe)-import qualified Data.Text.IO          as TIO-import           Data.Typeable         (Typeable)-import           System.IO             (hClose, hFlush)+import           Control.Concurrent      (withMVar)+import           Control.Exception       (SomeException)+import qualified Data.Text.IO            as TIO+import           Data.Typeable           (Typeable)+import           System.IO               (Handle, IOMode (ReadWriteMode),+                                          SeekMode (SeekFromEnd), hClose, hFlush, hSeek) import           Universum -import           System.Wlog.Formatter (LogFormatter, nullFormatter, simpleLogFormatter)-import           System.Wlog.Handler   (LogHandler (..))-import           System.Wlog.Severity  (Severity (..))+import           System.Wlog.Formatter   (LogFormatter, nullFormatter, simpleLogFormatter)+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-    , formatter :: LogFormatter (GenericHandler a)-    , privData  :: a-    , writeFunc :: a -> Text -> IO ()-    , closeFunc :: a -> IO ()-    , ghTag     :: Maybe String+    { severity       :: !Severity+    , formatter      :: !(LogFormatter (GenericHandler a))+    , privData       :: !a+    , writeFunc      :: !(a -> Text -> IO ())+    , closeFunc      :: !(a -> IO ())+    , readBackBuffer :: !(MemoryQueue Text)+    , ghTag          :: !LogHandlerTag     } deriving Typeable  instance Typeable a => LogHandler (GenericHandler a) where-    getTag = fromMaybe "GenericHandler" . ghTag+    getTag = ghTag     setLevel sh s = sh {severity = s}     getLevel sh = severity sh     setFormatter sh f = sh{formatter = f}     getFormatter sh = formatter sh+    readBack sh i = pure $ take i . reverse $ MQ.toList $ readBackBuffer sh     emit sh (_,msg) _ = (writeFunc sh) (privData sh) msg     close sh = (closeFunc sh) (privData sh) @@ -71,7 +75,8 @@         , privData = h         , writeFunc = mywritefunc         , closeFunc = const $ pure ()-        , ghTag = Just "streamHandler"+        , readBackBuffer = MQ.newMemoryQueue $ 2 * 1024 * 1024 -- 2 MB+        , ghTag = HandlerOther "GenericHandler/StreamHandler"         }   where     writeToHandle hdl msg =@@ -88,9 +93,12 @@ -- Append mode.  Calling 'close' on the handler will close the file. fileHandler :: FilePath -> Severity -> IO (GenericHandler Handle) fileHandler fp sev = do-    h <- openFile fp AppendMode+    h <- openFile fp ReadWriteMode+    hSeek h SeekFromEnd 0     sh <- streamHandler h sev-    return (sh {closeFunc = hClose, ghTag = Just ("fileHandler:" ++ fp)})+    pure $ sh { closeFunc = hClose+              , ghTag = HandlerFilelike fp+              }  -- | Like 'streamHandler', but note the priority and logger name along -- with each message.

@@ -65,7 +65,7 @@ import           Universum                 hiding (Option, identity)  import           System.Wlog.Formatter     (LogFormatter, varFormatter)-import           System.Wlog.Handler       (LogHandler (..))+import           System.Wlog.Handler       (LogHandler (..), LogHandlerTag (HandlerOther)) import           System.Wlog.Severity      (Severity (..))  @@ -263,11 +263,12 @@   instance LogHandler SyslogHandler where-    getTag = const "SyslogHandlerTag"+    getTag = const $ HandlerOther "SyslogHandlerTag"     setLevel sh p = sh{priority = p}     getLevel sh = priority sh     setFormatter sh f = sh{formatter = f}     getFormatter sh = formatter sh+    readBack _ _ = pure []     emit sh (prio, msg) _ = do       when (elem PERROR (options sh)) (TIO.hPutStrLn stderr msg)       pidPart <- getPidPart

@@ -32,30 +32,23 @@        , setupLogging        ) where -#if PatakDebugSkovorodaBARDAQ-import qualified Data.ByteString.Char8      as BS (putStrLn)-import           Data.Yaml.Pretty           (defConfig, encodePretty)-#endif-import           Control.Concurrent         (modifyMVar_) import           Control.Error.Util         ((?:)) import           Control.Exception          (throwIO) import qualified Data.HashMap.Strict        as HM hiding (HashMap)-import           Data.List                  (isSuffixOf) import qualified Data.Text                  as T import           Data.Yaml                  (decodeFileEither) import           System.Directory           (createDirectoryIfMissing) import           System.FilePath            ((</>)) import           Universum -import           System.Wlog.CanLog         (memoryLogs) import           System.Wlog.Formatter      (stdoutFormatter, stdoutFormatterTimeRounded) import           System.Wlog.Handler        (LogHandler (setFormatter))+import           System.Wlog.Handler.Roller (rotationFileHandler) import           System.Wlog.Handler.Simple (fileHandler)-import           System.Wlog.Logger         (addHandler, updateGlobalLogger)-import           System.Wlog.LoggerConfig   (LoggerConfig (..), LoggerTree (..))+import           System.Wlog.Logger         (addHandler, setPrefix, updateGlobalLogger)+import           System.Wlog.LoggerConfig   (HandlerWrap (..), LoggerConfig (..),+                                             LoggerTree (..)) import           System.Wlog.LoggerName     (LoggerName (..))-import           System.Wlog.MemoryQueue    (newMemoryQueue)-import           System.Wlog.Roller         (rotationFileHandler) import           System.Wlog.Wrapper        (Severity (Debug), initTerminalLogging,                                              setSeverityMaybe) @@ -69,11 +62,7 @@ setupLogging LoggerConfig{..} = do     liftIO $ createDirectoryIfMissing True handlerPrefix     when consoleOutput $ initTerminalLogging isShowTime _lcTermSeverity-    -- TODO: use lifted version here-    whenJust _lcMemModeLimit $ \limit -> do-        putText "Initializing logs"-        let cpj = const . pure . Just -- just for lulz-        liftIO $ modifyMVar_ memoryLogs $ cpj $ (newMemoryQueue limit, _lcRoundVal)+    liftIO $ setPrefix _lcFilePrefix     processLoggers mempty _lcTree   where     handlerPrefix = _lcFilePrefix ?: "."@@ -92,17 +81,15 @@         unless (parent == mempty && not consoleOutput) $             setSeverityMaybe parent _ltSeverity -        forM_ _ltFiles $ \fileName -> liftIO $ do+        forM_ _ltFiles $ \HandlerWrap{..} -> liftIO $ do             let fileSeverity   = _ltSeverity ?: Debug-            let handlerPath    = handlerPrefix </> fileName+            let handlerPath    = handlerPrefix </> _hwFilePath             case handlerFabric of                 HandlerFabric fabric -> do                     let handlerCreator = fabric handlerPath fileSeverity                     let defFmt = (`setFormatter` stdoutFormatter isShowTime)                     let roundFmt r = (`setFormatter` stdoutFormatterTimeRounded r)-                    let fmt = maybe defFmt (\r -> if ".pub" `isSuffixOf` fileName-                                                  then roundFmt r-                                                  else defFmt) _lcRoundVal+                    let fmt = maybe defFmt roundFmt _hwRounding                     thisLoggerHandler <- fmt <$> handlerCreator                     updateGlobalLogger (loggerName parent) $ addHandler thisLoggerHandler @@ -121,11 +108,6 @@ buildAndSetupYamlLogging configBuilder loggerConfigPath = do     cfg@LoggerConfig{..} <- parseLoggerConfig loggerConfigPath     let builtConfig       = cfg <> configBuilder--#if PatakDebugSkovorodaBARDAQ-    liftIO $ BS.putStrLn $ encodePretty defConfig builtConfig-#endif-     setupLogging builtConfig  -- | Initialize logger hierarchy from configuration file.

@@ -1,5 +1,8 @@ {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiWayIf                #-} {-# LANGUAGE NoImplicitPrelude         #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE TupleSections             #-}  {- |    Module     : System.Log.Logger@@ -47,19 +50,27 @@          -- ** Saving Your Changes        , saveGlobalLogger        , updateGlobalLogger+       , setPrefix+       , retrieveLogContent        ) where -import           Control.Concurrent.MVar    (modifyMVar, modifyMVar_)+import           Control.Concurrent.MVar    (modifyMVar, modifyMVar_, withMVar)+import           Control.Lens               (makeLenses) import           Data.List                  (isPrefixOf)-import qualified Data.Map                   as Map+import qualified Data.Map                   as M import           Data.Maybe                 (fromJust)---import           System.IO+import qualified Data.Text                  as T+import qualified Data.Text.IO               as TIO+import           System.FilePath            ((</>)) import           System.IO.Unsafe           (unsafePerformIO)-import           System.Wlog.Handler        (LogHandler (getTag), close)+import           Universum++import           System.Wlog.Handler        (LogHandler (getTag),+                                             LogHandlerTag (HandlerFilelike), close,+                                             readBack) import qualified System.Wlog.Handler        (handle) import           System.Wlog.Handler.Simple (streamHandler) import           System.Wlog.Severity       (LogRecord, Severity (..))-import           Universum   ---------------------------------------------------------------------------@@ -69,13 +80,20 @@ data HandlerT = forall a. LogHandler a => HandlerT a  data Logger = Logger-    { level    :: Maybe Severity-    , handlers :: [HandlerT]-    , name     :: String-    }+    { _lLevel    :: Maybe Severity+    , _lHandlers :: [HandlerT]+    , _lName     :: String+    } deriving (Generic) -type LogTree = Map.Map String Logger+makeLenses ''Logger +type LogTree = Map String Logger++data LogInternalState = LogInternalState+    { liTree   :: Map String Logger+    , liPrefix :: Maybe FilePath+    } deriving (Generic)+ --------------------------------------------------------------------------- -- Utilities ---------------------------------------------------------------------------@@ -89,17 +107,18 @@ -- Logger Tree Storage --------------------------------------------------------------------------- --- | The log tree.  Initialize it with a default root logger--- and (FIXME) a logger for MissingH itself.-{-# NOINLINE logTree #-}-logTree :: MVar LogTree+-- | The log tree. Initialize it with a default root logger.+{-# NOINLINE logInternalState #-}+logInternalState :: MVar LogInternalState -- note: only kick up tree if handled locally-logTree = unsafePerformIO $ do+logInternalState = unsafePerformIO $ do     h <- streamHandler stderr Debug-    newMVar $-        Map.singleton rootLoggerName $-        Logger {level = Just Warning, name = "", handlers = [HandlerT h]}-+    let liTree = M.singleton rootLoggerName $+                 Logger { _lLevel = Just Warning+                        , _lName = ""+                        , _lHandlers = [HandlerT h]}+        liPrefix = Nothing+    newMVar $ LogInternalState {..}  {- | Given a name, return all components of it, starting from the root. Example return value:@@ -109,12 +128,13 @@ -} componentsOfName :: String -> [String] componentsOfName name =-    let joinComp [] _ = []-        joinComp (x:xs) [] = x : joinComp xs x-        joinComp (x:xs) accum =-            let newlevel = accum ++ "." ++ x-            in newlevel : joinComp xs newlevel-    in rootLoggerName : joinComp (split "." name) []+    rootLoggerName : joinComp (split "." name) []+  where+    joinComp [] _ = []+    joinComp (x:xs) [] = x : joinComp xs x+    joinComp (x:xs) accum =+        let newlevel = accum ++ "." ++ x+        in newlevel : joinComp xs newlevel  --------------------------------------------------------------------------- -- Logging With Location@@ -123,13 +143,13 @@ -- | Log a message using the given logger at a given priority. logM :: String     -- ^ Name of the logger to use      -> Severity   -- ^ Severity of this message-     -> Text     -- ^ The log text itself+     -> Text       -- ^ The log text itself      -> IO () logM logname pri msg = do     l <- getLogger logname     logL l pri msg -logMCond :: String -> Severity -> Text -> (String -> Bool) -> IO ()+logMCond :: String -> Severity -> Text -> (LogHandlerTag -> Bool) -> IO () logMCond logname sev msg cond = do     l <- getLogger logname     logLCond l sev msg cond@@ -162,7 +182,7 @@          -> IO () warningM s = logM s Warning -{- | Log a message at 'ERROR' priority -}+{- | Log a message at 'Error' priority -} errorM :: String                       -- ^ Logger name        -> Text                         -- ^ Log message        -> IO ()@@ -176,22 +196,23 @@ -- exists, creates new loggers and any necessary parent loggers, with -- no connected handlers. getLogger :: String -> IO Logger-getLogger lname = modifyMVar logTree $ \lt -> case Map.lookup lname lt of-    Just x ->  return (lt, x) -- A logger exists; return it and leave tree-    Nothing -> do-        -- Add logger(s).  Then call myself to retrieve it.-        let newlt = createLoggers (componentsOfName lname) lt-        let result = fromJust $ Map.lookup lname newlt-        return (newlt, result)+getLogger lname = modifyMVar logInternalState $ \lt@LogInternalState{..} ->+    case M.lookup lname liTree of+      Just x ->  return (lt, x) -- A logger exists; return it and leave tree+      Nothing -> do+          -- 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 liPrefix, result)   where     createLoggers :: [String] -> LogTree -> LogTree     createLoggers [] lt = lt -- No names to add; return tree unmodified     createLoggers (x:xs) lt = -- Add logger to tree-        if Map.member x lt-           then createLoggers xs lt-           else createLoggers xs-                    (Map.insert x (defaultLogger {name=x}) lt)-    defaultLogger = Logger Nothing [] undefined -- ???!??!+        createLoggers xs $+            if M.member x lt+               then lt+               else M.insert x (defaultLogger & lName .~ x) lt+    defaultLogger = Logger Nothing [] (error "log-warper has some strange code") -- ???!??!  -- | Returns the root logger. getRootLogger :: IO Logger@@ -202,19 +223,19 @@ logL l pri msg = handle l (pri, msg) (const True)  -- | Logs a message with condition.-logLCond :: Logger -> Severity -> Text -> (String -> Bool) -> IO ()+logLCond :: Logger -> Severity -> Text -> (LogHandlerTag -> Bool) -> IO () logLCond l pri msg = handle l (pri, msg)  -- | Handle a log request.-handle :: Logger -> LogRecord -> (String -> Bool) -> IO ()+handle :: Logger -> LogRecord -> (LogHandlerTag -> Bool) -> IO () handle l lrecord@(sev, _) handlerFilter = do     lp <- getLoggerSeverity nm     if sev >= lp then do-        ph <- concatMap handlers <$> parentLoggers nm+        ph <- concatMap (view lHandlers) <$> parentLoggers nm         forM_ ph $ callHandler lrecord nm     else return ()   where-    nm = name l+    nm = view lName l     parentLoggers :: String -> IO [Logger]     parentLoggers = mapM getLogger . componentsOfName     -- Get the severity we should use. Find the first logger in the@@ -223,7 +244,7 @@     getLoggerSeverity :: String -> IO Severity     getLoggerSeverity name = do         pl <- parentLoggers name-        case catMaybes . map level $ (l : pl) of+        case catMaybes . map (view lLevel) $ (l : pl) of             []    -> pure Debug             (x:_) -> pure x     callHandler :: LogRecord -> String -> HandlerT -> IO ()@@ -231,10 +252,13 @@         when (handlerFilter $ getTag x) $         System.Wlog.Handler.handle x lr loggername +-- | Sets file prefix to 'LogInternalState'.+setPrefix :: Maybe FilePath -> IO ()+setPrefix p = modifyMVar_ logInternalState $ \li -> pure $ li { liPrefix = p }  -- | Add handler to 'Logger'.  Returns a new 'Logger'. addHandler :: LogHandler a => a -> Logger -> Logger-addHandler h l= l{handlers = (HandlerT h) : (handlers l)}+addHandler h = lHandlers %~ (HandlerT h:)  -- | Remove a handler from the 'Logger'.  Handlers are removed in the reverse -- order they were added, so the following property holds for any 'LogHandler'@@ -250,34 +274,34 @@ -- -- > updateGlobalLogger rootLoggerName removeHandler removeHandler :: Logger -> Logger-removeHandler l = l { handlers = drop 1 $ handlers l }+removeHandler = lHandlers %~ drop 1  -- | Set the 'Logger'\'s list of handlers to the list supplied. -- All existing handlers are removed first. setHandlers :: LogHandler a => [a] -> Logger -> Logger-setHandlers hl l =-    l{handlers = map (\h -> HandlerT h) hl}+setHandlers hl = lHandlers .~ map HandlerT hl  -- | Returns the "level" of the logger.  Items beneath this -- level will be ignored. getLevel :: Logger -> Maybe Severity-getLevel = level+getLevel = _lLevel  -- | Sets the "level" of the 'Logger'.  Returns a new -- 'Logger' object with the new level. setLevel :: Severity -> Logger -> Logger-setLevel p l = l {level = Just p}+setLevel p = lLevel .~ Just p  -- | Clears the "level" of the 'Logger'.  It will now inherit the level of -- | its parent. clearLevel :: Logger -> Logger-clearLevel l = l {level = Nothing}+clearLevel = lLevel .~ Nothing  -- | Updates the global record for the given logger to take into -- account any changes you may have made. saveGlobalLogger :: Logger -> IO ()-saveGlobalLogger l = modifyMVar_ logTree-                     (\lt -> return $ Map.insert (name l) l lt)+saveGlobalLogger l =+    modifyMVar_ logInternalState $ \LogInternalState{..} ->+    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@@ -296,10 +320,11 @@ -- | Allow graceful shutdown. Release all opened files/handlers/etc. removeAllHandlers :: IO () removeAllHandlers =-    modifyMVar_ logTree $ \lt -> do-        let allHandlers = Map.fold (\l r -> concat [r, handlers l]) [] lt+    modifyMVar_ logInternalState $ \LogInternalState{..} -> do+        let allHandlers = M.fold (\l r -> concat [r, view lHandlers l]) [] liTree         mapM_ (\(HandlerT h) -> close h) allHandlers-        return $ Map.map (\l -> l {handlers = []}) lt+        let newTree = map (lHandlers .~ []) liTree+        return $ LogInternalState newTree liPrefix  -- | Traps exceptions that may occur, logging them, then passing them on. --@@ -320,6 +345,38 @@     handler e = do         logM logger priority (realdesc <> show e)         throwM e -- Re-raise it++----------------------------------------------------------------------------+-- Retrieving logs ad-hoc+----------------------------------------------------------------------------++-- | 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.+--+-- FYI: this function is implemented to avoid the following problem:+-- log-warper holds open handles to files, so trying to open log file+-- for read would result in 'IOException'.+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 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 filePathFull+            xs  -> error $ "Found more than one (" <> show (length xs) <>+                           "handle with the same filePath tag, impossible."++----------------------------------------------------------------------------+-- List util functions+----------------------------------------------------------------------------  -- | This function pulled in from MissingH to avoid a dep on it split :: Eq a => [a] -> [a] -> [[a]]

@@ -21,6 +21,9 @@        , isValidRotation           -- * Hierarchical tree of loggers (with lenses)+       , HandlerWrap (..)+       , hwFilePath+       , hwRounding        , LoggerTree (..)        , ltFiles        , ltSeverity@@ -33,18 +36,15 @@        , lcConsoleOutput        , lcFilePrefix        , lcMapper-       , lcMemModeLimit        , lcRotation        , lcShowTime        , lcTermSeverity        , lcTree-       , lcRoundVal        , zoomLogger           -- ** Builders for 'LoggerConfig'        , consoleOutB        , mapperB-       , memoryB        , prefixB        , productionB        , showTimeB@@ -85,21 +85,32 @@ -- LoggerTree ---------------------------------------------------------------------------- +-- | Wrapper over file handler with additional rounding option.+data HandlerWrap = HandlerWrap+    { _hwFilePath :: !FilePath+      -- ^ Path to the file to be handled.+    , _hwRounding :: !(Maybe Int)+      -- ^ Amount of seconds to round time on (if set).+    } deriving (Generic,Show)++makeLenses ''HandlerWrap+ type LoggerMap = HashMap Text LoggerTree  -- | Stores configuration for hierarchical loggers. data LoggerTree = LoggerTree     { _ltSubloggers :: !LoggerMap-    , _ltFiles      :: ![FilePath]+    , _ltFiles      :: ![HandlerWrap]     , _ltSeverity   :: !(Maybe Severity)     } deriving (Generic, Show)  makeLenses ''LoggerTree + -- TODO: QuickCheck tests on monoid laws instance Monoid LoggerTree where     mempty = LoggerTree-        { _ltFiles       = []+        { _ltFiles      = []         , _ltSeverity   = Nothing         , _ltSubloggers = mempty         }@@ -110,15 +121,26 @@         , _ltSubloggers = _ltSubloggers lt1 <>  _ltSubloggers lt2         } +instance ToJSON HandlerWrap+instance FromJSON HandlerWrap where+    parseJSON = withObject "handler wrap" $ \o -> do+        (_hwFilePath :: FilePath) <- o .: "file"+        (_hwRounding :: Maybe Int) <- o .:? "round"+        pure HandlerWrap{..}+ nonLoggers :: [Text]-nonLoggers = ["file", "files", "severity"]+nonLoggers = ["file", "files", "severity", "rounding", "handlers"]  instance ToJSON LoggerTree instance FromJSON LoggerTree where     parseJSON = withObject "loggers tree" $ \o -> do         (singleFile :: Maybe FilePath) <- o .:? "file"         (manyFiles :: [FilePath]) <- o .:? "files" .!= []-        let _ltFiles = maybe [] (:[]) singleFile ++ manyFiles+        handlers <- o .:? "handlers" .!= []+        let fileHandlers =+                map (\fp -> HandlerWrap fp Nothing) $+                maybe [] (:[]) singleFile ++ manyFiles+        let _ltFiles = fileHandlers <> handlers         _ltSeverity   <- o .:? "severity"         _ltSubloggers <- for (filterObject nonLoggers o) parseJSON         return LoggerTree{..}@@ -179,14 +201,8 @@       -- | Path prefix to add for each logger file     , _lcFilePrefix    :: Maybe FilePath -      -- | Limit for queue in memory mode.-    , _lcMemModeLimit  :: Maybe Word64-       -- | Hierarchical tree of loggers.     , _lcTree          :: LoggerTree--      -- | If rounding is enabled, to how many secs to round.-    , _lcRoundVal      :: Maybe Int     }  makeLenses ''LoggerConfig@@ -200,9 +216,7 @@         , _lcConsoleOutput = mempty         , _lcMapper        = mempty         , _lcFilePrefix    = mempty-        , _lcMemModeLimit  = Nothing         , _lcTree          = mempty-        , _lcRoundVal      = Nothing         }      lc1 `mappend` lc2 = LoggerConfig@@ -212,14 +226,12 @@         , _lcConsoleOutput = _lcConsoleOutput lc1  <> _lcConsoleOutput lc2         , _lcMapper        = _lcMapper        lc1  <> _lcMapper        lc2         , _lcFilePrefix    = _lcFilePrefix    lc1 <|> _lcFilePrefix    lc2-        , _lcMemModeLimit  = _lcMemModeLimit  lc1 <|> _lcMemModeLimit  lc2         , _lcTree          = _lcTree          lc1  <> _lcTree          lc2-        , _lcRoundVal      = _lcRoundVal      lc1 `max` _lcRoundVal    lc2         }  topLevelParams :: [Text] topLevelParams =-    ["rotation", "showTime", "printOutput", "filePrefix", "memModeLimit", "roundTime"]+    ["rotation", "showTime", "printOutput", "filePrefix" ]  instance FromJSON LoggerConfig where     parseJSON = withObject "rotation params" $ \o -> do@@ -228,9 +240,7 @@         _lcShowTime      <- Any <$> o .:? "showTime"    .!= False         _lcConsoleOutput <- Any <$> o .:? "printOutput" .!= False         _lcFilePrefix    <-         o .:? "filePrefix"-        _lcMemModeLimit  <-         o .:? "memModeLimit"         _lcTree          <- parseJSON $ Object $ filterObject topLevelParams o-        _lcRoundVal      <-         o .:? "roundTime"         let _lcMapper     = mempty         return LoggerConfig{..} @@ -243,7 +253,6 @@             , "showTime"     .= getAny _lcShowTime             , "printOutput"  .= getAny _lcConsoleOutput             , "filePrefix"   .= _lcFilePrefix-            , "memModeLimit" .= _lcMemModeLimit             , ("logTree", toJSON _lcTree)             ] @@ -268,7 +277,3 @@ -- | Setup 'lcFilePrefix' inside 'LoggerConfig'. prefixB :: FilePath -> LoggerConfig prefixB filePrefix = mempty { _lcFilePrefix = Just filePrefix }---- | Setup memory logger with certain limit-memoryB :: Word64 -> LoggerConfig-memoryB limit = mempty { _lcMemModeLimit = Just limit }

@@ -15,6 +15,7 @@ import           Data.Text.Buildable (Buildable) import qualified Data.Text.Buildable as Buildable import           Formatting          (Format, bprint, build, string)+import           Universum  -- | Logger name to keep in context. 

@@ -28,6 +28,7 @@ import           Control.Monad.Trans.Cont    (ContT, mapContT) import           Control.Monad.Trans.Control (MonadBaseControl (..)) import           Control.Monad.Writer        (WriterT (..), mapWriterT)+import           Universum  import           System.Wlog.LoggerName      (LoggerName) 

@@ -1,5 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TemplateHaskell #-}  -- | Queue for in-memory logs. Rolls out old logging if size of queue -- is bigger than predefined limit.@@ -32,7 +31,6 @@ instance Sized Text where     getSize = fromIntegral . length - -- | Data structure similar to queue but pops out elements after -- 'pushFront' if 'mqMemSize' > 'mqLimit'. data MemoryQueue a = MemoryQueue@@ -56,7 +54,7 @@         in (Just popped, MemoryQueue{ _mqMemSize = newMemSize, _mqQueue = rest, .. })  -- | Add new element at the beginning removing elements from the end--- untill size become not greater than limit.+-- until size become not greater than limit. pushFront :: (Sized a) => a -> MemoryQueue a -> MemoryQueue a pushFront msg mq = executingState mq $ do     mqMemSize += getSize msg

@@ -1,106 +0,0 @@-{-# LANGUAGE DeriveAnyClass    #-}-{-# LANGUAGE NoImplicitPrelude #-}---- | Custom implementation of 'LogHandler' with log rotation support.--module System.Wlog.Roller-       ( InvalidRotation (..)-       , RollerHandler   (..)-       , logIndex-       , rotationFileHandler-       ) where--import           Universum--import           Control.Concurrent         (modifyMVar_, withMVar)-import           Formatting                 (sformat, shown, (%))-import qualified Prelude                    (show)--import           System.Directory           (removeFile, renameFile)-import           System.FilePath            ((<.>))-import           System.IO                  (Handle, IOMode (AppendMode), hClose,-                                             hFileSize)-import           System.Wlog.FileUtils      (whenExist)-import           System.Wlog.Formatter      (LogFormatter, nullFormatter)-import           System.Wlog.Handler        (LogHandler (..))-import           System.Wlog.Handler.Simple (GenericHandler (..), fileHandler)-import           System.Wlog.LoggerConfig   (RotationParameters (..), isValidRotation)-import           System.Wlog.Severity       (Severity (..))---- | Similar to 'GenericHandler'. But holds file 'Handle' inside--- mutable variable ('MVar') to be able to rotate loggers.-data RollerHandler = RollerHandler-    { rhSeverity    :: Severity-    , rhFormatter   :: LogFormatter RollerHandler-    , rhFileHandle  :: MVar Handle-    , rhWriteAction :: Handle -> Text -> IO ()-    , rhCloseAction :: Handle -> IO ()-    , rhFileName    :: FilePath-    }--instance LogHandler RollerHandler where-    getTag rh         = "rollerHandler:" <> rhFileName rh-    setLevel     rh p = rh { rhSeverity  = p }-    setFormatter rh f = rh { rhFormatter = f }-    getLevel          = rhSeverity-    getFormatter      = rhFormatter--    emit rh (_, msg) _      = rhWriteAction rh (error "Handler is used internally") msg-    close RollerHandler{..} = withMVar rhFileHandle rhCloseAction--data InvalidRotation = InvalidRotation !Text-    deriving (Show, Eq)--instance Exception InvalidRotation--logIndex :: FilePath -> Int -> FilePath-logIndex handlerPath i = handlerPath <.> Prelude.show i---- TODO: correct exceptions handling here is too smart for me-rollerWriting-    :: RotationParameters-    -> FilePath-    -> (Handle -> Text -> IO ())-    -> MVar Handle-    -> Handle-    -> Text-    -> IO ()-rollerWriting RotationParameters{..} handlerPath loggingAction varHandle _ msg =-    modifyMVar_ varHandle $ \landle -> do-        loggingAction landle msg-        logFileSize <- fromIntegral <$> hFileSize landle-        if logFileSize < rpLogLimit-        then return landle-         -- otherwise should rename all files and create new handle putting in MVar-        else do-            hClose landle-            let lastIndex = fromIntegral $ rpKeepFiles - 1-            for_ [lastIndex - 1,lastIndex - 2 .. 0] $ \i -> do-                let oldLogFile = logIndex handlerPath i-                let newLogFile = logIndex handlerPath (i + 1)-                whenExist oldLogFile $ (`renameFile` newLogFile)-            let zeroIndex = logIndex handlerPath 0-            renameFile handlerPath zeroIndex-            let lastLogFile = logIndex handlerPath lastIndex-            whenExist lastLogFile removeFile-            openFile handlerPath AppendMode---- | Create rotation logging handler.-rotationFileHandler-    :: MonadIO m-    => RotationParameters-    -> FilePath-    -> Severity-    -> m RollerHandler-rotationFileHandler rp@RotationParameters{..} _ _-    | not $ isValidRotation rp = liftIO $ throwM $ InvalidRotation $-      sformat ("Rotation parameters must be positive: "%shown) rp-rotationFileHandler rp@RotationParameters{..} handlerPath rhSeverity = liftIO $ do-    GenericHandler{..} <- fileHandler handlerPath rhSeverity-    rhFileHandle       <- newMVar privData-    let rhWriteAction   = rollerWriting rp handlerPath writeFunc rhFileHandle-    pure RollerHandler { rhFormatter   = nullFormatter-                       , rhCloseAction = closeFunc-                       , rhFileName = handlerPath-                       , ..-                       }

@@ -39,15 +39,10 @@ -- (it should be filled before this function call). streamHandlerWithLock :: MVar () -> Handle -> Severity -> IO (GenericHandler Handle) streamHandlerWithLock lock h sev = do-    GenericHandler{..} <- streamHandler h sev-    return GenericHandler-        { severity  = severity-        , formatter = formatter-        , privData  = privData-        , writeFunc = \a s -> withMVar lock $ const $ writeFunc a s-        , closeFunc = closeFunc-        , ghTag = ghTag-        }+    GenericHandler {..} <- streamHandler h sev+    pure+        GenericHandler+        {writeFunc = \a s -> withMVar lock $ const $ writeFunc a s, ..}  -- | This function initializes global logging system for terminal output. -- At high level, it sets severity which will be used by all loggers by default,

@@ -19,13 +19,14 @@ import           Test.QuickCheck          (Arbitrary (..), Property, choose, (==>)) import           Test.QuickCheck.Monadic  (PropertyM, monadicIO, run) -import           System.Wlog              (InvalidRotation (..), LoggerConfig (..),-                                           RotationParameters (..), Severity (..),-                                           fromScratch, isValidRotation, lcFilePrefix,-                                           lcRotation, lcTree, logDebug, logIndex,-                                           ltFiles, ltSeverity, releaseAllHandlers,-                                           rotationFileHandler, setupLogging,-                                           usingLoggerName, whenExist, zoomLogger)+import           System.Wlog              (HandlerWrap (..), InvalidRotation (..),+                                           LoggerConfig (..), RotationParameters (..),+                                           Severity (..), fromScratch, isValidRotation,+                                           lcFilePrefix, lcRotation, lcTree, logDebug,+                                           logIndex, ltFiles, ltSeverity,+                                           releaseAllHandlers, rotationFileHandler,+                                           setupLogging, usingLoggerName, whenExist,+                                           zoomLogger)  spec :: Spec spec = do@@ -73,7 +74,7 @@     zoom lcTree $ do         ltSeverity ?= Debug         zoomLogger "test" $-            ltFiles .= [testLogFile]+            ltFiles .= [HandlerWrap testLogFile Nothing]  logThreadsNum :: Word logThreadsNum = 4