log-warper 0.2.3 → 0.2.5

raw patch · 13 files changed

+537/−137 lines, 13 filesdep +QuickCheckdep +asyncdep +hspecdep ~basedep ~data-defaultdep ~directoryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: QuickCheck, async, hspec, universum

Dependency ranges changed: base, data-default, directory, filepath, unordered-containers

API changes (from Hackage documentation)

Files

• examples/Playground.hs +1/−1
• log-warper.cabal +48/−2
• src/System/Wlog.hs +6/−2
• src/System/Wlog/CanLog.hs +6/−1
• src/System/Wlog/FileUtils.hs +15/−0
• src/System/Wlog/Launcher.hs +132/−0
• src/System/Wlog/LoggerConfig.hs +81/−18
• src/System/Wlog/LoggerNameBox.hs +12/−1
• src/System/Wlog/Parser.hs +0/−112
• src/System/Wlog/Roller.hs +103/−0
• test/Spec.hs +1/−0
• test/Test.hs +7/−0
• test/Test/Wlog/RollingSpec.hs +125/−0

@@ -12,7 +12,7 @@                                     modifyLoggerName, releaseAllHandlers, runPureLog,                                     usingLoggerName) -testLogging :: CanLog m => m ()+testLogging :: (CanLog m) => m () testLogging = usingLoggerName "node" $ do     logDebug   "skovoroda"     logInfo    "patak"

@@ -1,5 +1,5 @@ name:                log-warper-version:             0.2.3+version:             0.2.5 synopsis:            Flexible, configurable, monadic and pretty logging homepage:            https://github.com/serokell/log-warper license:             MIT@@ -20,10 +20,12 @@ library   exposed-modules:     System.Wlog                        System.Wlog.CanLog+                       System.Wlog.FileUtils+                       System.Wlog.Launcher                        System.Wlog.LoggerConfig                        System.Wlog.LoggerName                        System.Wlog.LoggerNameBox-                       System.Wlog.Parser+                       System.Wlog.Roller                        System.Wlog.Severity                        System.Wlog.Wrapper @@ -53,6 +55,7 @@                      , time                 >= 1.6.0.1                      , transformers         >= 0.5.2                      , transformers-base    >= 0.4.4+                     , universum                      , unordered-containers >= 0.2.7.1                      , yaml                 >= 0.8.20 @@ -89,3 +92,46 @@                        OverloadedStrings                        TypeApplications                        RecordWildCards++test-suite log-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Test.hs+  other-modules:       Spec+                       Test.Wlog.RollingSpec++  build-depends:       async+                     , base+                     , data-default+                     , directory+                     , filepath+                     , hspec+                     , log-warper+                     , QuickCheck+                     , universum+                     , unordered-containers++  default-language:    Haskell2010+  ghc-options:         -threaded+                       -rtsopts+                       -Wall+                       -fno-warn-orphans+                       -with-rtsopts=-N++  default-extensions:   DeriveDataTypeable+                        DeriveGeneric+                        GeneralizedNewtypeDeriving+                        StandaloneDeriving+                        FlexibleContexts+                        FlexibleInstances+                        MultiParamTypeClasses+                        FunctionalDependencies+                        DefaultSignatures+                        NoImplicitPrelude+                        OverloadedStrings+                        RecordWildCards+                        TypeApplications+                        TupleSections+                        ViewPatterns+                        LambdaCase+                        MultiWayIf

@@ -13,18 +13,22 @@  module System.Wlog        ( module System.Wlog.CanLog+       , module System.Wlog.FileUtils+       , module System.Wlog.Launcher        , module System.Wlog.LoggerConfig        , module System.Wlog.LoggerName        , module System.Wlog.LoggerNameBox-       , module System.Wlog.Parser+       , module System.Wlog.Roller        , module System.Wlog.Severity        , module System.Wlog.Wrapper        ) where  import           System.Wlog.CanLog+import           System.Wlog.FileUtils+import           System.Wlog.Launcher import           System.Wlog.LoggerConfig import           System.Wlog.LoggerName import           System.Wlog.LoggerNameBox-import           System.Wlog.Parser+import           System.Wlog.Roller import           System.Wlog.Severity import           System.Wlog.Wrapper

@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLists       #-}+{-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE UndecidableInstances  #-}@@ -32,6 +33,8 @@  import           Control.Monad.Except      (ExceptT, MonadError) import           Control.Monad.Reader      (MonadReader, ReaderT)+import qualified Control.Monad.RWS         as RWSLazy+import qualified Control.Monad.RWS.Strict  as RWSStrict import           Control.Monad.State       (MonadState, StateT) import           Control.Monad.Trans       (MonadTrans (lift)) import           Control.Monad.Writer      (MonadWriter (tell), WriterT (runWriterT))@@ -77,6 +80,8 @@ instance CanLog m => CanLog (ReaderT r m) instance CanLog m => CanLog (StateT s m) instance CanLog m => CanLog (ExceptT s m)+instance (CanLog m, Monoid w) => CanLog (RWSLazy.RWST r w s m)+instance (CanLog m, Monoid w) => CanLog (RWSStrict.RWST r w s m)  -- | Holds all required information for 'dispatchLoggerName' function. data LogEvent = LogEvent@@ -93,7 +98,7 @@ -- But it uses 'unsafePerformIO' so use with caution within IO. -- -- TODO: Should we use some @Data.Tree@-like structure to observe message only--- by chosen loger names?+-- by chosen logger names? newtype PureLogger m a = PureLogger     { runPureLogger :: WriterT (DList LogEvent) m a     } deriving (Functor, Applicative, Monad, MonadTrans, MonadWriter (DList LogEvent),

@@ -0,0 +1,15 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- | Some helpers and utilites to work with files++module System.Wlog.FileUtils+       ( whenExist+       ) where++import           Universum++import           System.Directory (doesFileExist)++-- | Performs given action on file if file exists.+whenExist :: MonadIO m => FilePath -> (FilePath -> m ()) -> m ()+whenExist filePath action = whenM (liftIO $ doesFileExist filePath) $ action filePath

@@ -0,0 +1,132 @@+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ViewPatterns              #-}++-- |+-- Module      : System.Wlog.Parser+-- Copyright   : (c) Serokell, 2016+-- License     : GPL-3 (see the file LICENSE)+-- Maintainer  : Serokell <hi@serokell.io>+-- Stability   : experimental+-- Portability : POSIX, GHC+--+-- Parser for configuring and initializing logger from YAML file.+-- Logger configuration should look like this:+--+-- > rotation:                # [optional] parameters for logging rotation+-- >     logLimit: 1024       # max size of log file in bytes+-- >     keepFiles: 3         # number of files with logs to keep including current one+-- > node:                    # logger named «node»+-- >     severity: Warning    # severity for logger «node»+-- >     comm:                # logger named «node.comm»+-- >         severity: Info   # severity for logger «node.comm»+-- >         file: patak.jpg  # messages will be also printed to patak.jpg+--+-- And this configuration corresponds two loggers with 'LoggerName'`s+-- @node@ and @node.comm@.++module System.Wlog.Launcher+       ( initLoggingFromYaml+       , initLoggingFromYamlWithMapper+       , parseLoggerConfig+       , traverseLoggerConfig+       ) where++#if PatakDebugSkovorodaBARDAQ+import qualified Data.ByteString.Char8     as BS (putStrLn)+import           Data.Yaml.Pretty          (defConfig, encodePretty)+#endif++import           Control.Error.Util        ((?:))+import           Control.Exception         (throwIO)+import           Control.Monad             (join)+import           Control.Monad.Extra       (whenJust)+import           Control.Monad.IO.Class    (MonadIO (liftIO))++import           Data.Foldable             (for_)+import qualified Data.HashMap.Strict       as HM hiding (HashMap)+import           Data.Maybe                (fromMaybe)+import           Data.Monoid               ((<>))+import           Data.Text                 (unpack)+import           Data.Yaml                 (decodeFileEither)++import           System.Directory          (createDirectoryIfMissing)+import           System.FilePath           ((</>))+import           System.Log                (Priority)+import           System.Log.Handler        (LogHandler)+import           System.Log.Handler.Simple (fileHandler)+import           System.Log.Logger         (addHandler, updateGlobalLogger)++import           System.Wlog.Formatter     (setStdoutFormatter)+import           System.Wlog.LoggerConfig  (LoggerConfig (..), LoggerTree (..),+                                            RotationParameters)+import           System.Wlog.LoggerName    (LoggerName (..))+import           System.Wlog.Roller        (rotationFileHandler)+import           System.Wlog.Wrapper       (Severity (Debug, Warning), convertSeverity,+                                            initLogging, setSeverityMaybe)++data HandlerFabric+    = forall h . LogHandler h => HandlerFabric (FilePath -> Priority -> IO h)++-- | This function traverses 'LoggerConfig' initializing all subloggers+-- with 'Severity' and redirecting output in file handlers. Also takes+-- 'FilePath' prefix to create directory for file handlers output. Create+-- logging rotation if appropriate arguments are passed.+traverseLoggerConfig+    :: MonadIO m+    => (LoggerName -> LoggerName)  -- ^ mapper to transform logger names during traversal+    -> Maybe RotationParameters    -- ^ rotation parameters for roller handle+    -> LoggerTree                  -- ^ given 'LoggerConfig' to traverse+    -> Maybe FilePath              -- ^ prefix for file handlers+    -> m ()+traverseLoggerConfig logMapper mrot tree (fromMaybe "." -> handlerPrefix) = do+    liftIO $ createDirectoryIfMissing True handlerPrefix+    initLogging Warning+    processLoggers mempty tree+  where+    handlerFabric :: HandlerFabric+    handlerFabric = case mrot of+        Nothing  -> HandlerFabric fileHandler+        Just rot -> HandlerFabric $ rotationFileHandler rot++    processLoggers :: MonadIO m => LoggerName -> LoggerTree -> m ()+    processLoggers parent LoggerTree{..} = do+        setSeverityMaybe parent ltSeverity++        whenJust ltFile $ \fileName -> liftIO $ do+            let filePriority   = convertSeverity $ ltSeverity ?: Debug+            let handlerPath    = handlerPrefix </> fileName+            case handlerFabric of+              HandlerFabric fabric -> do+                thisLoggerHandler <- setStdoutFormatter True <$> fabric handlerPath filePriority+                updateGlobalLogger (loggerName parent) $ addHandler thisLoggerHandler++        for_ (HM.toList ltSubloggers) $ \(name, loggerConfig) -> do+            let thisLoggerName = LoggerName $ unpack name+            let thisLogger     = parent <> logMapper thisLoggerName+            processLoggers thisLogger loggerConfig++-- | Parses logger config from given file path.+parseLoggerConfig :: MonadIO m => FilePath -> m LoggerConfig+parseLoggerConfig loggerConfigPath =+    liftIO $ join $ either throwIO return <$> decodeFileEither loggerConfigPath++-- | Initialize logger hierarchy from configuration file.+-- See this module description.+initLoggingFromYamlWithMapper+    :: MonadIO m+    => (LoggerName -> LoggerName)+    -> FilePath+    -> Maybe FilePath+    -> m ()+initLoggingFromYamlWithMapper loggerMapper loggerConfigPath handlerPrefix = do+    cfg@LoggerConfig{..} <- parseLoggerConfig loggerConfigPath++#if PatakDebugSkovorodaBARDAQ+    liftIO $ BS.putStrLn $ encodePretty defConfig cfg+#endif++    traverseLoggerConfig loggerMapper lcRotation lcTree handlerPrefix++initLoggingFromYaml :: MonadIO m => FilePath -> Maybe FilePath -> m ()+initLoggingFromYaml = initLoggingFromYamlWithMapper id

@@ -10,7 +10,10 @@  module System.Wlog.LoggerConfig        ( LoggerConfig (..)+       , LoggerTree   (..)        , LoggerMap+       , RotationParameters (..)+       , isValidRotation        ) where  import           Data.Aeson          (withObject)@@ -18,38 +21,98 @@ import           Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM hiding (HashMap) import           Data.Text           (Text)+import qualified Data.Text.Buildable as Buildable import           Data.Traversable    (for)-import           Data.Yaml           (FromJSON (..), ToJSON, (.:?))+import           Data.Word           (Word64)+import           Data.Yaml           (FromJSON (..), ToJSON, Value (Object), (.:), (.:?))+import           Formatting          (bprint, shown) import           GHC.Generics        (Generic)  import           System.Wlog.Wrapper (Severity) -type LoggerMap = HashMap Text LoggerConfig+----------------------------------------------------------------------------+-- Utilites & helpers+---------------------------------------------------------------------------- -data LoggerConfig = LoggerConfig-    { lcSubloggers :: !LoggerMap-    , lcFile       :: !(Maybe FilePath)-    , lcSeverity   :: !(Maybe Severity)+filterObject :: [Text] -> HashMap Text a -> HashMap Text a+filterObject excluded = HM.filterWithKey $ \k _ -> k `notElem` excluded++----------------------------------------------------------------------------+-- LoggerTree+----------------------------------------------------------------------------++type LoggerMap = HashMap Text LoggerTree++-- | Stores configuration for hierarchical loggers.+data LoggerTree = LoggerTree+    { ltSubloggers :: !LoggerMap+    , ltFile       :: !(Maybe FilePath)+    , ltSeverity   :: !(Maybe Severity)     } deriving (Generic, Show) -instance ToJSON LoggerConfig+instance ToJSON LoggerTree -instance Default LoggerConfig where-    def = LoggerConfig-          { lcFile       = Nothing-          , lcSeverity   = Nothing-          , lcSubloggers = mempty+instance Default LoggerTree where+    def = LoggerTree+          { ltFile       = Nothing+          , ltSeverity   = Nothing+          , ltSubloggers = mempty           }  nonLoggers :: [Text] nonLoggers = ["file", "severity"] -selectLoggers :: HashMap Text a -> HashMap Text a-selectLoggers = HM.filterWithKey $ \k _ -> k `notElem` nonLoggers+instance FromJSON LoggerTree where+    parseJSON = withObject "loggers tree" $ \o -> do+        ltFile       <- o .:? "file"+        ltSeverity   <- o .:? "severity"+        ltSubloggers <- for (filterObject nonLoggers o) parseJSON+        return LoggerTree{..} +----------------------------------------------------------------------------+-- Logger rotattion+----------------------------------------------------------------------------++-- | Parameters for logging rotation.+data RotationParameters = RotationParameters+    { rpLogLimit  :: !Word64  -- ^ max size of file in bytes+    , rpKeepFiles :: !Word    -- ^ number of files to keep+    } deriving (Generic, Show)++instance Buildable.Buildable RotationParameters where+    build = bprint shown++instance ToJSON RotationParameters++instance FromJSON RotationParameters where+    parseJSON = withObject "rotation params" $ \o -> do+        rpLogLimit  <- o .: "logLimit"+        rpKeepFiles <- o .: "keepFiles"+        return RotationParameters{..}++isValidRotation :: RotationParameters -> Bool+isValidRotation RotationParameters{..} = rpLogLimit > 0 && rpKeepFiles > 0++----------------------------------------------------------------------------+-- LoggerConfig+----------------------------------------------------------------------------++-- | Logger configuration which keeps 'RotationParameters' and 'LoggerTree'.+data LoggerConfig = LoggerConfig+    { lcRotation :: !(Maybe RotationParameters)+    , lcTree     :: !LoggerTree+    } deriving (Generic, Show)++instance Default LoggerConfig where+    def = LoggerConfig+          { lcRotation = Nothing+          , lcTree     = def+          }+ instance FromJSON LoggerConfig where-    parseJSON = withObject "root loggers" $ \o -> do-        lcFile       <- o .:? "file"-        lcSeverity   <- o .:? "severity"-        lcSubloggers <- for (selectLoggers o) parseJSON+    parseJSON = withObject "rotation params" $ \o -> do+        lcRotation <- o .:? "rotation"+        lcTree     <- parseJSON $ Object $ filterObject ["rotation"] o         return LoggerConfig{..}++instance ToJSON LoggerConfig

@@ -19,6 +19,8 @@ import           Control.Monad.Fix           (MonadFix) import           Control.Monad.Reader        (MonadReader (..), ReaderT, mapReaderT,                                               runReaderT)+import qualified Control.Monad.RWS           as RWSLazy+import qualified Control.Monad.RWS.Strict    as RWSStrict import           Control.Monad.State         (MonadState, StateT, mapStateT) import           Control.Monad.Trans         (MonadIO, MonadTrans, lift) import           Control.Monad.Trans.Cont    (ContT, mapContT)@@ -63,6 +65,16 @@      modifyLoggerName = mapContT . modifyLoggerName +instance (Monad m, HasLoggerName m, Monoid w) => HasLoggerName (RWSLazy.RWST r w s m) where+    getLoggerName = lift getLoggerName++    modifyLoggerName = RWSLazy.mapRWST . modifyLoggerName++instance (Monad m, HasLoggerName m, Monoid w) => HasLoggerName (RWSStrict.RWST r w s m) where+    getLoggerName = lift getLoggerName++    modifyLoggerName = RWSStrict.mapRWST . modifyLoggerName+ -- | Set logger name in context. setLoggerName :: HasLoggerName m => LoggerName -> m a -> m a setLoggerName = modifyLoggerName . const@@ -72,7 +84,6 @@     { loggerNameBoxEntry :: ReaderT LoggerName m a     } deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadBase b,                 MonadThrow, MonadCatch, MonadMask, MonadState s, MonadFix)-  instance MonadReader r m => MonadReader r (LoggerNameBox m) where     ask = lift ask

@@ -1,112 +0,0 @@-{-# LANGUAGE CPP          #-}-{-# LANGUAGE ViewPatterns #-}---- |--- Module      : System.Wlog.Parser--- Copyright   : (c) Serokell, 2016--- License     : GPL-3 (see the file LICENSE)--- Maintainer  : Serokell <hi@serokell.io>--- Stability   : experimental--- Portability : POSIX, GHC------ Parser for configuring and initializing logger from YAML file.--- Logger configuration should look like this:------ > node:                    # logger named «node»--- >     severity: Warning    # severity for logger «node»--- >     comm:                # logger named «node.comm»--- >         severity: Info   # severity for logger «node.comm»--- >         file: patak.jpg  # messages will be also printed to patak.jpg------ And this configuration corresponds two loggers with 'LoggerName'`s--- @node@ and @node.comm@.--module System.Wlog.Parser-       ( initLoggingFromYaml-       , initLoggingFromYamlWithMapper-       , parseLoggerConfig-       , traverseLoggerConfig-       ) where--#if PatakDebugSkovorodaBARDAQ-import qualified Data.ByteString.Char8     as BS (putStrLn)-import           Data.Yaml.Pretty          (defConfig, encodePretty)-#endif--import           Control.Error.Util        ((?:))-import           Control.Exception         (throwIO)-import           Control.Monad             (join)-import           Control.Monad.Extra       (whenJust)-import           Control.Monad.IO.Class    (MonadIO (liftIO))--import           Data.Foldable             (for_)-import qualified Data.HashMap.Strict       as HM hiding (HashMap)-import           Data.Maybe                (fromMaybe)-import           Data.Monoid               ((<>))-import           Data.Text                 (unpack)-import           Data.Yaml                 (decodeFileEither)--import           System.Directory          (createDirectoryIfMissing)-import           System.FilePath           ((</>))-import           System.Log.Handler.Simple (fileHandler)-import           System.Log.Logger         (addHandler, updateGlobalLogger)--import           System.Wlog.Formatter     (setStdoutFormatter)-import           System.Wlog.LoggerConfig  (LoggerConfig (..))-import           System.Wlog.LoggerName    (LoggerName (..))-import           System.Wlog.Wrapper       (Severity (Debug, Warning), convertSeverity,-                                            initLogging, setSeverityMaybe)---- | This function traverses 'LoggerConfig' initializing all subloggers--- with 'Severity' and redirecting output in file handlers. Also takes--- 'FilePath' prefix to create directory for file handlers output.-traverseLoggerConfig-    :: MonadIO m-    => (LoggerName -> LoggerName)  -- ^ mapper to transform logger names during traversal-    -> LoggerConfig                -- ^ given LoggerConfig to traverse-    -> Maybe FilePath              -- ^ prefix for file handlers-    -> m ()-traverseLoggerConfig logMapper config (fromMaybe "." -> handlerPrefix) = do-    liftIO $ createDirectoryIfMissing True handlerPrefix-    initLogging Warning-    processLoggers mempty config-  where-    processLoggers:: MonadIO m => LoggerName -> LoggerConfig -> m ()-    processLoggers parent LoggerConfig{..} = do-        setSeverityMaybe parent lcSeverity--        whenJust lcFile $ \fileName -> liftIO $ do-            let fileSeverity   = convertSeverity $ lcSeverity ?: Debug-            let handlerPath    = handlerPrefix </> fileName-            thisLoggerHandler <- setStdoutFormatter True <$> fileHandler handlerPath fileSeverity-            updateGlobalLogger (loggerName parent) $ addHandler thisLoggerHandler--        for_ (HM.toList lcSubloggers) $ \(name, loggerConfig) -> do-            let thisLoggerName = LoggerName $ unpack name-            let thisLogger     = parent <> logMapper thisLoggerName-            processLoggers thisLogger loggerConfig---- | Parses logger config from given file path.-parseLoggerConfig :: MonadIO m => FilePath -> m LoggerConfig-parseLoggerConfig loggerConfigPath =-    liftIO $ join $ either throwIO return <$> decodeFileEither loggerConfigPath---- | Initialize logger hierarchy from configuration file.--- See this module description.-initLoggingFromYamlWithMapper-    :: MonadIO m-    => (LoggerName -> LoggerName)-    -> FilePath-    -> Maybe FilePath-    -> m ()-initLoggingFromYamlWithMapper loggerMapper loggerConfigPath handlerPrefix = do-    loggerConfig <- parseLoggerConfig loggerConfigPath--#if PatakDebugSkovorodaBARDAQ-    liftIO $ BS.putStrLn $ encodePretty defConfig loggerConfig-#endif--    traverseLoggerConfig loggerMapper loggerConfig handlerPrefix--initLoggingFromYaml :: MonadIO m => FilePath -> Maybe FilePath -> m ()-initLoggingFromYaml = initLoggingFromYamlWithMapper id

@@ -0,0 +1,103 @@+{-# 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        (MVar, modifyMVar_, newMVar)+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.Log                (Priority)+import           System.Log.Formatter      (LogFormatter, nullFormatter)+import           System.Log.Handler        (LogHandler (..))+import           System.Log.Handler.Simple (GenericHandler (..), fileHandler)++import           System.Wlog.FileUtils     (whenExist)+import           System.Wlog.LoggerConfig  (RotationParameters (..), isValidRotation)++-- | Similar to 'GenericHandler'. But holds file 'Handle' inside+-- mutable variable ('MVar') to be able to rotate loggers.+data RollerHandler = RollerHandler+    { rhPriority    :: Priority+    , rhFormatter   :: LogFormatter RollerHandler+    , rhFileHandle  :: MVar Handle+    , rhWriteAction :: Handle -> String -> IO ()+    , rhCloseAction :: Handle -> IO ()+    }++instance LogHandler RollerHandler where+    setLevel     rh p = rh { rhPriority  = p }+    setFormatter rh f = rh { rhFormatter = f }+    getLevel          = rhPriority+    getFormatter      = rhFormatter++    emit rh (_, msg) _      = rhWriteAction rh (panic "Handler is used internally") msg+    close RollerHandler{..} = withMVar rhFileHandle rhCloseAction++data InvalidRotation = InvalidRotation !Text+    deriving (Show, Eq)++instance Exception InvalidRotation++logIndex :: FilePath -> Word -> FilePath+logIndex handlerPath i = handlerPath <.> Prelude.show i++-- | Create rotation logging handler.+rotationFileHandler+    :: MonadIO m+    => RotationParameters+    -> FilePath+    -> Priority+    -> m RollerHandler+rotationFileHandler rp@RotationParameters{..} _ _+    | not $ isValidRotation rp = liftIO $ throwM $ InvalidRotation $+      sformat ("Rotation parameters must be positive: "%shown) rp+rotationFileHandler RotationParameters{..} handlerPath rhPriority = liftIO $ do+    GenericHandler{..} <- fileHandler handlerPath rhPriority+    rhFileHandle       <- newMVar privData+    let rhWriteAction   = rollerWriting writeFunc rhFileHandle+    return RollerHandler{ rhFormatter   = nullFormatter+                        , rhCloseAction = closeFunc+                        , ..+                        }+  where+    -- TODO: correct exceptions handling here is too smart for me+    rollerWriting+        :: (Handle -> String -> IO ())+        -> MVar Handle+        -> Handle+        -> String+        -> IO ()+    rollerWriting loggingAction varHandle _ msg = modifyMVar_ varHandle $ \landle -> do+        loggingAction landle msg+        logFileSize <- fromIntegral <$> hFileSize landle+        if logFileSize < rpLogLimit then+            return landle+        else do  -- otherwise should rename all files and create new handle putting in MVar+           hClose landle+           let lastIndex = 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

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

@@ -0,0 +1,7 @@+import           Universum++import           Spec       (spec)+import           Test.Hspec (hspec)++main :: IO ()+main = hspec spec

@@ -0,0 +1,125 @@+-- | Tests for rolling logger.++module Test.Wlog.RollingSpec+       ( spec+       ) where++import           Universum++import           Control.Concurrent.Async (mapConcurrently)+import           Data.Default             (def)+import qualified Data.HashMap.Strict      as HM (fromList)+import qualified Prelude                  (read)+import           System.Directory         (doesFileExist, removeFile)+import           System.FilePath          (takeExtension)+import           System.IO                (hFileSize)++import           Test.Hspec               (Spec, describe, it, shouldThrow)+import           Test.Hspec.QuickCheck    (prop)+import           Test.QuickCheck          (Arbitrary (..), Large (..), Positive (..),+                                           Property, (==>))+import           Test.QuickCheck.Monadic  (PropertyM, assert, monadicIO, run)++import           System.Wlog              (InvalidRotation (..), LoggerConfig (..),+                                           LoggerTree (..), RotationParameters (..),+                                           Severity (..), isValidRotation, logDebug,+                                           logIndex, releaseAllHandlers,+                                           rotationFileHandler, traverseLoggerConfig,+                                           usingLoggerName, whenExist)++spec :: Spec+spec = describe "System.Wlog.Roller" $ do+    describe "Exception" $ do+        it "throws exception in case of invalid roller params" $ do+            let wrongRP1 = RotationParameters 0 1+            let wrongRP2 = RotationParameters 1 0+            let expectedRollException rp =+                  (== InvalidRotation ("Rotation parameters must be positive: " <> pretty rp))+            let rollExceptionChecker rp+                  = rotationFileHandler rp "" (panic "Test roll!")+                      `shouldThrow`+                    expectedRollException rp++            rollExceptionChecker wrongRP1+            rollExceptionChecker wrongRP2++    describe "Concurrent rolling" $+        prop description_verifyLoggerRotation verifyLoggerRotation+  where+    description_verifyLoggerRotation =+      "logger rotation successfully creates files in concurrent environment"++instance Arbitrary RotationParameters where+    arbitrary = do+        Large    rpLogLimit  <- arbitrary+        Positive rpKeepFiles <- arbitrary+        pure RotationParameters{..}++testLogFile :: FilePath+testLogFile = "patak.log"++testLoggerConfig :: RotationParameters -> LoggerConfig+testLoggerConfig (Just -> lcRotation) = LoggerConfig{..}+  where+    lcTree = def { ltSeverity   = Just Debug+                 , ltSubloggers = HM.fromList [("test", def { ltFile = Just testLogFile })]+                 }++logThreadsNum :: Word+logThreadsNum = 1++-- | Runs 'logThreadsnum' threads to write dummy logs into @log-warper\/logs\/patak.log@ file.+writeConcurrentLogs :: RotationParameters -> IO ()+writeConcurrentLogs rp@RotationParameters{..} =+    bracket_+        (traverseLoggerConfig identity lcRotation lcTree $ Just "logs")+        releaseAllHandlers+        concurrentWriting+  where+    LoggerConfig{..}  = testLoggerConfig rp+    concurrentWriting = () <$ mapConcurrently logThread [1 .. logThreadsNum]++    -- | Starting thread with number @i@+    logThread _i = replicateM 10 $ usingLoggerName "test" $ logDebug "skovoroda"++-- | Verifies that logging in concurrent application works correctly. Thus+-- * it actually works+-- * it works when multiple threads trying to write to log file+-- * size of each file is not very big+-- * number of files is not bigger than allowed+-- TODO: more properties?+verifyLoggerRotation :: RotationParameters -> Property+verifyLoggerRotation rp@RotationParameters{..} = isValidRotation rp ==> monadicIO $ do+    run $ writeConcurrentLogs rp+    checkFilesNumber+    checkFilesSize+    run $ cleanupFiles+  where+    testLogPath  = "logs/patak.log"++    -- | Checks assert on every rolled file if this file exist+    forRolledOut :: MonadIO m => Bool -> (FilePath -> m ()) -> m ()+    forRolledOut checkNonIndexed rollAction = do+        for_ [0 .. rpKeepFiles - 1] $ \i -> do+            let logFileName = logIndex testLogPath i+            whenExist logFileName rollAction+        when checkNonIndexed $ rollAction testLogPath++    -- | Removes all files after performing tests+    cleanupFiles :: IO ()+    cleanupFiles = forRolledOut True removeFile++    checkFilesNumber :: MonadIO m => PropertyM m ()+    checkFilesNumber = do+        forRolledOut False $ \filePath -> do+            let ('.' : rest) = takeExtension  filePath+            let index = Prelude.read rest+            assert (0 <= index && index < rpKeepFiles - 1)+        for_ [rpKeepFiles .. 2 * rpKeepFiles] $ \i -> do+            let logFileName = logIndex testLogPath i+            assert =<< (not <$> liftIO (doesFileExist logFileName))++    checkFilesSize :: MonadIO m => PropertyM m ()+    checkFilesSize = forRolledOut True $ \filePath -> do+        fileSize <- liftIO $ withFile filePath ReadMode hFileSize+        assert (fromIntegral fileSize < 2 * rpLogLimit)