diff --git a/examples/Playground.hs b/examples/Playground.hs --- a/examples/Playground.hs +++ b/examples/Playground.hs @@ -12,7 +12,7 @@ modifyLoggerName, releaseAllHandlers, runPureLog, usingLoggerName) -testLogging :: CanLog m => m () +testLogging :: (CanLog m) => m () testLogging = usingLoggerName "node" $ do logDebug "skovoroda" logInfo "patak" diff --git a/log-warper.cabal b/log-warper.cabal --- a/log-warper.cabal +++ b/log-warper.cabal @@ -1,5 +1,5 @@ name: log-warper -version: 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 diff --git a/src/System/Wlog.hs b/src/System/Wlog.hs --- a/src/System/Wlog.hs +++ b/src/System/Wlog.hs @@ -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 diff --git a/src/System/Wlog/CanLog.hs b/src/System/Wlog/CanLog.hs --- a/src/System/Wlog/CanLog.hs +++ b/src/System/Wlog/CanLog.hs @@ -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), diff --git a/src/System/Wlog/FileUtils.hs b/src/System/Wlog/FileUtils.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/FileUtils.hs @@ -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 diff --git a/src/System/Wlog/Launcher.hs b/src/System/Wlog/Launcher.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/Launcher.hs @@ -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 +-- 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 diff --git a/src/System/Wlog/LoggerConfig.hs b/src/System/Wlog/LoggerConfig.hs --- a/src/System/Wlog/LoggerConfig.hs +++ b/src/System/Wlog/LoggerConfig.hs @@ -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 diff --git a/src/System/Wlog/LoggerNameBox.hs b/src/System/Wlog/LoggerNameBox.hs --- a/src/System/Wlog/LoggerNameBox.hs +++ b/src/System/Wlog/LoggerNameBox.hs @@ -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 diff --git a/src/System/Wlog/Parser.hs b/src/System/Wlog/Parser.hs deleted file mode 100644 --- a/src/System/Wlog/Parser.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/System/Wlog/Roller.hs b/src/System/Wlog/Roller.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/Roller.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,7 @@ +import Universum + +import Spec (spec) +import Test.Hspec (hspec) + +main :: IO () +main = hspec spec diff --git a/test/Test/Wlog/RollingSpec.hs b/test/Test/Wlog/RollingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Wlog/RollingSpec.hs @@ -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)