log4hs 0.4.0.0 → 0.5.0.0

raw patch · 28 files changed

+683/−962 lines, 28 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• log4hs.cabal +9/−10
• src/Logging.hs +5/−8
• src/Logging/Aeson.hs +0/−235
• src/Logging/Config/Json.hs +1/−1
• src/Logging/Config/Type.hs +13/−2
• src/Logging/Internal.hs +5/−9
• src/Logging/Prelude.hs +86/−0
• src/Logging/TH.hs +11/−0
• src/Logging/Types/Class/Filterable.hs +1/−1
• src/Logging/Types/Class/Handler.hs +5/−4
• src/Logging/Types/Filter.hs +28/−11
• src/Logging/Types/Handlers/FileHandler.hs +1/−2
• src/Logging/Types/Handlers/RotatingFileHandler.hs +18/−23
• src/Logging/Types/Level.hs +3/−3
• src/Logging/Types/Record.hs +1/−1
• src/Logging/Utils.hs +3/−67
• src/System/IO/Extra.hs +0/−7
• test/Logging/AesonSpec.hs +0/−222
• test/Logging/ConfigSpec.hs +0/−158
• test/Logging/TypesSpec.hs +0/−21
• test/LoggingSpec.hs +0/−176
• test/LoggingTest/ConfigSpec.hs +158/−0
• test/LoggingTest/InternalSpec.hs +107/−0
• test/LoggingTest/Prelude.hs +82/−0
• test/LoggingTest/TypesSpec.hs +133/−0
• test/Main.hs +1/−0
• test/Spec.hs +0/−1

@@ -5,3 +5,15 @@  ## V0.3.1 - Fix `defaultRoot` format bug++## V0.4.0+- Add `Config` module to decode `Manager` from json and yaml+- Mark `Logging.Aeson` as deprecated+- Remove `Logging.Deprecated` module++## V0.5.0+- Mark `stderrHandler` `stdoutHandler` `defaultRoot` as deprecated+- Remove `Logging.Aeson` module+- Fix `RotatingFileHandler` bug+- Refine tests+- Fix `callHandler` redundant check

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: e7973c763207cddf6697fcd36825081d9f793242e5dc25a07c6b80d710174aa8+-- hash: 8bbb99f215db2c4adcdb2ab401f23a78b09e5a05c3c874cbb6102403fa6d387d  name:           log4hs-version:        0.4.0.0+version:        0.5.0.0 synopsis:       A python logging style log library description:    Please see the http://hackage.haskell.org/package/log4hs category:       logging@@ -23,15 +23,15 @@ library   exposed-modules:       Logging-      Logging.Aeson       Logging.Config.Json       Logging.Config.Type       Logging.Config.Yaml+      Logging.Prelude       Logging.Types+      Logging.TH       Logging.Utils   other-modules:       Logging.Internal-      Logging.TH       Logging.Types.Class       Logging.Types.Class.Filterable       Logging.Types.Class.Handler@@ -45,7 +45,6 @@       Logging.Types.Manager       Logging.Types.Record       Logging.Types.Sink-      System.IO.Extra       Paths_log4hs   hs-source-dirs:       src@@ -68,12 +67,12 @@  test-suite log4hs-test   type: exitcode-stdio-1.0-  main-is: Spec.hs+  main-is: Main.hs   other-modules:-      Logging.AesonSpec-      Logging.ConfigSpec-      Logging.TypesSpec-      LoggingSpec+      LoggingTest.ConfigSpec+      LoggingTest.InternalSpec+      LoggingTest.Prelude+      LoggingTest.TypesSpec       Paths_log4hs   hs-source-dirs:       test

@@ -16,11 +16,10 @@    module Main ( main ) where -  import           Data.Aeson-  import           Data.Maybe-  import           Logging-  import           Logging.Config.Json-  import           Prelude    hiding (error)+  import           Logging             (run)+  import           Logging.Config.Json (getManager)+  import           Logging.TH          (debug, error, fatal, info, logv, warn)+  import           Prelude             hiding (error)    main :: IO ()   main = getManager "{}" >>= flip run app@@ -39,13 +38,11 @@  See "Logging.Config.Json" and "Logging.Config.Yaml" to lean more about decoding 'Manager' from json or yaml- -} module Logging   ( module Logging.Types-  , module Logging.Internal-  -- ** Logging THs   , module Logging.TH+  , module Logging.Internal   ) where  import           Logging.Internal hiding (log)

@@ -1,235 +0,0 @@-{-# OPTIONS_HADDOCK prune, ignore-exports #-}--{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}--module Logging.Aeson {-# DEPRECATED "Use Logging.Config.Json instead" #-}-  (-  -- * Aeson Instances-  ---  -- $aesondoc-  ) where--import           Control.Applicative         (pure)-import           Control.Lens                (set)-import           Data.Aeson-import           Data.Aeson.Types            (Parser, typeMismatch)-import           Data.Default-import           Data.Generics.Product.Typed-import           Data.IORef-import qualified Data.Map.Lazy               as M-import           Data.String-import           System.Directory-import           System.FilePath-import           System.IO-import           Text.Format--import           Logging.Internal-import           Logging.Types-import           Logging.Utils---{- $aesondoc--By using 'Data.Aeson', we can decode json string into 'Manager'.--__A basic 'Manager' json format:__--@-  {-    \"loggers\": {\"root\": {}, \"MyLogger\": {}},-    \"handlers\": {\"console\": {}, \"file\": {}},-    \"formatters\": {\"default\": "format", \"simple\": "format"},-    \"disabled\": false,-    \"catchUncaughtException\": true-  }-@---In practice, a set of handlers share a formatter, and other handlers share-another one, so we define all the formatters in a map, handler refernces-the formatter throught its key.--So as handlers, sinks may share same handlers.--__Examples of Formatter json__--See 'Text.Format' of vformat package for more information about formatting.--@-  "{message}"-  "{logger} {level}: {message}"-  "{logger:<20.20s} {level:<8s}: {message}"-  "{asctime:%Y-%m-%dT%H:%M:%S%6Q%z} - {level} - {logger}] {message}"-@--__Examples of 'Handler' json__--Note: Besides some common field, handler's other fields depend on its type.--@-  -- StreamHandler-  {-    \"type\": \"StreamHandler\",-    \"stream\": \"stderr\",-    \"level\": \"DEBUG\",-    \"filterer\": [\"Package.Module.Submodule\"],-    \"formatter\": \"default\",-  }--  -- FileHandler-  {-    \"type\": \"FileHandler\",-    \"file\": \"./default.log\",-    \"level\": \"INFO\",-    \"filterer\": [],-    \"formatter\": \"simple\",-  }-@--__Examples of 'Logger' ('Sink') json__--@-  -- a standard format-  {-    \"level\": \"DEBUG\",-    \"filterer\": [\"Package.Module.Submodule\"],-    \"handlers\": [\"console\"],-    \"propagate\": true,-    \"disabled\": false-  }--  -- this example is equivalent to the first-  {-    \"level\": \"DEBUG\",-    \"filterer\": [\"Package.Module.Submodule\"],-    \"handlers\": ["console"]-  }--  -- another example-  {-    \"level\": \"INFO\",-    \"handlers\": [\"console\", \"file\"],-    \"propagate\": false-  }-@--}--instance FromJSON Level where-  parseJSON v = read <$> parseJSON v---instance FromJSON Filter where-  parseJSON v = Filter <$> parseJSON v---instance FromJSON Format1 where-  parseJSON v = fromString <$> parseJSON v---instance FromJSON StreamHandler where-  parseJSON = withObject "StreamHandler" $ \v ->-      StreamHandler <$> v .:? "level" .!= def-                    <*> v .:? "filterer" .!= []-                    <*> v .:? "formatter" .!= "{message}"-                    <*> (parseStream <$> (v .:? "stream" .!= "stderr"))-    where-      parseStream :: String -> Handle-      parseStream "stderr" = stderr-      parseStream "stdout" = stdout-      parseStream _        = error "Logging.Aeson: no parse (stream)"---instance FromJSON (IO FileHandler) where-  parseJSON = withObject "FileHandler" $ \v -> do-    level <- v .:? "level" .!= def-    filterer <- v .:? "filterer" .!= []-    formatter <- v .:? "formatter" .!= "{message}"-    file <- v .:? "file" .!= "log4hs.log"-    encoding <- v .:? "encoding" .!= (show utf8)-    return $ do-      stream <- newIORef undefined-      encoding' <- mkTextEncoding encoding-      return $ FileHandler level filterer formatter file encoding' stream---instance FromJSON (IO RotatingFileHandler) where-  parseJSON = withObject "RotatingFileHandler" $ \v -> do-    level <- v .:? "level" .!= def-    filterer <- v .:? "filterer" .!= []-    formatter <- v .:? "formatter" .!= ""-    file <- v .:? "file" .!= "log4hs.log"-    encoding <- v .:? "encoding" .!= (show utf8)-    maxBytes <- v .:? "maxBytes" .!= 102400000-    backupCount <- v .:? "maxBytes" .!= 5-    return $ do-      stream <- newIORef undefined-      encoding' <- mkTextEncoding encoding-      return $ RotatingFileHandler level filterer formatter file encoding'-                                   maxBytes backupCount stream---instance FromJSON (IO SomeHandler) where-  parseJSON = withObject "Handler" $ \v -> (v .: "type") >>= (`parseHandler` v)-    where-      parseHandler :: String -> Object -> Parser (IO SomeHandler)-      parseHandler "StreamHandler" v = do-        hdl <- parseJSON (Object v)-        return $ return $ toHandler (hdl :: StreamHandler)-      parseHandler "FileHandler" v = do-        hdlIo <- parseJSON (Object v)-        return $ toHandler <$> (hdlIo :: IO FileHandler)-      parseHandler "RotatingFileHandler" v = do-        hdlIo <- parseJSON (Object v)-        return $ toHandler <$> (hdlIo :: IO RotatingFileHandler)---instance FromJSON (M.Map String Format1 -> IO SomeHandler) where-  parseJSON = withObject "Handler" $ \v -> do-    hdlio <- parseJSON (Object v)-    key <- v .:? "formatter" .!= "{message}"-    return $ \fs -> hdlio >>= \hdl -> return $-      set (typed @Format1) (M.findWithDefault "" key fs) hdl---instance FromJSON (Sink) where-  parseJSON = withObject "Sink" $ \v ->-    Sink <$> v .:? "logger" .!= "placeholder"-         <*> v .:? "level" .!= def-         <*> v .:? "filterer" .!= []-         <*> (return [])-         <*> v .:? "disabled" .!= False-         <*> v .:? "propagate" .!= False---instance FromJSON (String -> M.Map String SomeHandler -> Sink) where-  parseJSON = withObject "Sink" $ \v -> do-    sink <- parseJSON (Object v)-    keys <- v .:? "handlers" .!= []-    return $ \lgr hs -> sink { logger = if lgr == "root" then "" else lgr-                             , handlers = [hs M.! k | k <- keys]-                             }---type Formatters = M.Map String Format1-type HandlersMakerIO = M.Map String (Formatters -> IO SomeHandler)-type SinksMaker = M.Map String (String -> M.Map String SomeHandler -> Sink)--instance FromJSON (IO Manager) where-  parseJSON = withObject "Manager" $ \v -> do-    fmts :: Formatters <- v .:? "formatters" .!= (object []) >>= parseJSON-    hdls :: HandlersMakerIO <- v .:? "handlers" .!= (object []) >>= parseJSON-    sinks :: SinksMaker <- v .:? "loggers" .!= (object []) >>= parseJSON--    disabled <- v .:? "disabled" .!= False-    catchUncaughtException <- v .:? "catchUncaughtException" .!= False--    return $ do-      hdls' <- sequence $ M.map (\f -> f fmts) hdls-      let sinks' = M.mapWithKey (\k f -> f k hdls') sinks-          root = M.findWithDefault defaultRoot "root" sinks'-          sinks'' = M.delete "root" sinks'-      return $ Manager root sinks'' disabled catchUncaughtException

@@ -9,7 +9,7 @@  1) 'List' type field will use '[]' as default -2) 'Bool' type filed will use False as default+2) 'Purelude.Bool' type filed will use False as default  3) if the field is an instance of 'Data.Default.Default', use 'def' 

@@ -26,9 +26,8 @@ import qualified Prelude           as P import           Text.Format -import           Logging.Internal+import           Logging.Prelude import qualified Logging.Types     as T-import           Logging.Utils   data Handler = StreamHandler { level     :: Maybe String@@ -41,14 +40,20 @@                            , formatter :: Maybe String                            , file      :: FilePath                            , encoding  :: Maybe String+                             -- ^ See 'System.IO.mkTextEncoding',+                             -- default is utf8.                            }              | RotatingFileHandler { level       :: Maybe String                                    , filterer    :: Maybe [String]                                    , formatter   :: Maybe String                                    , file        :: FilePath                                    , encoding    :: Maybe String+                                     -- ^ See 'System.IO.mkTextEncoding',+                                     -- default is utf8.                                    , maxBytes    :: Maybe Int+                                     -- ^ Default is 100 MB.                                    , backupCount :: Maybe Int+                                     -- ^ Default is 10.                                    }               deriving (Generic, Show) @@ -100,6 +105,12 @@   where     formatters' :: Map String Format1     formatters' = maybe (singleton "" "{message}") (map fromString) formatters++    stderrHandler :: T.SomeHandler+    stderrHandler = T.toHandler $ T.StreamHandler def [] "{message}" stderr++    defaultRoot :: T.Sink+    defaultRoot = T.Sink "" "DEBUG" [] [stderrHandler] False False      createSink :: Map String T.SomeHandler -> String -> Sink -> IO T.Sink     createSink hs logger Sink{..} = do

@@ -30,8 +30,8 @@ import           System.IO                   (stderr, stdout) import           System.IO.Unsafe            (unsafePerformIO) +import           Logging.Prelude import           Logging.Types-import           Logging.Utils  {-# NOINLINE _mgr #-} _mgr :: IORef Manager@@ -108,7 +108,7 @@      callHandlers :: [SomeHandler] -> LogRecord -> IO ()     callHandlers handlers rcd = forM_ handlers $ \hdl ->-      when (isHandlerEnableFor hdl rcd) $ void $ Logging.Types.handle hdl rcd+      Logging.Types.handle hdl rcd      isSinkEnabledFor :: Sink -> LogRecord -> Bool     isSinkEnabledFor sink@Sink{..} rcd@LogRecord{level=level'}@@ -116,11 +116,8 @@       | level' < level = False       | otherwise = filter sink rcd -    isHandlerEnableFor :: SomeHandler -> LogRecord -> Bool-    isHandlerEnableFor hdl rcd@LogRecord{level=level'}-      | level' < (view (typed @Level) hdl) = False-      | otherwise = filter (view (typed @Filterer) hdl) rcd +{-# DEPRECATED stderrHandler, stdoutHandler, defaultRoot "Will be removed" #-}  -- |A 'StreamHandler' bound to 'stderr' stderrHandler :: StreamHandler@@ -130,9 +127,8 @@ stdoutHandler :: StreamHandler stdoutHandler = StreamHandler def [] "{message}" stdout -{-# NOINLINE defaultRoot #-}--- |Default root sink which is used by 'jsonToManager' when __root__ is missed.+-- |Default root sink which is used by "Logging.Config.Json" and+-- "Logging.Config.Yaml" when __root__ sink is omitted. ----- You can use it when you make 'Manager' manually. defaultRoot :: Sink defaultRoot = Sink "" "DEBUG" [] [toHandler stderrHandler] False False

@@ -0,0 +1,86 @@+{-|  This module is used internally in log4hs.++Note: don't use this module in your own projects, it may be changed at any time.+-}++module Logging.Prelude+  ( addZonedTime+  , diffZonedTime+  , zonedTimeToPOSIXSeconds+  , timestamp+  , seconds+  , milliseconds+  , microseconds+  , openLogFile+  , tryRenameFile+  , modifyBaseName+  , appendBaseName+  ) where++import           Control.Monad+import           Data.Time.Clock+import           Data.Time.Clock.POSIX+import           Data.Time.LocalTime+import           System.Directory+import           System.Environment+import           System.FilePath+import           System.IO+++instance Eq TextEncoding where+  e1 == e2 = show e1 == show e2+++addZonedTime :: NominalDiffTime -> ZonedTime -> ZonedTime+addZonedTime ndt zt@(ZonedTime _ tz) =+  utcToZonedTime tz $ addUTCTime ndt $ zonedTimeToUTC zt+++diffZonedTime :: ZonedTime -> ZonedTime -> NominalDiffTime+diffZonedTime zt1 zt2 = diffUTCTime (zonedTimeToUTC zt1) (zonedTimeToUTC zt2)+++zonedTimeToPOSIXSeconds :: ZonedTime -> NominalDiffTime+zonedTimeToPOSIXSeconds = utcTimeToPOSIXSeconds . zonedTimeToUTC+++timestamp :: NominalDiffTime -> Double+timestamp = fromRational . toRational+++seconds :: NominalDiffTime -> Integer+seconds = truncate+++milliseconds :: NominalDiffTime -> Integer+milliseconds = truncate . (* 1000)+++microseconds :: NominalDiffTime -> Integer+microseconds = truncate . (* 1000000)+++openLogFile :: FilePath -> TextEncoding -> IO Handle+openLogFile path encoding = do+  absPath <- makeAbsolute path+  progName <- getProgName+  let dir = takeDirectory absPath+      file = if dir == absPath then dir </> (progName ++ ".log") else absPath+  createDirectoryIfMissing True dir+  stream <- openFile file ReadWriteMode+  hSeek stream SeekFromEnd 0+  hSetEncoding stream encoding+  hSetBuffering stream LineBuffering+  return stream+++tryRenameFile :: FilePath -> FilePath -> IO ()+tryRenameFile src dest = doesFileExist src >>= (flip when $ renameFile src dest)+++modifyBaseName :: FilePath -> (String -> String) -> FilePath+modifyBaseName file modify = replaceBaseName file $ modify $ takeBaseName file+++appendBaseName :: FilePath -> String -> FilePath+appendBaseName file suffix = modifyBaseName file (++ suffix)

@@ -2,6 +2,17 @@ {-# LANGUAGE QuasiQuotes       #-} {-# LANGUAGE TemplateHaskell   #-} +{-| This module provides a series of log routines that create a 'LogRecord'+ and then emit a log event.++The log routines use "Language.Haskell.TH" to obtain some fields related to+where they are called,+e.g. __filename__, __pkgname__, __modulename__, __lineno__++When use these log routines, you should enable __TemplateHaskell__+language extension.+-}+ module Logging.TH   ( logv   , debug

@@ -11,4 +11,4 @@  instance Filterable a => Filterable [a] where   filter [] _       = True-  filter (f:fs) rcd = (filter f) rcd && (filter fs rcd)+  filter (f:fs) rcd = (filter f rcd) && (filter fs rcd)

@@ -67,10 +67,11 @@   close _ = return ()    handle :: a -> LogRecord -> IO Bool-  handle hdl rcd = do-    let rv = filter (view (typed @Filterer) hdl) rcd-    when rv $ emit hdl rcd-    return rv+  handle hdl rcd@LogRecord{level=level'} = do+    let level = view (typed @Level) hdl+        res = level' >= level && filter (view (typed @Filterer) hdl) rcd+    when res $ emit hdl rcd+    return res    fromHandler :: SomeHandler -> Maybe a   fromHandler (SomeHandler h) = cast h

@@ -14,24 +14,41 @@  -- | 'Filter's are used to perform arbitrary filtering of 'LogRecord's. ----- 'Sink's and 'Handler's can optionally use 'Filter' to filter records--- as desired. It allows events which are below a certain point in the--- sink hierarchy. For example, a filter initialized with "A.B" will allow+-- 'Sink's and 'Handler's can optionally use 'Filter' to filter 'LogRecord's+-- as desired.+-- It allows events which are below a certain point in the+-- sink hierarchy.+-- For example, a 'Filter' initialized with "A.B" will allow -- events logged by loggers "A.B", "A.B.C", "A.B.C.D", "A.B.D" etc. -- but not "A.BB", "B.A.B" etc.--- If initialized name with the empty string, all events are passed.-newtype Filter = Filter Logger deriving (Read, Show, Eq)+--+-- If initialized with the empty string, all events are passed.+--+-- If initialized with a predicate function, the 'Logger' will be considered as+-- the 'Filter''s name, the function will be used to filter 'LogRecord's.+data Filter = Filter Logger (Maybe (LogRecord -> Bool))  instance IsString Filter where-  fromString = Filter+  fromString = flip Filter Nothing +instance Read Filter where+  readsPrec _ s = [(fromString s, "")]++instance Show Filter where+  show (Filter logger _)         = "Filter " ++ (show logger)++-- | If two 'Filter's have same 'Logger' (name), they are equal.+instance Eq Filter where+  (Filter logger _) == (Filter logger' _) = logger == logger'+ instance Filterable Filter where-  filter (Filter self) rcd@LogRecord{..}-    | self == "" = True-    | otherwise = case stripPrefix self logger of-                    Just ""      -> True   -- self == logger-                    Just ('.':_) -> True   -- self == parent logger+  filter (Filter logger' Nothing) rcd@LogRecord{..}+    | logger' == "" = True+    | otherwise = case stripPrefix logger' logger of+                    Just ""      -> True+                    Just ('.':_) -> True                     _            -> False+  filter (Filter _ (Just f)) rcd = f rcd   -- |List of Filter

@@ -11,11 +11,10 @@ import           System.IO import           Text.Format +import           Logging.Prelude import           Logging.Types.Class import           Logging.Types.Filter import           Logging.Types.Level-import           Logging.Utils-import           System.IO.Extra   -- | A handler type which writes logging records, appropriately formatted,

@@ -12,18 +12,15 @@ import           System.IO import           Text.Format +import           Logging.Prelude import           Logging.Types.Class import           Logging.Types.Filter import           Logging.Types.Level-import           Logging.Utils-import           System.IO.Extra   -- | A handler type which writes logging records, appropriately formatted, -- to a file, it will rotate when file is too large. ----- UNTESTED--- -- Since 0.3.0 -- data RotatingFileHandler = RotatingFileHandler { level       :: Level@@ -32,6 +29,9 @@                                                , file        :: FilePath                                                , encoding    :: TextEncoding                                                , maxBytes    :: Int+                                                 -- ^ Actual file size may be+                                                 -- slightly larger than this+                                                 -- value.                                                , backupCount :: Int                                                , stream      :: IORef Handle                                                } deriving (Generic, Eq)@@ -40,29 +40,24 @@   open RotatingFileHandler{..} =     atomicWriteIORef stream =<< openLogFile file encoding -  emit RotatingFileHandler{..} rcd = do+  emit handler@RotatingFileHandler{..} rcd = do       let msg = format1 formatter rcd-      rollover $ length msg       stream' <- readIORef stream       hPutStrLn stream' msg       hFlush stream'-    where-      rollover :: Int -> IO ()-      rollover mlen = do-        stream' <- readIORef stream-        pos <- hTell =<< readIORef stream-        when (fromEnum pos + mlen >= maxBytes && backupCount > 0)  $ do+      when (backupCount > 0) $ do+        pos <- hTell stream'+        when (fromEnum pos >= maxBytes) $ do           hClose stream'-          rotateNext $ backupCount - 1-          rotateFile file $ modifyBaseName file (++ ".1")--      addSuffix :: String -> Int -> String-      addSuffix src suffix = src ++ "." ++ (show suffix)--      rotateNext :: Int -> IO ()-      rotateNext n = when (n > 0) $ do-        let src = modifyBaseName file $ flip addSuffix n-            dest = modifyBaseName file $ flip addSuffix $ n + 1-        rotateFile src dest+          rotate $ backupCount - 1+          tryRenameFile file $ appendBaseName file ".1"+          open handler+    where+      rotate :: Int -> IO ()+      rotate n = when (n > 0) $ do+        let src = appendBaseName file $ '.' : (show n)+            dest = appendBaseName file $ '.' : (show (n + 1))+        tryRenameFile src dest+        rotate (n - 1)    close RotatingFileHandler{..} = hClose =<< readIORef stream

@@ -26,9 +26,6 @@ -- newtype Level = Level Int deriving (Eq, Ord) -instance FormatArg Level where-  formatArg = formatArg . show- instance Show Level where   show (Level 0)  = "NOTSET"   show (Level 10) = "DEBUG"@@ -58,3 +55,6 @@  instance Default Level where   def = "NOTSET"++instance FormatArg Level where+  formatArg = formatArg . show

@@ -61,6 +61,6 @@                            , utctime    :: UTCTime                            , created    :: Double                            , msecs      :: Integer-                           } deriving Generic+                           } deriving (Generic, Show)  instance FormatArg LogRecord

@@ -1,70 +1,6 @@-module Logging.Utils-  ( addZonedTime-  , diffZonedTime-  , zonedTimeToPOSIXSeconds-  , timestamp-  , seconds-  , milliseconds-  , microseconds-  , openLogFile-  , rotateFile-  , modifyBaseName+module Logging.Utils {-# DEPRECATED "Renamed as Logging.Prelude" #-}+  ( module Logging.Prelude   ) where -import           Control.Monad-import           Data.Time.Clock-import           Data.Time.Clock.POSIX-import           Data.Time.LocalTime-import           System.Directory-import           System.Environment-import           System.FilePath-import           System.IO --addZonedTime :: NominalDiffTime -> ZonedTime -> ZonedTime-addZonedTime ndt zt@(ZonedTime _ tz) =-  utcToZonedTime tz $ addUTCTime ndt $ zonedTimeToUTC zt---diffZonedTime :: ZonedTime -> ZonedTime -> NominalDiffTime-diffZonedTime zt1 zt2 = diffUTCTime (zonedTimeToUTC zt1) (zonedTimeToUTC zt2)---zonedTimeToPOSIXSeconds :: ZonedTime -> NominalDiffTime-zonedTimeToPOSIXSeconds = utcTimeToPOSIXSeconds . zonedTimeToUTC---timestamp :: NominalDiffTime -> Double-timestamp = fromRational . toRational---seconds :: NominalDiffTime -> Integer-seconds = truncate---milliseconds :: NominalDiffTime -> Integer-milliseconds = truncate . (* 1000)---microseconds :: NominalDiffTime -> Integer-microseconds = truncate . (* 1000000)---openLogFile :: FilePath -> TextEncoding -> IO Handle-openLogFile path encoding = do-  absPath <- makeAbsolute path-  progName <- getProgName-  let dir = takeDirectory absPath-      file = if dir == absPath then dir </> (progName ++ ".log") else absPath-  createDirectoryIfMissing True dir-  stream <- openFile file AppendMode-  hSetEncoding stream encoding-  return stream---rotateFile :: FilePath -> FilePath -> IO ()-rotateFile src dest = doesFileExist src >>= (flip when $ renameFile src dest)---modifyBaseName :: FilePath -> (String -> String) -> FilePath-modifyBaseName file modify = replaceBaseName file $ modify $ takeBaseName file+import           Logging.Prelude

@@ -1,7 +0,0 @@-module System.IO.Extra  where--import           System.IO---instance Eq TextEncoding where-  e1 == e2 = show e1 == show e2

@@ -1,222 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE TypeApplications  #-}--module Logging.AesonSpec ( spec ) where--import           Control.Lens                (view)-import           Control.Monad-import           Data.Aeson-#if MIN_VERSION_aeson(1, 4, 3)-import           Data.Aeson.QQ.Simple        (aesonQQ)-#else-import           Data.Aeson.QQ               (aesonQQ)-#endif-import           Data.Default                (def)-import           Data.Generics.Product.Typed-import           Data.List                   (intercalate)-import qualified Data.Map                    as M-import           Data.Maybe                  (fromJust)-import           System.IO-import           System.IO.Unsafe-import           Test.Hspec-import           Test.Hspec.QuickCheck-import           Text.Format--import           Logging-import           Logging.Aeson--spec :: Spec-spec = levelSpec >> filterSpec >> handlerSpec >> sinkSpec >> managerSpec---levelSpec :: Spec-levelSpec = describe "Level" $ modifyMaxSize (const 1000) $ do-  prop "decode" $ \x -> let v = Level x in (decode $ encode $ show v) == Just v---filterSpec :: Spec-filterSpec = describe "Filter" $ modifyMaxSize (const 1000) $ do-  prop "decode" $ \fs ->-    let logger = intercalate "." fs-    in (decode $ encode logger) == Just (Filter logger)---handlerSpec :: Spec-handlerSpec = describe "Handler" $ modifyMaxSize (const 1000) $ do-  it "decode StreamHandler simple" $ do-    let StreamHandler{..} = fromJust $ decode $ encode $-          [aesonQQ|{"type": "StreamHandler"}|]-    stream == stderr `shouldBe` True-    level == def `shouldBe` True-    filterer == [] `shouldBe` True-    formatter == "{message}" `shouldBe` True--  it "decode StreamHandler standard" $ do-    let StreamHandler{..} = fromJust $ decode $ encode $-          [aesonQQ|-            {-              "type": "StreamHandler",-              "stream": "stdout",-              "level": "DEBUG",-              "filterer": ["Module.Submodule"],-              "formatter": "default"-            }-          |]--    stream == stdout `shouldBe` True-    level == "DEBUG" `shouldBe` True-    filterer == [Filter "Module.Submodule"] `shouldBe` True-    formatter == "default" `shouldBe` True--  it "decode FileHandler" $ do-    FileHandler{..} <- fromJust $ decode $ encode $-          [aesonQQ|-            {-              "type": "FileHandler",-              "file": "myapp.log",-              "encoding": "UTF-16",-              "level": "INFO",-              "filterer": ["Module.Submodule"],-              "formatter": "default"-            }-          |]--    file `shouldBe` "myapp.log"-    encoding `shouldBe` utf16-    level `shouldBe` "INFO"-    filterer == [Filter "Module.Submodule"] `shouldBe` True-    formatter == "default" `shouldBe` True--  it "decode (formatters -> SomeHandler)" $ do-    let simple = "{logger}: {message}"-        func = fromJust $ decode $ encode-          [aesonQQ|-            {-              "type": "StreamHandler",-              "level": "DEBUG",-              "filterer": ["Module.Submodule"],-              "formatter": "simple"-            }-          |]--    handler@(SomeHandler _) <- func $ M.singleton ("simple" :: String) simple-    view (typed @Level) handler == "DEBUG" `shouldBe` True-    view (typed @Filterer) handler == ["Module.Submodule"] `shouldBe` True-    view (typed @Format1) handler == simple `shouldBe` True---sinkSpec :: Spec-sinkSpec = describe "Sink" $ modifyMaxSize (const 1000) $ do-  it "decode" $ do-    let Sink{..} = fromJust $ decode $ encode $-          [aesonQQ|-            {-              "level": "DEBUG",-              "filterer": ["Module.Submodule"],-              "handlers": ["console"],-              "disabled": false,-              "propagate": true-            }-          |]--    logger `shouldBe` "placeholder"-    level `shouldBe` "DEBUG"-    filterer == ["Module.Submodule"] `shouldBe` True-    length handlers `shouldBe` 0-    disabled `shouldBe` False-    propagate `shouldBe` True--  it "decode (logger -> handlers -> sink)" $ do-    let handlerMap = M.fromList [ ("console", toHandler stderrHandler)-                                , ("file" :: String, toHandler stderrHandler)-                                ]-        func = fromJust $ decode $ encode $-              [aesonQQ|-                {-                  "level": "INFO",-                  "filterer": ["Module.Submodule"],-                  "handlers": ["console", "file"]-                }-              |]-        Sink{..} = func ("MyLogger" :: String) handlerMap--    logger `shouldBe` "MyLogger"-    level `shouldBe` "INFO"-    filterer == ["Module.Submodule"] `shouldBe` True-    length handlers `shouldBe` 2 -- deep test handlers-    disabled `shouldBe` False-    propagate `shouldBe` False---managerSpec :: Spec-managerSpec = describe "Manager" $ modifyMaxSize (const 1000) $ do-  it "decode" $ do-    let Manager{..} = manager_--    length sinks `shouldBe` 1-    M.member "MyLogger" sinks `shouldBe` True-    disabled `shouldBe` False-    catchUncaughtException `shouldBe` True--  it "decode root" $ do-    let Sink{..} = root manager_--    logger `shouldBe` ""-    level `shouldBe` "DEBUG"-    disabled `shouldBe` False-    propagate `shouldBe` False-    length filterer `shouldBe` 0-    length handlers `shouldBe` 1--  it "decode sinks" $ do-    let Sink{..} = (sinks manager_) M.! "MyLogger"--    logger `shouldBe` "MyLogger"-    level `shouldBe` "INFO"-    propagate `shouldBe` False-    disabled `shouldBe` False-    length filterer `shouldBe` 1-    filterer == ["MyLogger.Main"] `shouldBe` True-    length handlers `shouldBe` 2----- Decoding manager globally, or it will throw file resouse busy error-manager_ :: Manager-{-# NOINLINE manager_ #-}-manager_ = unsafePerformIO $ fromJust $ decode $ encode [aesonQQ|{-  "catchUncaughtException": true,-  "loggers": {-      "root": {-        "level": "DEBUG",-        "handlers": ["console"],-        "propagate": false-      },-      "MyLogger": {-        "level": "INFO",-        "filterer": ["MyLogger.Main"],-        "handlers": ["console", "file"],-        "propagate": false-      }-    },-    "handlers": {-      "console": {-        "type": "StreamHandler",-        "stream": "stderr",-        "level": "DEBUG",-        "formatter": "default"-      },-      "file": {-        "type": "FileHandler",-        "level": "INFO",-        "formatter": "default",-        "file": "./default.log"-      }-    },-    "formatters": {-      "default": "{asctime} - {level} - {logger}:{lineno}] {message}"-    }-}|]

@@ -1,158 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE RecordWildCards   #-}--module Logging.ConfigSpec ( spec ) where---import           Data.Aeson            as Json-#if MIN_VERSION_aeson(1, 4, 3)-import           Data.Aeson.QQ.Simple  (aesonQQ)-#else-import           Data.Aeson.QQ         (aesonQQ)-#endif-import           Data.ByteString       (ByteString, pack, writeFile)-import           Data.ByteString.Lazy  (unpack)-import qualified Data.Map              as M-import           Data.Yaml             as Yaml-import           Data.Yaml.TH-import           Prelude               hiding (writeFile)-import           System.Directory-import           Test.Hspec-import           Test.Hspec.QuickCheck--import           Logging-import           Logging.Config.Json   as Json-import           Logging.Config.Yaml   as Yaml---spec :: Spec-spec = beforeAll_ prepare $-  describe "Config & Manager" $ modifyMaxSize (const 1000) $ do-    it "json" $ do-      Manager{..} <- Json.getManager jsonRaw-      length sinks `shouldBe` 1-      M.member "MyLogger" sinks `shouldBe` True-      disabled `shouldBe` False-      catchUncaughtException `shouldBe` True--    it "yaml" $ do-      Manager{..} <- Yaml.getManager yamlRaw-      length sinks `shouldBe` 1-      M.member "MyLogger" sinks `shouldBe` True-      disabled `shouldBe` False-      catchUncaughtException `shouldBe` True--    it "json file" $ do-      Manager{..} <- Json.getManagerFile "/tmp/log4hs/config.json"-      length sinks `shouldBe` 1-      M.member "MyLogger" sinks `shouldBe` True-      disabled `shouldBe` False-      catchUncaughtException `shouldBe` True--    it "yaml file" $ do-      Manager{..} <- Yaml.getManagerFile "/tmp/log4hs/config.yaml"-      length sinks `shouldBe` 1-      M.member "MyLogger" sinks `shouldBe` True-      disabled `shouldBe` False-      catchUncaughtException `shouldBe` True--    it "root sink" $ do-      Sink{..} <- root <$> (Json.getManager jsonRaw)--      logger `shouldBe` ""-      level `shouldBe` "DEBUG"-      disabled `shouldBe` False-      propagate `shouldBe` False-      length filterer `shouldBe` 0-      length handlers `shouldBe` 1--    it "sinks" $ do-      Sink{..} <- (flip (M.!) "MyLogger" . sinks) <$> (Json.getManager jsonRaw)--      logger `shouldBe` "MyLogger"-      level `shouldBe` "INFO"-      propagate `shouldBe` False-      disabled `shouldBe` False-      length filterer `shouldBe` 1-      filterer == ["MyLogger.Main"] `shouldBe` True-      length handlers `shouldBe` 2---prepare :: IO ()-prepare = do-  createDirectoryIfMissing False "/tmp/log4hs"-  writeFile "/tmp/log4hs/config.json" jsonRaw-  writeFile "/tmp/log4hs/config.yaml" yamlRaw---jsonRaw :: ByteString-jsonRaw = pack $ unpack $ Json.encode-  [aesonQQ|{-    "sinks": {-      "root": {-        "level": "DEBUG",-        "handlers": ["console"],-        "propagate": false-      },-      "MyLogger": {-        "level": "INFO",-        "filterer": ["MyLogger.Main"],-        "handlers": ["console", "file"],-        "propagate": false-      }-    },-    "handlers": {-      "console": {-        "type": "StreamHandler",-        "stream": "stderr",-        "level": "DEBUG",-        "formatter": "default"-      },-      "file": {-        "type": "FileHandler",-        "level": "INFO",-        "formatter": "default",-        "file": "./default.log"-      }-    },-    "formatters": {-      "default": "{asctime} - {level} - {logger}:{lineno}] {message}"-    },-    "catchUncaughtException": true-  }|]---yamlRaw :: ByteString-yamlRaw = Yaml.encode-  [yamlQQ|-    sinks:-      root:-        level: DEBUG-        handlers:-        - console-        propagate: false-      MyLogger:-        level: INFO-        filterer:-        - MyLogger.Main-        handlers:-        - console-        - file-        propagate: false-    handlers:-      console:-        type: StreamHandler-        stream: stderr-        level: DEBUG-        formatter: default-      file:-        type: FileHandler-        level: INFO-        formatter: default-        file: "./default.log"-    formatters:-      default: "{asctime} - {level} - {logger}:{lineno}] {message}"-    catchUncaughtException: true-  |]

@@ -1,21 +0,0 @@-{-# LANGUAGE RecordWildCards    #-}-{-# LANGUAGE StandaloneDeriving #-}--module Logging.TypesSpec ( spec ) where--import           Data.String           (fromString)-import           Test.Hspec-import           Test.Hspec.QuickCheck-import           Test.QuickCheck--import           Logging.Types-import           Logging.Utils--spec :: Spec-spec = levelSpec---levelSpec :: Spec-levelSpec = describe "Level" $ modifyMaxSize (const 1000) $ do-  prop "read and show" $ \x -> (read . show) (Level x) == (Level x)-  prop "overload string" $ \x -> fromString (show (Level x)) == (Level x)

@@ -1,176 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TemplateHaskell   #-}--module LoggingSpec ( spec ) where--import           Control.Monad-import           Data.Default            (def)-import           Data.List               (intercalate)-import qualified Data.Map                as M-import           Data.Word-import           Prelude                 hiding (error)-import           System.IO-import           System.IO.Unsafe        (unsafePerformIO)-import           System.Process          (createPipe)-import           Test.Hspec-import           Test.Hspec.QuickCheck-import           Test.QuickCheck         hiding (run)-import qualified Test.QuickCheck.Monadic as Q-import           Text.Format--import           Logging--spec :: Spec-spec = basicSpec >> formatSpec >> filterSpec >> propagateSpec---basicSpec :: Spec-basicSpec = describe "Basic" $ modifyMaxSize (const 1000) $ do-  prop "log to root" $ \(PrintableString msg) ->-    runLog "" "DEBUG" msg "debug" (== msg)-  prop "log to Log4hs" $ \(PrintableString msg) ->-    runLog "Log4hs" "INFO" msg "debug" (== msg)-  prop "log to Log4hs.Json" $ \(PrintableString msg) ->-    runLog "Log4hs.Json" "WARN" msg "debug" (== msg)-  prop "disabled some" $ \(PrintableString msg) level ->-    runLog "Log10000hs" level msg "debug" (== "")-  prop "disabled all" $ \(PrintableString msg) loggers level ->-    let logger = intercalate "." $ [getPrintableString x | x <- loggers]-    in runDisabledLog logger level msg---formatSpec :: Spec-formatSpec = describe "Format" $ modifyMaxSize (const 1000) $ do-  prop "simple" $ \(PrintableString msg) ->-    runLog "" "DEBUG" msg "debug" (== msg)-  prop "logger" $ \(PrintableString msg) (Log4hsLogger logger) -> do-    runLog logger "WARN" msg "info" (== logger ++ ": " ++ msg)-  prop "level" $ \(PrintableString msg) (Log4hsLogger logger) fmtlevel ->-    let (Log4hsHighLevel level) = fmtlevel-        out = logger ++ " " ++ (show level) ++ "] " ++ msg-    in runLog logger level msg "error" (== out)---filterSpec :: Spec-filterSpec = describe "Filter" $ modifyMaxSize (const 1000) $ do-  prop "root sink && debug handler" $ \(PrintableString msg) level ->-    runLog "" level msg "debug" $ (== if level >= "DEBUG" then msg else "")-  prop "Log4hs sink && info handler" $ \(PrintableString msg) level ->-    let out = if level >= "INFO" then "Log4hs: " ++ msg else ""-    in runLog "Log4hs" level msg "info" $ (== out)-  prop "Log4hs.Json sink && error handler" $ \(PrintableString msg) level ->-    let out = if level >= "ERROR"-                then "Log4hs.Json " ++ (show level) ++ "] " ++ msg-                else ""-    in runLog "Log4hs.Json" level msg "error" $ (== out)-  prop "handler's filterer" $ \(PrintableString msg) (Small v)->-    let logger = "Log4hs.V" ++ (show v)-        out = if v == (3 :: Word8) then logger ++ ": " ++ msg else ""-    in runLog logger "INFO" msg "infov3" (== out)---propagateSpec :: Spec-propagateSpec = describe "Propagate" $ modifyMaxSize (const 1000) $ do-  prop "to root (real)" $ \(PrintableString msg) ->-    runLog "Log8hs" "WARN" msg "debug" $ (== msg)-  prop "to root (virtual)" $ \(PrintableString msg) ->-    runLog "Log0hs" "WARN" msg "debug" $ (== msg)-  prop "to parent (real)" $ \(PrintableString msg) ->-    runLog "Log4hs.Json" "WARN" msg "info" $ (== "Log4hs.Json: " ++ msg)-  prop "to parent (virtual)" $ \(PrintableString msg) ->-    runLog "Log4hs.Ini" "WARN" msg "info" $ (== "Log4hs.Ini: " ++ msg)-  prop "to grandparent (real)" $ \(PrintableString msg) ->-    runLog "Log8hs.Json" "WARN" msg "debug" $ (== msg)-  prop "to grandparent (virtual)" $ \(PrintableString msg) ->-    runLog "Log0hs.Json" "WARN" msg "debug" $ (== msg)-  prop "disabled" $ \(PrintableString msg) ->-    runLog "Log4hs" "FATAL" msg "fatal" $ (== "")---runLog :: Logger -> Level -> String -> String -> (String -> Bool) -> Property-runLog logger level msg stream test = Q.monadicIO $ do-  out <- Q.run $ createManager False >>= \(mgr, streams) -> run mgr $-    $(logv) logger level msg  >> hTryGetLine (streams M.! stream)-  Q.assert $ test out---runDisabledLog :: Logger -> Level -> String -> Property-runDisabledLog logger level msg = Q.monadicIO $ do-  outs <- Q.run $ createManager True >>= \(mgr, streams) -> run mgr $-    $(logv) logger level msg  >> sequence (M.map hTryGetLine streams)-  Q.assert $ M.empty == M.filter (/= "") outs---createManager :: Bool -> IO (Manager, M.Map String Handle)-createManager disabled = do-  debugPh <- createPipeHandler "DEBUG" [] (formatters M.! "simple")-  infoPh <- createPipeHandler "INFO" [] (formatters M.! "logger")-  infov3Ph <- createPipeHandler "INFO" ["Log4hs.V3"] (formatters M.! "logger")-  errorPh <- createPipeHandler "ERROR" [] (formatters M.! "level")-  fatalPh <- createPipeHandler "FATAL" [] (formatters M.! "logger")--  let root = Sink "" "DEBUG" [] [fst debugPh, fst fatalPh] False False-      handlers = [fst debugPh, fst infoPh, fst infov3Ph, fst errorPh]-      log4hs = Sink "Log4hs" "INFO" [] handlers False False-      log4hsJson = Sink "Log4hs.Json" "WARN" [] [] False True-      log4hsYaml = Sink "Log4hs.Yaml" "WARN" [] [] False True-      log8hs = Sink "Log8hs" "INFO" [] [] False True-      log8hsJson = Sink "Log8hs.Json" "INFO" [] [] False True-      log10000hs = Sink "Log8hs.Json" "INFO" [] [fst debugPh] True False-      sinks = M.fromList [ ("Log4hs", log4hs)-                         , ("Log4hs.Json", log4hsJson)-                         , ("Log4hs.Yaml", log4hsYaml)-                         , ("Log8hs", log8hs)-                         , ("Log8hs.Json", log8hsJson)-                         , ("Log10000hs", log10000hs)-                         ]-      streams = M.fromList $ [ ("debug", snd debugPh)-                             , ("info", snd infoPh)-                             , ("infov3", snd infov3Ph)-                             , ("error", snd errorPh)-                             , ("fatal", snd fatalPh)-                             ]-  return (Manager root sinks disabled False, streams)---formatters :: M.Map String Format1-formatters = M.fromList-  [ ("simple", "{message}")-  , ("logger", "{logger}: {message}")-  , ("level", "{logger} {level}] {message}")-  ]---createPipeHandler :: Level -> Filterer -> Format1 -> IO (SomeHandler, Handle)-createPipeHandler level filterer formatter = do-  (read, write) <- createPipe-  hSetEncoding read utf8-  hSetEncoding write utf8-  return $ ( toHandler $ StreamHandler level filterer formatter write-           , read-           )---hTryGetLine :: Handle -> IO String-hTryGetLine hdl = do-  ready <- hReady hdl-  if ready then hGetLine hdl else return ""---instance Arbitrary Level where-  arbitrary = Level <$> arbitrary---newtype Log4hsLogger = Log4hsLogger Logger deriving Show--instance Arbitrary Log4hsLogger where-  arbitrary = elements $-    map Log4hsLogger ["Log4hs", "Log4hs.Json", "Log4hs.Yaml"]---newtype Log4hsHighLevel = Log4hsHighLevel Level deriving Show--instance Arbitrary Log4hsHighLevel where-  arbitrary = elements $ map Log4hsHighLevel ["ERROR", "FATAL", Level 100]

@@ -0,0 +1,158 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE RecordWildCards   #-}++module LoggingTest.ConfigSpec ( spec ) where+++import           Data.Aeson            as Json+#if MIN_VERSION_aeson(1, 4, 3)+import           Data.Aeson.QQ.Simple  (aesonQQ)+#else+import           Data.Aeson.QQ         (aesonQQ)+#endif+import           Data.ByteString       (ByteString, pack, writeFile)+import           Data.ByteString.Lazy  (unpack)+import qualified Data.Map              as M+import           Data.Yaml             as Yaml+import           Data.Yaml.TH+import           Prelude               hiding (writeFile)+import           System.Directory+import           Test.Hspec+import           Test.Hspec.QuickCheck++import           Logging+import           Logging.Config.Json   as Json+import           Logging.Config.Yaml   as Yaml+++spec :: Spec+spec = beforeAll_ prepare $+  describe "Config & Manager" $ modifyMaxSize (const 1000) $ do+    it "json" $ do+      Manager{..} <- Json.getManager jsonRaw+      length sinks `shouldBe` 1+      M.member "MyLogger" sinks `shouldBe` True+      disabled `shouldBe` False+      catchUncaughtException `shouldBe` True++    it "yaml" $ do+      Manager{..} <- Yaml.getManager yamlRaw+      length sinks `shouldBe` 1+      M.member "MyLogger" sinks `shouldBe` True+      disabled `shouldBe` False+      catchUncaughtException `shouldBe` True++    it "json file" $ do+      Manager{..} <- Json.getManagerFile "/tmp/log4hs/config.json"+      length sinks `shouldBe` 1+      M.member "MyLogger" sinks `shouldBe` True+      disabled `shouldBe` False+      catchUncaughtException `shouldBe` True++    it "yaml file" $ do+      Manager{..} <- Yaml.getManagerFile "/tmp/log4hs/config.yaml"+      length sinks `shouldBe` 1+      M.member "MyLogger" sinks `shouldBe` True+      disabled `shouldBe` False+      catchUncaughtException `shouldBe` True++    it "root sink" $ do+      Sink{..} <- root <$> (Json.getManager jsonRaw)++      logger `shouldBe` ""+      level `shouldBe` "DEBUG"+      disabled `shouldBe` False+      propagate `shouldBe` False+      length filterer `shouldBe` 0+      length handlers `shouldBe` 1++    it "sinks" $ do+      Sink{..} <- (flip (M.!) "MyLogger" . sinks) <$> (Json.getManager jsonRaw)++      logger `shouldBe` "MyLogger"+      level `shouldBe` "INFO"+      propagate `shouldBe` False+      disabled `shouldBe` False+      length filterer `shouldBe` 1+      filterer == ["MyLogger.Main"] `shouldBe` True+      length handlers `shouldBe` 2+++prepare :: IO ()+prepare = do+  createDirectoryIfMissing False "/tmp/log4hs"+  writeFile "/tmp/log4hs/config.json" jsonRaw+  writeFile "/tmp/log4hs/config.yaml" yamlRaw+++jsonRaw :: ByteString+jsonRaw = pack $ unpack $ Json.encode+  [aesonQQ|{+    "sinks": {+      "root": {+        "level": "DEBUG",+        "handlers": ["console"],+        "propagate": false+      },+      "MyLogger": {+        "level": "INFO",+        "filterer": ["MyLogger.Main"],+        "handlers": ["console", "file"],+        "propagate": false+      }+    },+    "handlers": {+      "console": {+        "type": "StreamHandler",+        "stream": "stderr",+        "level": "DEBUG",+        "formatter": "default"+      },+      "file": {+        "type": "FileHandler",+        "level": "INFO",+        "formatter": "default",+        "file": "./default.log"+      }+    },+    "formatters": {+      "default": "{asctime} - {level} - {logger}:{lineno}] {message}"+    },+    "catchUncaughtException": true+  }|]+++yamlRaw :: ByteString+yamlRaw = Yaml.encode+  [yamlQQ|+    sinks:+      root:+        level: DEBUG+        handlers:+        - console+        propagate: false+      MyLogger:+        level: INFO+        filterer:+        - MyLogger.Main+        handlers:+        - console+        - file+        propagate: false+    handlers:+      console:+        type: StreamHandler+        stream: stderr+        level: DEBUG+        formatter: default+      file:+        type: FileHandler+        level: INFO+        formatter: default+        file: "./default.log"+    formatters:+      default: "{asctime} - {level} - {logger}:{lineno}] {message}"+    catchUncaughtException: true+  |]

@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}++module LoggingTest.InternalSpec ( spec ) where++import           Control.Monad+import           Data.Default            (def)+import           Data.List               (intercalate)+import qualified Data.Map                as M+import           Data.Word+import           Prelude                 hiding (error)+import           System.IO+import           System.IO.Unsafe        (unsafePerformIO)+import           System.Process          (createPipe)+import           Test.Hspec+import           Test.Hspec.QuickCheck+import           Test.QuickCheck+import           Test.QuickCheck.Monadic+import           Text.Format++import           Logging                 hiding (run)+import           Logging.TH+import           LoggingTest.Prelude++spec :: Spec+spec = describe "run & log" $ do+  let levels = ["DEBUG", "INFO", "WARN", "ERROR", "FATAL"]+      loggers = [ ("root", "DEBUG", [], ["DEBUG"], False, False)+                , ("Disabled", "DEBUG", [], ["DEBUG"], True, False)+                , ("Debug", "DEBUG", [], ["DEBUG", "INFO"], False, False)+                , ("Info", "INFO", ["Info.A"], ["DEBUG", "INFO"], False, False)+                , ("Warn", "WARN", [], ["WARN"], False, False)+                , ("Warn.Error", "ERROR", [], ["ERROR"], False, False)+                , ("Error", "ERROR", [], ["ERROR"], False, True)+                , ("Error.Fatal", "FATAL", [], ["FATAL"], False, True)+                ]+  handlers <- fmap M.fromList $ runIO $ forM levels $ \level -> do+    (read, write) <- createPipe+    hSetEncoding read utf8 >> hSetEncoding write utf8+    let handler = toHandler $ StreamHandler level [] "{message}" write+    return $ (level, (handler, read))+  sinks <- fmap M.fromList $ runIO $ forM loggers $ \item -> do+    let (logger, level, fs, hs, disabled, propagate) = item+        logger' = if logger == "root" then "" else logger+        hs' = [fst (handlers M.! h) | h <- hs]+        sink = Sink logger' level fs hs' disabled propagate+    return (logger, sink)++  let root = sinks M.! "root"+      sinks' = M.delete "root" sinks+      disabledManager = Manager root sinks' True False+      manager = Manager root sinks' False False++  prop "filter" $ \(MessageString message) -> monadicIO $ do+    -- manager disabled+    run $ runLog disabledManager $ $(info) "Debug" message+    msgs <- run $ forM ["DEBUG", "INFO"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ ["", ""] ==  msgs+    -- sink disabled+    run $ runLog manager $ $(debug) "Disabled" message+    msg1 <- run $ hTryGetLine $ snd $ handlers M.! "DEBUG"+    assert $ msg1 == ""+    -- sink level reject+    run $ runLog manager $ $(debug) "Info.A" message+    msgs1 <- run $ forM ["DEBUG", "INFO"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ ["", ""] == msgs1+    -- sink filterer reject+    run $ runLog manager $ $(info) "Info.B" message+    msgs2 <- run $ forM ["DEBUG", "INFO"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ ["", ""] ==  msgs2+    -- pass 1+    run $ runLog manager $ $(info) "Debug" message+    msgs3 <- run $ forM ["DEBUG", "INFO"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ [message, message] == msgs3+    -- pass 2+    run $ runLog manager $ $(info) "Info.A" message+    msgs4 <- run $ forM ["DEBUG", "INFO"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ [message, message] == msgs4++  prop "propagate" $ \(MessageString message) -> monadicIO $ do+    -- propagation disabled 1+    run $ runLog manager $ $(warn) "Warn" message+    msgs <- run $ forM ["DEBUG", "WARN"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ ["", message] == msgs+    -- propagation disabled 2+    run $ runLog manager $ $(error) "Warn.Error" message+    msgs1 <- run $ forM ["DEBUG", "WARN", "ERROR"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ ["", "", message] == msgs1+    -- propagation enabled 1+    run $ runLog manager $ $(error) "Error" message+    msgs2 <- run $ forM ["DEBUG", "ERROR"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ [message, message] == msgs2+    -- propagation enabled 2+    run $ runLog manager $ $(fatal) "Error.Fatal" message+    msgs3 <- run $ forM ["DEBUG", "ERROR", "FATAL"] $ \level ->+      hTryGetLine $ snd $ handlers M.! level+    assert $ [message, message, message] == msgs3

@@ -0,0 +1,82 @@+{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE RecordWildCards #-}++module LoggingTest.Prelude+  ( Alphabet(..)+  , LoggerString(..)+  , MessageString(..)+  , hTryGetLine+  , parent+  , runLog+  ) where+++import           Control.Monad+import           Data.List           (dropWhileEnd, intersperse)+import           Data.String+import           Data.Time.LocalTime+import           System.IO+import           Test.QuickCheck++import qualified Logging+import           Logging.Prelude+import           Logging.Types+++data Alphabet = Alphabet { getAlphabet :: Char } deriving Show++instance Arbitrary Alphabet where+  arbitrary = Alphabet <$> elements ['a'..'z']+++instance Arbitrary Level where+  arbitrary = (Level . getNonNegative) <$> arbitrary+++newtype LoggerString = LoggerString { getLoggerString :: Logger }++instance Arbitrary LoggerString where+  arbitrary = do+    ls <- listOf (elements ['A'..'Z'])+    return $ LoggerString $ intersperse '.' $ ls+++newtype MessageString = MessageString { getMessageString :: String+                                      } deriving Show++instance Arbitrary MessageString where+  arbitrary = do+    ms <- forM [1..99] $ \_ -> arbitraryUnicodeChar `suchThat` (/= '\n')+    return $ MessageString ms+++instance Arbitrary LogRecord where+  arbitrary = do+    logger <- getLoggerString <$> arbitrary+    level <- arbitrary+    message <- getMessageString <$> arbitrary+    pathname <- arbitrary+    filename <- arbitrary+    pkgname <- arbitrary+    modulename <- arbitrary+    lineno <- arbitrary+    let asctime = read "1970-01-01 00:00:00"+        utctime = zonedTimeToUTC asctime+        difftime = zonedTimeToPOSIXSeconds asctime+        created = timestamp difftime+        msecs   = milliseconds difftime+    return $ LogRecord{..}+++hTryGetLine :: Handle -> IO String+hTryGetLine hdl = do+  ready <- hReady hdl+  if ready then hGetLine hdl else return ""+++parent :: Logger -> Logger+parent = dropWhileEnd (== '.') . dropWhileEnd (/= '.')+++runLog :: Manager -> IO a -> IO a+runLog = Logging.run

@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeApplications  #-}++module LoggingTest.TypesSpec ( spec ) where++import           Control.Lens                hiding (Level (..))+import           Control.Monad+import           Data.Default                (def)+import           Data.Generics.Product.Typed+import           Data.IORef+import           Data.String                 (fromString)+import           Prelude                     hiding (filter)+import           System.IO+import           System.Process              (createPipe)+import           Test.Hspec+import           Test.Hspec.QuickCheck+import           Test.QuickCheck+import           Test.QuickCheck.Monadic++import           Logging.Prelude+import           Logging.Types+import           LoggingTest.Prelude++spec :: Spec+spec = do+  levelSpec+  filterSpec+  handlerSpec+++levelSpec :: Spec+levelSpec = describe "Level" $ do+  prop "read & show" $ \v ->+    let level = Level v in read (show level) == level++  prop "overload string" $ \v ->+    let level = Level v in fromString (show level) == level++filterSpec :: Spec+filterSpec = describe "Filter" $ do+  prop "pass" $ \rcd@LogRecord{..} ->+    let filterer = map fromString $+                    [logger, parent logger, parent $ parent logger, ""]+    in filter (filterer :: Filterer) rcd++  prop "reject" $ \rcd@LogRecord{..} ->+    let filters = map (fromString . (++ "Test")) $+                    [logger, parent logger, parent $ parent logger, ""]+    in all (== False) [filter (f :: Filter) rcd | f <- filters]+++handlerSpec :: Spec+handlerSpec = describe "Handler" $ do+  (read, write) <- runIO createPipe+  fileRef <- runIO $ newIORef undefined+  rotateFileRef <- runIO $ newIORef undefined+  runIO $ hSetEncoding read utf8 >> hSetEncoding write utf8+  let handler = toHandler $ StreamHandler def [] "{message}" write+      fileHandler = toHandler $+        FileHandler def [] "{message}" "/tmp/log4hs/file.log" utf8 fileRef+      rotateHandler = toHandler $+        RotatingFileHandler def [] "{message}" "/tmp/log4hs/rotate.log" utf8+          1000 5 rotateFileRef+  runIO $ open handler >> open fileHandler >> open rotateHandler++  prop "filter" $ \(rcd@LogRecord{..}) -> monadicIO $ do+    let loggers = [logger, parent logger, parent $ parent logger, ""]+    -- level reject+    forM_ logger $ \logger -> do+      let handler' = handler & typed @Level .~ (succ level)+      res <- run $ handle handler' rcd+      assert $ not res+    -- filterer reject+    forM_ loggers $ \logger -> do+      let handler' = handler & typed @Filterer .~ [fromString $ logger ++ "Test"]+      res <- run $ handle handler' rcd+      assert $ not res+    -- filterer pass+    forM_ loggers $ \logger -> do+      let handler' = handler & typed @Filterer .~ [fromString logger]+      res <- run $ handle handler' rcd+      msg <- run $ hTryGetLine read+      assert res+      assert (msg == message)+    -- empty filterer+    res <- run $ handle handler rcd+    msg <- run $ hTryGetLine read+    assert res+    assert (msg == message)++  prop "file" $ \(rcd@LogRecord{..}) -> monadicIO $ do+    file <- run $ readIORef fileRef+    run $ hSetFileSize file 0 >> hSeek file AbsoluteSeek 0+    run $ handle fileHandler rcd+    run $ hSeek file AbsoluteSeek 0+    msg <- run $ hTryGetLine file+    assert (msg == message)++  prop "rotate" $ \(rcd, Alphabet c) -> monadicIO $ do+    file <- run $ readIORef rotateFileRef+    run $ hSetFileSize file 0 >> hSeek file AbsoluteSeek 0+    let message = replicate 99 c+        rcd' = rcd { message = message }+    -- not rollover yet+    run $ forM [1..9] $ \_ -> handle rotateHandler rcd'+    run $ hSeek file AbsoluteSeek 0+    msgs <- run $ forM [1..9] $ \_ -> hTryGetLine file+    assert $ all (== message) msgs+    -- rollover+    run $ handle rotateHandler rcd'+    closed <- run $ hIsClosed file+    assert closed+    pos <- run $ readIORef rotateFileRef >>= hTell+    assert (pos == 0)+    -- rotate.1.log+    file1 <- run $ openLogFile "/tmp/log4hs/rotate.1.log" utf8+    run $ hSeek file1 AbsoluteSeek 0+    msgs1 <- run $ forM [1..10] $ \_ -> hTryGetLine file1+    run $ hClose file1+    assert $ all (== message) msgs1+    -- rollover again+    file' <- run $ readIORef rotateFileRef+    run $ forM [1..10] $ \_ -> handle rotateHandler rcd'+    closed1 <- run $ hIsClosed file'+    assert closed1+    -- rotate.2.log+    file2 <- run $ openLogFile "/tmp/log4hs/rotate.2.log" utf8+    run $ hSeek file2 AbsoluteSeek 0+    msgs2 <- run $ forM [1..10] $ \_ -> hTryGetLine file2+    run $ hClose file2+    -- rotate.2.log+    assert $ all (== message) msgs2

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}