log4hs 0.6.0.0 → 0.7.0.0

raw patch · 44 files changed

+1028/−600 lines, 44 filesdep +vformat-timedep ~vformatPVP ok

version bump matches the API change (PVP)

Dependencies added: vformat-time

Dependency ranges changed: vformat

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• log4hs.cabal +22/−19
• src/Logging/Class.hs +8/−0
• src/Logging/Class/Filterable.hs +14/−0
• src/Logging/Class/Handler.hs +94/−0
• src/Logging/Config/Json.hs +1/−1
• src/Logging/Config/Type.hs +50/−7
• src/Logging/Config/Yaml.hs +1/−1
• src/Logging/Filter.hs +55/−0
• src/Logging/Global.hs +1/−1
• src/Logging/Global/Internal.hs +36/−2
• src/Logging/Global/TH.hs +3/−3
• src/Logging/Handler/FileHandler.hs +41/−0
• src/Logging/Handler/RotatingFileHandler.hs +74/−0
• src/Logging/Handler/StreamHandler.hs +30/−0
• src/Logging/Handler/TimeRotatingFileHandler.hs +198/−0
• src/Logging/Level.hs +60/−0
• src/Logging/Logger.hs +5/−0
• src/Logging/Manager.hs +37/−0
• src/Logging/Monad.hs +1/−1
• src/Logging/Monad/Internal.hs +19/−16
• src/Logging/Monad/TH.hs +3/−3
• src/Logging/Prelude.hs +13/−0
• src/Logging/Record.hs +77/−0
• src/Logging/Sink.hs +44/−0
• src/Logging/TH.hs +1/−1
• src/Logging/Types.hs +21/−17
• src/Logging/Types/Class.hs +0/−8
• src/Logging/Types/Class/Filterable.hs +0/−14
• src/Logging/Types/Class/Handler.hs +0/−80
• src/Logging/Types/Filter.hs +0/−55
• src/Logging/Types/Handlers.hs +0/−9
• src/Logging/Types/Handlers/FileHandler.hs +0/−39
• src/Logging/Types/Handlers/RotatingFileHandler.hs +0/−63
• src/Logging/Types/Handlers/StreamHandler.hs +0/−29
• src/Logging/Types/Level.hs +0/−60
• src/Logging/Types/Logger.hs +0/−5
• src/Logging/Types/Manager.hs +0/−34
• src/Logging/Types/Record.hs +0/−66
• src/Logging/Types/Sink.hs +0/−40
• test/LoggingTest/ConfigSpec.hs +2/−1
• test/LoggingTest/GlobalSpec.hs +29/−11
• test/LoggingTest/Prelude.hs +17/−3
• test/LoggingTest/TypesSpec.hs +65/−11

@@ -22,3 +22,9 @@ - Add local logging (run in monad) - Redesign global logging - Remove `stderrHandler` `stdoutHandler` `defaultRoot`++## V0.7.0+- Fix `RotatingFileHandler` rollover bug+- Flatten `Logging.Types`+- Make timezone of logging environment configurable+- Add `TimeRotatingFileHandler`

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 621a17085d5d95bc8f29ab4cb601c416c58065b9290beebafdcf7544be009732+-- hash: cbfd6363e7bbeaee5e3e8cc995db591bf20b5f5ae9b3c4e159ad8501ed2a3cfe  name:           log4hs-version:        0.6.0.0+version:        0.7.0.0 synopsis:       A python logging style log library description:    Please see the http://hackage.haskell.org/package/log4hs category:       logging@@ -23,33 +23,33 @@ library   exposed-modules:       Logging+      Logging.Class       Logging.Config.Json       Logging.Config.Type       Logging.Config.Yaml+      Logging.Filter       Logging.Global       Logging.Global.TH+      Logging.Handler.FileHandler+      Logging.Handler.RotatingFileHandler+      Logging.Handler.StreamHandler+      Logging.Handler.TimeRotatingFileHandler+      Logging.Level+      Logging.Logger+      Logging.Manager       Logging.Monad       Logging.Monad.TH       Logging.Prelude-      Logging.Types+      Logging.Record+      Logging.Sink       Logging.TH+      Logging.Types       Logging.Utils   other-modules:+      Logging.Class.Filterable+      Logging.Class.Handler       Logging.Global.Internal       Logging.Monad.Internal-      Logging.Types.Class-      Logging.Types.Class.Filterable-      Logging.Types.Class.Handler-      Logging.Types.Filter-      Logging.Types.Handlers-      Logging.Types.Handlers.FileHandler-      Logging.Types.Handlers.RotatingFileHandler-      Logging.Types.Handlers.StreamHandler-      Logging.Types.Level-      Logging.Types.Logger-      Logging.Types.Manager-      Logging.Types.Record-      Logging.Types.Sink       Paths_log4hs   hs-source-dirs:       src@@ -67,7 +67,8 @@     , template-haskell >=2.0 && <3.0     , text >=1.2 && <2.0     , time >=1.4 && <2.0-    , vformat >=0.9.1 && <1.0+    , vformat >=0.13 && <1.0+    , vformat-time >=0.1 && <1.0     , yaml >=0.9 && <1.0   default-language: Haskell2010 @@ -103,7 +104,8 @@     , template-haskell >=2.0 && <3.0     , text >=1.2 && <2.0     , time >=1.4 && <2.0-    , vformat >=0.9.1 && <1.0+    , vformat >=0.13 && <1.0+    , vformat-time >=0.1 && <1.0     , yaml >=0.9 && <1.0   default-language: Haskell2010 @@ -132,6 +134,7 @@     , template-haskell >=2.0 && <3.0     , text >=1.2 && <2.0     , time >=1.4 && <2.0-    , vformat >=0.9.1 && <1.0+    , vformat >=0.13 && <1.0+    , vformat-time >=0.1 && <1.0     , yaml >=0.9 && <1.0   default-language: Haskell2010

@@ -0,0 +1,8 @@+module Logging.Class+  ( module Logging.Class.Filterable+  , module Logging.Class.Handler+  ) where+++import           Logging.Class.Filterable+import           Logging.Class.Handler

@@ -0,0 +1,14 @@+module Logging.Class.Filterable ( Filterable(..) ) where++import           Prelude        hiding (filter)++import           Logging.Record+++-- |A class represents a common trait of filtering 'LogRecord's+class Filterable a where+  filter :: a -> LogRecord -> Bool++instance Filterable a => Filterable [a] where+  filter [] _       = True+  filter (f:fs) rcd = (filter f rcd) && (filter fs rcd)

@@ -0,0 +1,94 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications      #-}++module Logging.Class.Handler ( SomeHandler(..), Handler(..) ) where++import           Control.Lens                (set, view)+import           Control.Monad               (when)+import           Data.Generics.Product.Typed+import           Data.Typeable+import           Prelude                     hiding (filter)+import           Text.Format++import           Logging.Class.Filterable+import           Logging.Filter+import           Logging.Level+import           Logging.Record+++-- | Generalised 'Handler' instance, it wraps all other 'Handler' instances+-- into one type.+--+-- The 'SomeHandler' type is the root of the handler type hierarchy.+data SomeHandler where+  SomeHandler :: Handler h => h -> SomeHandler++instance {-# OVERLAPPING #-} HasType Level SomeHandler where+  getTyped (SomeHandler h) = view (typed @Level) h+  setTyped v (SomeHandler h) = SomeHandler $ set (typed @Level) v h++instance {-# OVERLAPPING #-} HasType Filterer SomeHandler where+  getTyped (SomeHandler h) = view (typed @Filterer) h+  setTyped v (SomeHandler h) = SomeHandler $ set (typed @Filterer) v h++instance {-# OVERLAPPING #-} HasType Format1 SomeHandler where+  getTyped (SomeHandler h) = view (typed @Format1) h+  setTyped v (SomeHandler h) = SomeHandler $ set (typed @Format1) v h++instance Eq SomeHandler where+  (SomeHandler h1) == h2 = Just h1 == fromHandler h2++instance Handler SomeHandler where+  open (SomeHandler h) = open h+  emit (SomeHandler h) = emit h+  close (SomeHandler h) = close h+  handle (SomeHandler h) = handle h+  fromHandler = Just . id+  toHandler = id+++-- |A type class that abstracts the characteristics of a 'Handler'+class ( HasType Level a+      , HasType Filterer a+      , HasType Format1 a+      , Typeable a+      , Eq a+      ) => Handler a where++  -- | Initialize the 'Handler' instance+  open :: a -> IO ()+  open _ = return ()++  -- | Emit log event, prepare log data, and send to bancked.+  --+  -- e.g. 1) Format 'LogRecord' into data in specific format (json, html, etc.),+  -- 2) write the data to a file or send the data to a server.+  emit :: a -> LogRecord -> IO ()++  -- | Terminate the 'Handler' instance+  close :: a -> IO ()+  close _ = return ()++  -- | Handle 'LogRecord' and decide whether to call 'emit'.+  --+  -- The default implementation is to filter 'LogRecord' by level and+  -- "Handler"'s filterer, if rejected, do nothing and return False,+  -- otherwise call emit and return True.+  --+  -- Note: You can override the default implementation.+  handle :: a -> LogRecord -> IO Bool+  handle hdl rcd@LogRecord{level=level'}+    | level' < view (typed @Level) hdl = return False+    | otherwise =+      if filter (view (typed @Filterer) hdl) rcd+         then emit hdl rcd >> return True+         else return False++  fromHandler :: SomeHandler -> Maybe a+  fromHandler (SomeHandler h) = cast h++  toHandler :: a -> SomeHandler+  toHandler = SomeHandler

@@ -97,7 +97,7 @@ import           Prelude             hiding (readFile)  import           Logging.Config.Type-import           Logging.Types       (Manager)+import           Logging.Manager   -- | decode a 'Manager' from strict 'ByteString'

@@ -12,22 +12,31 @@   ) where  -import           Control.Exception (Exception)+import           Control.Concurrent.MVar+import           Control.Exception                       (Exception) import           Data.Aeson import           Data.Default import           Data.IORef import           Data.Map.Lazy import           Data.Maybe import           Data.String+import           Data.Time.Clock+import           Data.Time.LocalTime import           GHC.Generics import           System.IO -import           Prelude           hiding (map)-import qualified Prelude           as P-import           Text.Format+import           Prelude                                 hiding (map)+import qualified Prelude                                 as P+import           Text.Format                             hiding (defaultOptions) +import qualified Logging.Class                           as T+import qualified Logging.Handler.FileHandler             as T+import qualified Logging.Handler.RotatingFileHandler     as T+import qualified Logging.Handler.StreamHandler           as T+import qualified Logging.Handler.TimeRotatingFileHandler as T+import qualified Logging.Manager                         as T import           Logging.Prelude-import qualified Logging.Types     as T+import qualified Logging.Sink                            as T   data Handler = StreamHandler { level     :: Maybe String@@ -55,6 +64,22 @@                                    , backupCount :: Maybe Int                                      -- ^ Default is 10.                                    }+             | TimeRotatingFileHandler { level       :: Maybe String+                                       , filterer    :: Maybe [String]+                                       , formatter   :: Maybe String+                                       , file        :: FilePath+                                       , encoding    :: Maybe String+                                       , timezone    :: Maybe String+                                         -- ^ If not set, same as 'Manager''s+                                         -- timezone.+                                       , rotateTime  :: Maybe String+                                         -- ^ Indicates when to rotate file,+                                         -- e.g. @D3@ means every 3 days,+                                         -- @W4@ means at 0 clock of 'Thursday',+                                         -- try showing 'RotateTime'.+                                       , backupCount :: Maybe Int+                                       }+              -- ^ @since 0.7.0               deriving (Generic, Show)  instance FromJSON Handler where@@ -77,6 +102,7 @@ data Config = Config { sinks                  :: Maybe (Map String Sink)                      , handlers               :: Maybe (Map String Handler)                      , formatters             :: Maybe (Map String String)+                     , timezone               :: Maybe String -- ^ @since 0.7.0                      , disabled               :: Maybe Bool                      , catchUncaughtException :: Maybe Bool                      } deriving (Generic, Show)@@ -96,12 +122,14 @@ createManager Config{..} = do     handlers <- mapM (createHandler formatters') $ fromMaybe empty handlers     sinks <- sequence $ mapWithKey (createSink handlers) $ fromMaybe empty sinks+    defaultTimezone <- getCurrentTimeZone      let root = findWithDefault defaultRoot "root" sinks         sinks' = delete "root" sinks+        timezone' = maybe defaultTimezone read timezone         disabled' = fromMaybe False disabled         catchUncaughtException' = fromMaybe False catchUncaughtException-    return $ T.Manager root sinks' disabled' catchUncaughtException'+    return $ T.Manager root sinks' timezone' disabled' catchUncaughtException'   where     formatters' :: Map String Format1     formatters' = maybe (singleton "" "{message}") (map fromString) formatters@@ -149,7 +177,22 @@           maxBytes' = fromMaybe 104857600 maxBytes           backupCount' = fromMaybe 10 backupCount       encoding' <- mkTextEncoding $ fromMaybe "utf8" encoding-      stream <- newIORef undefined+      stream <- newEmptyMVar       return $ T.toHandler $         T.RotatingFileHandler level' filterer' formatter' file encoding'                               maxBytes' backupCount' stream+    createHandler fs TimeRotatingFileHandler{timezone=tz, ..} = do+      let level' = maybe def read level+          filterer' = maybe [] (P.map fromString) filterer+          formatter' = maybe "{message}" ((!) fs) formatter+          tz' = mappend tz timezone+          rotateTime' = maybe (T.Day 1) read rotateTime+          backupCount' = fromMaybe 10 backupCount+      encoding' <- mkTextEncoding $ fromMaybe "utf8" encoding+      timezone' <- maybe getCurrentTimeZone (return . read) tz'+      rotateAt <- newIORef =<< getCurrentTime+      stream <- newEmptyMVar+      return $ T.toHandler $+        T.TimeRotatingFileHandler level' filterer' formatter' file encoding'+                                  timezone' rotateTime' backupCount' rotateAt+                                  stream

@@ -57,7 +57,7 @@ import           Data.Yaml  import           Logging.Config.Type-import           Logging.Types       (Manager)+import           Logging.Manager   -- | decode a 'Manager' from strict 'ByteString'

@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module Logging.Filter ( Filter(..), Filterer ) where++import           Data.List                (stripPrefix)+import           Data.String+import           Prelude                  hiding (filter)++import           Logging.Class.Filterable+import           Logging.Logger+import           Logging.Record+++-- | 'Filter's are used to perform arbitrary filtering of 'LogRecord's.+--+-- '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 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 = 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 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+type Filterer = [Filter]

@@ -16,4 +16,4 @@  import           Logging.Global.Internal import           Logging.Global.TH-import           Logging.Types+import           Logging.Manager

@@ -15,12 +15,15 @@ import           Prelude                hiding (log) import           System.IO.Unsafe +import           Logging.Level+import           Logging.Logger+import           Logging.Manager import qualified Logging.Monad.Internal as M-import           Logging.Types  {-# NOINLINE ref #-} ref :: IORef Manager-ref = unsafePerformIO $ newIORef undefined+ref = unsafePerformIO $ newIORef $+  error "Global logging manager is not set, see Logging.Global.run"   log :: MonadIO m@@ -30,7 +33,38 @@   manager <- readIORef ref   M.runLoggingT (M.log logger level message location) manager +{-| Run the global logging environment. +You should always run you application in the global logging environment.++  @+    main :: IO ()+    main = run manager app++    app :: IO ()+    app = do+      $(info) \"App\" "..."+      ...+  @++Never run multiple global logging environments concurrently.++  @+    -- bad useage+    main :: IO ()+    main = do+      forkIO $ run manager1 app1+      forkIO $ run manager2 app2+      ...++    -- correct useage+    main :: IO ()+    main = run manager $ do+      forkIO app1+      forkIO app2+      ...+  @+-} run :: Manager -> IO a -> IO a run manager@Manager{..} io = do     oldHandler <- getUncaughtExceptionHandler

@@ -16,11 +16,11 @@  import           Control.Monad.IO.Class  (MonadIO) import           Language.Haskell.TH+import           Prelude                 hiding (error, log)  import           Logging.Global.Internal-import           Logging.Types--import           Prelude                 hiding (error, log)+import           Logging.Level+import           Logging.Logger  -- | Log "message" with the severity "level". --

@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards       #-}++module Logging.Handler.FileHandler+  ( FileHandler(..)+  ) where++import           Data.IORef+import           GHC.Generics+import           System.IO+import           Text.Format++import           Logging.Class+import           Logging.Filter+import           Logging.Level+import           Logging.Prelude+++-- | A handler type which writes logging records, appropriately formatted,+-- to a file.+data FileHandler = FileHandler { level     :: Level+                               , filterer  :: Filterer+                               , formatter :: Format1+                               , file      :: FilePath+                               , encoding  :: TextEncoding+                               , stream    :: IORef Handle+                               -- ^ Don't open file manually, initialized as+                               -- __'IORef' undefined__ and use 'open' or+                               -- "Logger.Manager.initialize"+                               } deriving (Generic, Eq)++instance Handler FileHandler where+  open FileHandler{..} = atomicWriteIORef stream =<< openLogFile file encoding++  emit self@FileHandler{..} rcd = do+    stream' <- readIORef stream+    flip hPutStrLn (format1 formatter rcd) stream'+    hFlush stream'++  close FileHandler{..} = hClose =<< readIORef stream

@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards       #-}++module Logging.Handler.RotatingFileHandler+  ( RotatingFileHandler(..)+  ) where++import           Control.Concurrent.MVar+import           Control.Monad+import           GHC.Generics+import           System.IO+import           Text.Format++import           Logging.Class+import           Logging.Filter+import           Logging.Level+import           Logging.Prelude+++-- | A handler type which writes logging records, appropriately formatted,+-- to a file, it will rotate when file is too large.+--+-- Since 0.3.0+--+data RotatingFileHandler = RotatingFileHandler { level       :: Level+                                               , filterer    :: Filterer+                                               , formatter   :: Format1+                                               , file        :: FilePath+                                               , encoding    :: TextEncoding+                                               , maxBytes    :: Int+                                                 -- ^ Actual file size may be+                                                 -- slightly larger than this+                                                 -- value.+                                               , backupCount :: Int+                                               , stream      :: MVar Handle+                                               -- ^ Don't open file manually,+                                               -- initialized as empty 'MVar'+                                               -- and use 'open' or+                                               -- "Logger.Manager.initialize"+                                               } deriving (Generic, Eq)++instance Handler RotatingFileHandler where+  open RotatingFileHandler{..} = isEmptyMVar stream >>= safeOpen+    where+      safeOpen True  = void $ tryPutMVar stream =<< openLogFile file encoding+      safeOpen False = modifyMVar_ stream $ \h -> do+        hClose h+        openLogFile file encoding++  emit handler@RotatingFileHandler{..} rcd = do+      let msg = format1 formatter rcd+      modifyMVar_ stream $ \stream' -> do+        hPutStrLn stream' msg+        hFlush stream'+        pos <- hTell stream'+        rollover (backupCount > 0) (fromEnum pos >= maxBytes) stream'+    where+      rollover :: Bool -> Bool -> Handle -> IO Handle+      rollover True True h = do+        hClose h+        rotate $ backupCount - 1+        tryRenameFile file $ appendBaseName file ".1"+        openLogFile file encoding+      rollover _ _ h = return h++      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{..} = withMVar stream hClose

@@ -0,0 +1,30 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards       #-}++module Logging.Handler.StreamHandler ( StreamHandler(..) ) where++import           Control.Monad  (unless)+import           GHC.Generics+import           System.IO+import           Text.Format++import           Logging.Class+import           Logging.Filter+import           Logging.Level+++-- | A handler type which writes logging records, appropriately formatted,+-- to a stream.+--+data StreamHandler = StreamHandler { level     :: Level+                                   , filterer  :: Filterer+                                   , formatter :: Format1+                                   , stream    :: Handle+                                   -- ^ Must be writable 'Handle'+                                   } deriving (Generic, Eq)++instance Handler StreamHandler where+  emit hdl@StreamHandler{..} rcd = do+    hPutStrLn stream $ format1 formatter rcd+    hFlush stream

@@ -0,0 +1,198 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module Logging.Handler.TimeRotatingFileHandler+  ( TimeRotatingFileHandler(..)+  , DayOfWeek(..)+  , RotateTime(..)+  ) where++import           Control.Concurrent.MVar+import           Control.Monad+import           Data.Char+import           Data.IORef+import           Data.List+import           Data.Time.Clock+import           Data.Time.Clock.POSIX+import           Data.Time.LocalTime+import           GHC.Generics+import           System.Directory+import           System.FilePath+import           System.IO+import           Text.Format++import           Logging.Class           hiding (filter)+import           Logging.Filter+import           Logging.Level+import           Logging.Prelude+import           Logging.Record++{-| A handler type which logs to a file and rotates the log at cerntain timed+intervals.++@since 0.7.0+-}+data TimeRotatingFileHandler  = TimeRotatingFileHandler+                                  { level       :: Level+                                  , filterer    :: Filterer+                                  , formatter   :: Format1+                                  , file        :: FilePath+                                  , encoding    :: TextEncoding+                                  , timezone    :: TimeZone+                                    -- ^ In most cases, it is the same value as+                                    -- 'Manager''s timezone, but it won't cause+                                    -- problems if you set a different value.+                                  , rotateTime  :: RotateTime+                                  , backupCount :: Int+                                  , rotateAt    :: IORef UTCTime+                                  , stream      :: MVar Handle+                                  } deriving (Generic, Eq)+++instance Handler TimeRotatingFileHandler where+  open TimeRotatingFileHandler{..} = do+      now <- (utcToZonedTime timezone) <$> (lastModifyTime file)+      atomicWriteIORef rotateAt $ nextRotateAt rotateTime now+      isEmptyMVar stream >>= safeOpen+    where+      safeOpen True = void $ tryPutMVar stream =<< openLogFile file encoding+      safeOpen False = modifyMVar_ stream $ \h -> do+        hClose h+        openLogFile file encoding++  emit TimeRotatingFileHandler{..} rcd = do+      let msg = format1 formatter rcd+      modifyMVar_ stream $ \stream' -> do+        at <- readIORef rotateAt+        h <- rollover (backupCount > 0) (utctime rcd >= at) at stream'+        hPutStrLn h msg+        hFlush h+        return h+    where+      rollover :: Bool -> Bool -> UTCTime -> Handle -> IO Handle+      rollover True True at h = do+        hClose h+        files <- listDirectory $ takeDirectory file+        removeExpired $ sort $ filter (matchSuffix rotateTime file) files+        tryRenameFile file $ appendBaseName file $ format (suffix rotateTime) $+          utcToZonedTime timezone $ prevRotateAt rotateTime at+        now <- utcToZonedTime timezone <$> getCurrentTime+        writeIORef rotateAt $ nextRotateAt rotateTime now+        openLogFile file encoding+      rollover _ _ _ h        = return h++      removeExpired :: [FilePath] -> IO ()+      removeExpired fs = forM_ (drop (backupCount - 1) (reverse fs)) $ \fn ->+        removeFile $ replaceFileName file fn++  close TimeRotatingFileHandler{..} = withMVar stream hClose++-- | A datatype indicates a day of Monday-starting week.+--+data DayOfWeek = Monday+               | Tuesday+               | Wednesday+               | Thursday+               | Friday+               | Saturday+               | Sunday+               deriving Eq++-- | Monday-starting week means Monday is 1 and Sunday is 7+instance Enum DayOfWeek where+  toEnum 1 = Monday+  toEnum 2 = Tuesday+  toEnum 3 = Wednesday+  toEnum 4 = Thursday+  toEnum 5 = Friday+  toEnum 6 = Saturday+  toEnum 7 = Sunday++  fromEnum Monday    = 1+  fromEnum Tuesday   = 2+  fromEnum Wednesday = 3+  fromEnum Thursday  = 4+  fromEnum Friday    = 5+  fromEnum Saturday  = 6+  fromEnum Sunday    = 7+++{-| A datatype indicates when to rotate file.++Note: This handler use @1970-01-01 00:00:00@ of the given timezone as the zero+time, all caculations of 'RotateTime' are based on this zero time.+Let's consider @Hour 5@ for example, if now is @2020-01-01 03:10:00@,+since there are 87658 @5 hours@ between now and zero time, the next rotating+time will be @2020-01-01 07:00:00@.+-}+data RotateTime = Minute Int        -- ^ Every n minute(s)+                | Hour Int          -- ^ Every n hour(s)+                | WeekDay DayOfWeek -- ^ At zero clock of a weekday+                | Day Int           -- ^ Every n day(s)+               deriving Eq++instance Read RotateTime where+  readsPrec _ ('M' : cs) = [(Minute $ read cs, "")]+  readsPrec _ ('H' : cs) = [(Hour $ read cs, "")]+  readsPrec _ ('D' : cs) = [(Day $ read cs, "")]+  readsPrec _ ('W' : cs) = [(WeekDay $ toEnum $ read cs, "")]+  readsPrec _ _          = []++instance Show RotateTime where+  show (Minute n)  = 'M' : (show n)+  show (Hour n)    = 'H' : (show n)+  show (WeekDay n) = 'W' : (show $ fromEnum n)+  show (Day n)     = 'D' : (show n)+++interval :: RotateTime -> NominalDiffTime+interval (Minute n)  = 60 * fromInteger (toInteger n)+interval (Hour n)    = 60 * 60 * fromInteger (toInteger n)+interval (WeekDay _) = 60 * 60 * 24 * 7+interval (Day n)     = 60 * 60 * 24 * fromInteger (toInteger n)++nextRotateAt :: RotateTime -> ZonedTime -> UTCTime+nextRotateAt rt now = posixSecondsToUTCTime $ fixDay rt $ quot * unit+  where+    unit = interval rt+    total = zonedTimeToPOSIXSeconds now+    quot = fromInteger $ 1 + (truncate $ total / unit)+    diff = 60 * (fromInteger $ toInteger $ timeZoneMinutes $ zonedTimeZone now)++    fixDay :: RotateTime -> NominalDiffTime -> NominalDiffTime+    fixDay (WeekDay d) = (+) (interval (Day ((3 + fromEnum d) `mod` 7)) - diff)+    fixDay (Day _)     = subtract diff+    fixDay _           = id+++prevRotateAt :: RotateTime -> UTCTime -> UTCTime+prevRotateAt = addUTCTime . negate . interval+++suffix :: RotateTime -> Format+suffix (Minute _) = ".{:%Y-%m-%d_%H-%M}"+suffix (Hour _)   = ".{:%Y-%m-%d_%H}"+suffix _          = ".{:%Y-%m-%d}"+++matchSuffix :: RotateTime -> FilePath -> FilePath -> Bool+matchSuffix rt base src+    | Just cs <- stripPrefix (takeBaseName base) (takeBaseName src) =+      matchDay (take 11 cs) && matchTime rt (drop 11 cs)+    | otherwise = False+  where+    matchD2 :: Int -> String -> Bool+    matchD2 0 ""           = True+    matchD2 1 (x:y:"")     = isDigit x && isDigit y+    matchD2 n (x:y:'-':cs) = isDigit x && isDigit y && matchD2 (n - 1) cs+    matchD2 _ _            = False++    matchDay :: String -> Bool+    matchDay ('.':x:y:cs) = isDigit x && isDigit y && matchD2 3 cs+    matchDay _            = False++    matchTime :: RotateTime -> String -> Bool+    matchTime (Minute _) ('_':cs) = matchD2 2 cs+    matchTime (Hour _) ('_':cs)   = matchD2 1 cs+    matchTime _ cs                = matchD2 0 cs

@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}++module Logging.Level ( Level(..) ) where++import           Data.Default+import           Data.List    (stripPrefix)+import           Data.String+import           Text.Format+++-- |'Level' also known as severity, a higher 'Level' means a bigger 'Int'.+--+-- There are 5 common severity levels:+--+-- [@DEBUG@] Level 10+-- [@INFO@] Level 20+-- [@WARN@] Level 30+-- [@ERROR@] Level 40+-- [@FATAL@] Level 50+--+-- >>> :set -XOverloadedStrings+-- >>> "DEBUG" :: Level+-- DEBUG+-- >>> "DEBUG" == (Level 10)+-- True+--+newtype Level = Level Int deriving (Eq, Ord)++instance Show Level where+  show (Level 0)  = "NOTSET"+  show (Level 10) = "DEBUG"+  show (Level 20) = "INFO"+  show (Level 30) = "WARN"+  show (Level 40) = "ERROR"+  show (Level 50) = "FATAL"+  show (Level v)  = "LEVEL " ++ show v++instance Read Level where+  readsPrec _ "NOTSET" = [(Level 0, "")]+  readsPrec _ "DEBUG"  = [(Level 10, "")]+  readsPrec _ "INFO"   = [(Level 20, "")]+  readsPrec _ "WARN"   = [(Level 30, "")]+  readsPrec _ "ERROR"  = [(Level 40, "")]+  readsPrec _ "FATAL"  = [(Level 50, "")]+  readsPrec _ s       = case (stripPrefix "LEVEL " s) of+                          Just v -> [(Level (read v), "")]+                          _      -> []++instance IsString Level where+  fromString = read++instance Enum Level where+  toEnum = Level+  fromEnum (Level v) = v++instance Default Level where+  def = "NOTSET"++instance FormatArg Level where+  formatArg = formatArg . show

@@ -0,0 +1,5 @@+module Logging.Logger ( Logger(..) ) where+++-- |'Logger' is just a name.+type Logger = String

@@ -0,0 +1,37 @@+{-# LANGUAGE RecordWildCards #-}++module Logging.Manager+  ( Manager(..)+  , initialize+  , terminate+  ) where++import           Data.List             (nub)+import           Data.Map.Lazy         (Map, elems)+import           Data.Time.LocalTime++import           Logging.Class.Handler+import           Logging.Sink+++-- |Logging 'Manager' which holds the hierarchy of sinks and other settings.+--+-- Since v0.7.0, the 'TimeZone' of the logging environment can be configurable.+data Manager = Manager { root                   :: Sink+                       , sinks                  :: Map String Sink+                       , timezone               :: TimeZone -- ^ @since 0.7.0+                       , disabled               :: Bool+                       , catchUncaughtException :: Bool+                       }+++-- | Initialize a 'Manager', open all its handlers.+initialize :: Manager -> IO ()+initialize Manager{..} = mapM_ open $+  nub $ concat [ handlers | Sink{..} <- (root : (elems sinks)) ]+++-- | Terminate a 'Manager', close all its handlers.+terminate :: Manager -> IO ()+terminate Manager{..} = mapM_ close $+  nub $ concat [ handlers | Sink{..} <- (root : (elems sinks)) ]

@@ -17,6 +17,6 @@   ) where  +import           Logging.Manager import           Logging.Monad.Internal import           Logging.Monad.TH-import           Logging.Types

@@ -1,4 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE ScopedTypeVariables   #-}@@ -11,6 +12,7 @@   ) where  +import           Control.Concurrent import           Control.Exception           (SomeException, bracket_) import           Control.Lens                (view) import           Control.Monad@@ -30,8 +32,13 @@ import           System.IO                   (stderr, stdout) import           System.IO.Unsafe            (unsafePerformIO) +import           Logging.Class+import           Logging.Level+import           Logging.Logger+import           Logging.Manager import           Logging.Prelude-import           Logging.Types+import           Logging.Record+import           Logging.Sink   type LoggingT m a = ReaderT Manager m a@@ -41,29 +48,32 @@ runLoggingT = runReaderT  +runIO :: MonadIO m => IO a -> ReaderT Manager m a+runIO = lift . liftIO++ log :: MonadIO m     => Logger -> Level -> String -> (String, String, String, Int)     -> LoggingT m () log logger level message location = do     manager@Manager{..} <- ask-    asctime <- lift $ liftIO $ getZonedTime+    utctime <- runIO getCurrentTime+    thread <- runIO myThreadId      let (pathname, pkgname, modulename, lineno) = location         filename = takeFileName pathname-        utctime = zonedTimeToUTC asctime+        asctime = utcToZonedTime timezone utctime         diffTime = utcTimeToPOSIXSeconds utctime         created = timestamp diffTime-        msecs = microseconds diffTime+        msecs = milliseconds diffTime - (seconds diffTime * 1000) -    when (not disabled) $ lift $ liftIO $ process logger manager $-      LogRecord logger level message pathname filename pkgname modulename-                lineno asctime utctime created msecs+    when (not disabled) $ runIO $ process logger manager LogRecord{..}   where     process :: Logger -> Manager -> LogRecord -> IO ()     process logger manager rcd =       case lookupSink logger manager of         Just sink@Sink{..} -> do-          when (isSinkEnabledFor sink rcd) $ callHandlers handlers rcd+          when (filter sink rcd) $ callHandlers handlers rcd           let parentLogger = parent logger               shouldPropagate = propagate && logger /= parentLogger           when shouldPropagate $ process parentLogger manager rcd@@ -78,11 +88,4 @@       | otherwise = sinks !? logger      callHandlers :: [SomeHandler] -> LogRecord -> IO ()-    callHandlers handlers rcd = forM_ handlers $ \hdl ->-      Logging.Types.handle hdl rcd--    isSinkEnabledFor :: Sink -> LogRecord -> Bool-    isSinkEnabledFor sink@Sink{..} rcd@LogRecord{level=level'}-      | disabled = False-      | level' < level = False-      | otherwise = filter sink rcd+    callHandlers handlers rcd = forM_ handlers (`handle` rcd)

@@ -24,11 +24,11 @@  import           Control.Monad.IO.Class (MonadIO) import           Language.Haskell.TH+import           Prelude                hiding (error, log) +import           Logging.Level+import           Logging.Logger import           Logging.Monad.Internal-import           Logging.Types--import           Prelude                hiding (error, log)  -- | Log "message" with the severity "level". --

@@ -13,10 +13,12 @@   , microseconds   , openLogFile   , tryRenameFile+  , lastModifyTime   , modifyBaseName   , appendBaseName   ) where +import           Control.Concurrent import           Control.Monad import           Data.Time.Clock import           Data.Time.Clock.POSIX@@ -25,12 +27,17 @@ import           System.Environment import           System.FilePath import           System.IO+import           Text.Format   instance Eq TextEncoding where   e1 == e2 = show e1 == show e2  +instance FormatArg ThreadId where+  formatArg x = formatArg (show x)++ addZonedTime :: NominalDiffTime -> ZonedTime -> ZonedTime addZonedTime ndt zt@(ZonedTime _ tz) =   utcToZonedTime tz $ addUTCTime ndt $ zonedTimeToUTC zt@@ -76,6 +83,12 @@  tryRenameFile :: FilePath -> FilePath -> IO () tryRenameFile src dest = doesFileExist src >>= (flip when $ renameFile src dest)+++lastModifyTime :: FilePath -> IO UTCTime+lastModifyTime file = do+  exist <- doesFileExist file+  if exist then getModificationTime file else getCurrentTime   modifyBaseName :: FilePath -> (String -> String) -> FilePath

@@ -0,0 +1,77 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}++module Logging.Record ( LogRecord(..) ) where++import           Control.Concurrent+import           Data.Time.Clock+import           Data.Time.LocalTime+import           GHC.Generics+import           Text.Format+import           Text.Format.Time++import           Logging.Level+import           Logging.Logger+import           Logging.Prelude+++-- |A 'LogRecord' represents an event being logged.+--+-- 'LogRecord's are created every time something is logged. They+-- contain all the information related to the event being logged.+--+-- It includes the main message as well as information such as+-- when the record was created, the source line where the logging call was made.+--+-- 'LogRecord' can be formatted into string by 'Text.Format'+-- from 'vformat' package, see 'Text.Format.format1' for more information.+--+-- Currently, the useful attributes in a LogRecord are described by:+--+-- @+--  logger        name of the logger, see 'Logger'+--  level         logging level for the message, see 'Level'+--  message       the main message passed to logv debug info ..+--  pathname      full pathname of the source file where the logging call was issued (if available)+--  filename      filename portion of pathname+--  pkgname       package name where the logging call was issued (if available)+--  modulename    module name (e.g. Main, Logging)+--  lineno        source line number where the logging call was issued (if available)+--  asctime       locale time when the 'LogRecord' was created ('TimeZone' is from 'Manager')+--  utctime       utc time when the 'LogRecord' was created+--  created       timestamp when the 'LogRecord' was created+--  msecs         millisecond portion of the creation time+--  thread        'ThreadId' of the thread in which the logging call was issued+-- @+--+-- Format examples:+--+-- @+--  "{message}"+--  "{logger} {level}: {message}"+--  "{logger:<20.20s} {level:<8s}: {message}"+--  "{asctime:%Y-%m-%dT%H:%M:%S%6Q%z} - {level} - {logger}] {message}"+-- @+--+data LogRecord = LogRecord { logger     :: Logger+                           , level      :: Level+                           , message    :: String+                           , pathname   :: String+                           , filename   :: String+                           , pkgname    :: String+                           , modulename :: String+                           , lineno     :: Int+                           , asctime    :: ZonedTime+                           , utctime    :: UTCTime+                           , created    :: Double+                           -- ^ Use @{utctime:%s%Q}@ instead.+                           -- See "Text.Format.Time" and "Data.Time.Format".+                           , msecs      :: Integer+                           -- ^ Use @{utctime:%3q}@ instead.+                           -- See "Text.Format.Time" and "Data.Time.Format".+                           , thread     :: ThreadId+                           } deriving (Generic, Show)++instance FormatArg LogRecord++{-# DEPRECATED created, msecs "Will be removed" #-}

@@ -0,0 +1,44 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards       #-}++module Logging.Sink (Sink(..)) where++import           Prelude        hiding (filter)++import           Logging.Class+import           Logging.Filter+import           Logging.Level+import           Logging.Logger+import           Logging.Record+++-- |'Sink' represents a single logging channel.+--+-- A "logging channel" indicates an area of an application. Exactly how an+-- "area" is defined is up to the application developer. Since an+-- application can have any number of areas, logging channels are identified+-- by a unique string. Application areas can be nested (e.g. an area+-- of "input processing" might include sub-areas "read CSV files", "read+-- XLS files" and "read Gnumeric files"). To cater for this natural nesting,+-- channel names are organized into a namespace hierarchy where levels are+-- separated by periods, much like the  Haskell module namespace. So+-- in the instance given above, channel names might be "Input" for the upper+-- level, and "Input.Csv", "Input.Xls" and "Input.Gnu" for the sub-levels.+-- There is no arbitrary limit to the depth of nesting.+--+-- Note: The namespaces are case sensitive.+--+data Sink = Sink { logger    :: Logger+                 , level     :: Level+                 , filterer  :: Filterer+                 , handlers  :: [SomeHandler]+                 , disabled  :: Bool+                 , propagate :: Bool -- ^ It will pop up until root or the+                                     -- ancestor's propagation is disabled+                 }++instance Filterable Sink where+  filter Sink{..} rcd@LogRecord{level=level'}+    | disabled = False+    | level' < level = False+    | otherwise = filter filterer rcd

@@ -1,4 +1,4 @@-module Logging.TH {-# DEPRECATED "Renamed as Logging.TH.Global.TH" #-}+module Logging.TH {-# DEPRECATED "Renamed as Logging.Global.TH" #-}   ( module Logging.Global.TH   ) where 

@@ -1,19 +1,23 @@-module Logging.Types-  ( module Logging.Types.Logger-  , module Logging.Types.Level-  , module Logging.Types.Filter-  , module Logging.Types.Record-  , module Logging.Types.Handlers-  , module Logging.Types.Sink-  , module Logging.Types.Manager-  , module Logging.Types.Class+module Logging.Types {-# DEPRECATED "This module has been flattened, use relevant modules directly" #-}+  ( module Logging.Logger+  , module Logging.Level+  , module Logging.Filter+  , module Logging.Record+  , module Logging.Handler.FileHandler+  , module Logging.Handler.RotatingFileHandler+  , module Logging.Handler.StreamHandler+  , module Logging.Sink+  , module Logging.Manager+  , module Logging.Class   ) where -import           Logging.Types.Class-import           Logging.Types.Filter-import           Logging.Types.Handlers-import           Logging.Types.Level-import           Logging.Types.Logger-import           Logging.Types.Manager-import           Logging.Types.Record-import           Logging.Types.Sink+import           Logging.Class+import           Logging.Filter+import           Logging.Handler.FileHandler+import           Logging.Handler.RotatingFileHandler+import           Logging.Handler.StreamHandler+import           Logging.Level+import           Logging.Logger+import           Logging.Manager+import           Logging.Record+import           Logging.Sink

@@ -1,8 +0,0 @@-module Logging.Types.Class-  ( module Logging.Types.Class.Filterable-  , module Logging.Types.Class.Handler-  ) where---import           Logging.Types.Class.Filterable-import           Logging.Types.Class.Handler

@@ -1,14 +0,0 @@-module Logging.Types.Class.Filterable ( Filterable(..) ) where--import           Prelude              hiding (filter)--import           Logging.Types.Record----- |A class represents a common trait of filtering 'LogRecord's-class Filterable a where-  filter :: a -> LogRecord -> Bool--instance Filterable a => Filterable [a] where-  filter [] _       = True-  filter (f:fs) rcd = (filter f rcd) && (filter fs rcd)

@@ -1,80 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeApplications      #-}--module Logging.Types.Class.Handler ( SomeHandler(..), Handler(..) ) where--import           Control.Lens                   (set, view)-import           Control.Monad                  (when)-import           Data.Generics.Product.Typed-import           Data.Typeable-import           Prelude                        hiding (filter)-import           Text.Format--import           Logging.Types.Class.Filterable-import           Logging.Types.Filter-import           Logging.Types.Level-import           Logging.Types.Record----- |The 'SomeHandler' type is the root of the handler type hierarchy.--- It holds the real 'Handler' instance-data SomeHandler where-  SomeHandler :: Handler h => h -> SomeHandler--instance {-# OVERLAPPING #-} HasType Level SomeHandler where-  getTyped (SomeHandler h) = view (typed @Level) h-  setTyped v (SomeHandler h) = SomeHandler $ set (typed @Level) v h--instance {-# OVERLAPPING #-} HasType Filterer SomeHandler where-  getTyped (SomeHandler h) = view (typed @Filterer) h-  setTyped v (SomeHandler h) = SomeHandler $ set (typed @Filterer) v h--instance {-# OVERLAPPING #-} HasType Format1 SomeHandler where-  getTyped (SomeHandler h) = view (typed @Format1) h-  setTyped v (SomeHandler h) = SomeHandler $ set (typed @Format1) v h--instance Eq SomeHandler where-  (SomeHandler h1) == h2 = Just h1 == fromHandler h2--instance Handler SomeHandler where-  open (SomeHandler h) = open h-  emit (SomeHandler h) = emit h-  close (SomeHandler h) = close h-  handle (SomeHandler h) = handle h-  fromHandler = Just . id-  toHandler = id----- |A type class that abstracts the characteristics of a 'Handler'------ Note: Locking is not necessary, because 'GHC.IO.Handle' has done it on--- handle operations.-class ( HasType Level a-      , HasType Filterer a-      , HasType Format1 a-      , Typeable a-      , Eq a-      ) => Handler a where-  open :: a -> IO ()-  open _ = return ()--  emit :: a -> LogRecord -> IO ()--  close :: a -> IO ()-  close _ = return ()--  handle :: a -> LogRecord -> IO Bool-  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--  toHandler :: a -> SomeHandler-  toHandler = SomeHandler

@@ -1,55 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}--module Logging.Types.Filter ( Filter(..), Filterer ) where--import           Data.List                      (stripPrefix)-import           Data.String-import           Prelude                        hiding (filter)--import           Logging.Types.Class.Filterable-import           Logging.Types.Logger-import           Logging.Types.Record----- | 'Filter's are used to perform arbitrary filtering of 'LogRecord's.------ '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 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 = 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 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-type Filterer = [Filter]

@@ -1,9 +0,0 @@-module Logging.Types.Handlers-  ( module Logging.Types.Handlers.StreamHandler-  , module Logging.Types.Handlers.FileHandler-  , module Logging.Types.Handlers.RotatingFileHandler-  ) where--import           Logging.Types.Handlers.FileHandler-import           Logging.Types.Handlers.RotatingFileHandler-import           Logging.Types.Handlers.StreamHandler

@@ -1,39 +0,0 @@-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE RecordWildCards       #-}--module Logging.Types.Handlers.FileHandler-  ( FileHandler(..)-  ) where--import           Data.IORef-import           GHC.Generics-import           System.IO-import           Text.Format--import           Logging.Prelude-import           Logging.Types.Class-import           Logging.Types.Filter-import           Logging.Types.Level----- | A handler type which writes logging records, appropriately formatted,--- to a file.----data FileHandler = FileHandler { level     :: Level-                               , filterer  :: Filterer-                               , formatter :: Format1-                               , file      :: FilePath-                               , encoding  :: TextEncoding-                               , stream    :: IORef Handle-                               } deriving (Generic, Eq)--instance Handler FileHandler where-  open FileHandler{..} = atomicWriteIORef stream =<< openLogFile file encoding--  emit self@FileHandler{..} rcd = do-    stream' <- readIORef stream-    flip hPutStrLn (format1 formatter rcd) stream'-    hFlush stream'--  close FileHandler{..} = hClose =<< readIORef stream

@@ -1,63 +0,0 @@-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE RecordWildCards       #-}--module Logging.Types.Handlers.RotatingFileHandler-  ( RotatingFileHandler(..)-  ) where--import           Control.Monad-import           Data.IORef-import           GHC.Generics-import           System.IO-import           Text.Format--import           Logging.Prelude-import           Logging.Types.Class-import           Logging.Types.Filter-import           Logging.Types.Level----- | A handler type which writes logging records, appropriately formatted,--- to a file, it will rotate when file is too large.------ Since 0.3.0----data RotatingFileHandler = RotatingFileHandler { level       :: Level-                                               , filterer    :: Filterer-                                               , formatter   :: Format1-                                               , file        :: FilePath-                                               , encoding    :: TextEncoding-                                               , maxBytes    :: Int-                                                 -- ^ Actual file size may be-                                                 -- slightly larger than this-                                                 -- value.-                                               , backupCount :: Int-                                               , stream      :: IORef Handle-                                               } deriving (Generic, Eq)--instance Handler RotatingFileHandler where-  open RotatingFileHandler{..} =-    atomicWriteIORef stream =<< openLogFile file encoding--  emit handler@RotatingFileHandler{..} rcd = do-      let msg = format1 formatter rcd-      stream' <- readIORef stream-      hPutStrLn stream' msg-      hFlush stream'-      when (backupCount > 0) $ do-        pos <- hTell stream'-        when (fromEnum pos >= maxBytes) $ do-          hClose stream'-          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

@@ -1,29 +0,0 @@-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE RecordWildCards       #-}--module Logging.Types.Handlers.StreamHandler ( StreamHandler(..) ) where--import           Control.Monad        (unless)-import           GHC.Generics-import           System.IO-import           Text.Format--import           Logging.Types.Class-import           Logging.Types.Filter-import           Logging.Types.Level----- | A handler type which writes logging records, appropriately formatted,--- to a stream.----data StreamHandler = StreamHandler { level     :: Level-                                   , filterer  :: Filterer-                                   , formatter :: Format1-                                   , stream    :: Handle-                                   } deriving (Generic, Eq)--instance Handler StreamHandler where-  emit hdl@StreamHandler{..} rcd = do-    hPutStrLn stream $ format1 formatter rcd-    hFlush stream

@@ -1,60 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Logging.Types.Level ( Level(..) ) where--import           Data.Default-import           Data.List    (stripPrefix)-import           Data.String-import           Text.Format----- |'Level' also known as severity, a higher 'Level' means a bigger 'Int'.------ There are 5 common severity levels:------ [@DEBUG@] Level 10--- [@INFO@] Level 20--- [@WARN@] Level 30--- [@ERROR@] Level 40--- [@FATAL@] Level 50------ >>> :set -XOverloadedStrings--- >>> "DEBUG" :: Level--- DEBUG--- >>> "DEBUG" == (Level 10)--- True----newtype Level = Level Int deriving (Eq, Ord)--instance Show Level where-  show (Level 0)  = "NOTSET"-  show (Level 10) = "DEBUG"-  show (Level 20) = "INFO"-  show (Level 30) = "WARN"-  show (Level 40) = "ERROR"-  show (Level 50) = "FATAL"-  show (Level v)  = "LEVEL " ++ show v--instance Read Level where-  readsPrec _ "NOTSET" = [(Level 0, "")]-  readsPrec _ "DEBUG"  = [(Level 10, "")]-  readsPrec _ "INFO"   = [(Level 20, "")]-  readsPrec _ "WARN"   = [(Level 30, "")]-  readsPrec _ "ERROR"  = [(Level 40, "")]-  readsPrec _ "FATAL"  = [(Level 50, "")]-  readsPrec _ s       = case (stripPrefix "LEVEL " s) of-                          Just v -> [(Level (read v), "")]-                          _      -> []--instance IsString Level where-  fromString = read--instance Enum Level where-  toEnum = Level-  fromEnum (Level v) = v--instance Default Level where-  def = "NOTSET"--instance FormatArg Level where-  formatArg = formatArg . show

@@ -1,5 +0,0 @@-module Logging.Types.Logger ( Logger(..) ) where----- |'Logger' is just a name.-type Logger = String

@@ -1,34 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Logging.Types.Manager-  ( Manager(..)-  , initialize-  , terminate-  ) where--import           Data.List                   (nub)-import           Data.Map.Lazy               (Map, elems)--import           Logging.Types.Class.Handler-import           Logging.Types.Sink----- |There is __under normal circumstances__ just one Manager,--- which holds the hierarchy of sinks.-data Manager = Manager { root                   :: Sink-                       , sinks                  :: Map String Sink-                       , disabled               :: Bool-                       , catchUncaughtException :: Bool-                       }----- | Initialize a 'Manager', open all its handlers.-initialize :: Manager -> IO ()-initialize Manager{..} = mapM_ open $-  nub $ concat [ handlers | Sink{..} <- (root : (elems sinks)) ]----- | Terminate a 'Manager', close all its handlers.-terminate :: Manager -> IO ()-terminate Manager{..} = mapM_ close $-  nub $ concat [ handlers | Sink{..} <- (root : (elems sinks)) ]

@@ -1,66 +0,0 @@-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE DuplicateRecordFields #-}--module Logging.Types.Record ( LogRecord(..) ) where--import           Data.Time.Clock-import           Data.Time.LocalTime-import           GHC.Generics-import           Text.Format--import           Logging.Types.Level-import           Logging.Types.Logger----- |A 'LogRecord' represents an event being logged.------ 'LogRecord's are created every time something is logged. They--- contain all the information related to the event being logged.------ It includes the main message as well as information such as--- when the record was created, the source line where the logging call was made.------ 'LogRecord' can be formatted into string by 'Text.Format'--- from 'vformat' package, see 'Text.Format.format1' for more information.------ Currently, the useful attributes in a LogRecord are described by:------ @---  logger        name of the logger, see 'Logger'---  level         logging level for the message, see 'Level'---  message       the main message passed to logv debug info ..---  pathname      full pathname of the source file where the logging call was issued (if available)---  filename      filename portion of pathname---  pkgname       package name where the logging call was issued (if available)---  modulename    module name (e.g. Main, Logging.Types)---  lineno        source line number where the logging call was issued (if available)---  asctime       'ZonedTime' when the LogRecord was created---  utctime       'UTCTime' when the LogRecord was created---  created       timestamp when the LogRecord was created---  msecs         millisecond portion of the creation time--- @------ Format examples:------ @---  "{message}"---  "{logger} {level}: {message}"---  "{logger:<20.20s} {level:<8s}: {message}"---  "{asctime:%Y-%m-%dT%H:%M:%S%6Q%z} - {level} - {logger}] {message}"--- @----data LogRecord = LogRecord { logger     :: Logger-                           , level      :: Level-                           , message    :: String-                           , pathname   :: String-                           , filename   :: String-                           , pkgname    :: String-                           , modulename :: String-                           , lineno     :: Int-                           , asctime    :: ZonedTime-                           , utctime    :: UTCTime-                           , created    :: Double-                           , msecs      :: Integer-                           } deriving (Generic, Show)--instance FormatArg LogRecord

@@ -1,40 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE RecordWildCards       #-}--module Logging.Types.Sink (Sink(..)) where--import           Prelude              hiding (filter)--import           Logging.Types.Class-import           Logging.Types.Filter-import           Logging.Types.Level-import           Logging.Types.Logger----- |'Sink' represents a single logging channel.------ A "logging channel" indicates an area of an application. Exactly how an--- "area" is defined is up to the application developer. Since an--- application can have any number of areas, logging channels are identified--- by a unique string. Application areas can be nested (e.g. an area--- of "input processing" might include sub-areas "read CSV files", "read--- XLS files" and "read Gnumeric files"). To cater for this natural nesting,--- channel names are organized into a namespace hierarchy where levels are--- separated by periods, much like the  Haskell module namespace. So--- in the instance given above, channel names might be "Input" for the upper--- level, and "Input.Csv", "Input.Xls" and "Input.Gnu" for the sub-levels.--- There is no arbitrary limit to the depth of nesting.------ Note: The namespaces are case sensitive.----data Sink = Sink { logger    :: Logger-                 , level     :: Level-                 , filterer  :: Filterer-                 , handlers  :: [SomeHandler]-                 , disabled  :: Bool-                 , propagate :: Bool -- ^ It will pop up until root or the-                                     -- ancestor's propagation is disabled-                 }--instance Filterable Sink where-  filter Sink{..} = filter filterer

@@ -22,9 +22,10 @@ import           Test.Hspec import           Test.Hspec.QuickCheck -import           Logging import           Logging.Config.Json   as Json import           Logging.Config.Yaml   as Yaml+import           Logging.Manager+import           Logging.Sink   spec :: Spec

@@ -3,27 +3,37 @@ {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE TemplateHaskell   #-} +{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE TypeApplications  #-}+ module LoggingTest.GlobalSpec ( spec ) where  import           Control.Monad-import           Data.Default            (def)-import           Data.List               (intercalate)-import qualified Data.Map                as M+import           Data.Generics.Product.Typed+import qualified Data.Map                            as M+import           Data.Time.LocalTime import           Data.Word-import           Prelude                 hiding (error)+import           Prelude                             hiding (error)+ import           System.IO-import           System.IO.Unsafe        (unsafePerformIO)-import           System.Process          (createPipe)+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           Logging.Class+import           Logging.Global                      hiding (run)+import           Logging.Handler.FileHandler+import           Logging.Handler.RotatingFileHandler+import           Logging.Handler.StreamHandler+import           Logging.Manager+import           Logging.Sink+ import           LoggingTest.Prelude + spec :: Spec spec = describe "run & log" $ do   let levels = ["DEBUG", "INFO", "WARN", "ERROR", "FATAL"]@@ -35,6 +45,7 @@                 , ("Warn.Error", "ERROR", [], ["ERROR"], False, False)                 , ("Error", "ERROR", [], ["ERROR"], False, True)                 , ("Error.Fatal", "FATAL", [], ["FATAL"], False, True)+                , ("Timezone", "INFO", [], ["INFO"], False, False)                 ]   handlers <- fmap M.fromList $ runIO $ forM levels $ \level -> do     (read, write) <- createPipe@@ -44,14 +55,21 @@   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]+        setTz = if logger == "Timezone" then setTyped @Format1 "{asctime:%Z}"+                                        else id+        hs' = [setTz $ 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+      disabledManager = Manager root sinks' utc True False+      manager = Manager root sinks' (read "GMT") False False++  prop "timezone" $ \(MessageString message) -> monadicIO $ do+    run $ runLog manager $ $(info) "Timezone" message+    msg <- run $ hTryGetLine $ snd $ handlers M.! "INFO"+    assert $ msg == "GMT"    prop "filter" $ \(MessageString message) -> monadicIO $ do     -- manager disabled

@@ -8,6 +8,7 @@   , hTryGetLine   , parent   , runLog+  , createFile   ) where  @@ -15,12 +16,17 @@ import           Data.List           (dropWhileEnd, intersperse) import           Data.String import           Data.Time.LocalTime+import           System.Directory+import           System.FilePath import           System.IO import           Test.QuickCheck -import qualified Logging+import qualified Logging.Global+import           Logging.Level+import           Logging.Logger+import           Logging.Manager import           Logging.Prelude-import           Logging.Types+import           Logging.Record   data Alphabet = Alphabet { getAlphabet :: Char } deriving Show@@ -65,6 +71,7 @@         difftime = zonedTimeToPOSIXSeconds asctime         created = timestamp difftime         msecs   = milliseconds difftime+        thread = undefined     return $ LogRecord{..}  @@ -79,4 +86,11 @@   runLog :: Manager -> IO a -> IO a-runLog = Logging.run+runLog = Logging.Global.run+++createFile :: FilePath -> IO ()+createFile path = do+  file <- makeAbsolute path+  createDirectoryIfMissing True $ takeDirectory file+  openFile file ReadWriteMode >>= hClose

@@ -4,22 +4,40 @@  module LoggingTest.TypesSpec ( spec ) where -import           Control.Lens                hiding (Level (..))+import           Control.Concurrent.MVar+import           Control.Lens                            hiding (Level (..)) import           Control.Monad-import           Data.Default                (def)+import           Data.Default                            (def) import           Data.Generics.Product.Typed import           Data.IORef-import           Data.String                 (fromString)-import           Prelude                     hiding (filter)+import           Data.List                               (isPrefixOf)+import           Data.String                             (fromString)+import           Data.Time.Clock+import           Data.Time.Clock.POSIX+import           Data.Time.LocalTime+import           Prelude                                 hiding (filter)+import           System.Directory+import           System.FilePath import           System.IO-import           System.Process              (createPipe)+import           System.Process                          (createPipe) import           Test.Hspec import           Test.Hspec.QuickCheck import           Test.QuickCheck import           Test.QuickCheck.Monadic+import           Text.Format +import           Logging.Class+import           Logging.Filter+import           Logging.Handler.FileHandler+import           Logging.Handler.RotatingFileHandler+import           Logging.Handler.StreamHandler+import           Logging.Handler.TimeRotatingFileHandler+import           Logging.Level+import           Logging.Logger import           Logging.Prelude-import           Logging.Types+import           Logging.Record+import           Logging.Sink+ import           LoggingTest.Prelude  spec :: Spec@@ -54,14 +72,19 @@ handlerSpec = describe "Handler" $ do   (read, write) <- runIO createPipe   fileRef <- runIO $ newIORef undefined-  rotateFileRef <- runIO $ newIORef undefined+  rotateFileMVar <- runIO newEmptyMVar+  timeRotateRef <- runIO $ newIORef undefined+  timeFileMVar <- runIO newEmptyMVar   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+          1000 5 rotateFileMVar+      timeHandler = toHandler $+        TimeRotatingFileHandler def [] "{message}" "/tmp/log4hs/time.log" utf8+          utc (Minute 5) 5 timeRotateRef timeFileMVar   runIO $ open handler >> open fileHandler >> open rotateHandler    prop "filter" $ \(rcd@LogRecord{..}) -> monadicIO $ do@@ -98,7 +121,7 @@     assert (msg == message)    prop "rotate" $ \(rcd, Alphabet c) -> monadicIO $ do-    file <- run $ readIORef rotateFileRef+    file <- run $ readMVar rotateFileMVar     run $ hSetFileSize file 0 >> hSeek file AbsoluteSeek 0     let message = replicate 99 c         rcd' = rcd { message = message }@@ -111,7 +134,7 @@     run $ handle rotateHandler rcd'     closed <- run $ hIsClosed file     assert closed-    pos <- run $ readIORef rotateFileRef >>= hTell+    pos <- run $ readMVar rotateFileMVar >>= hTell     assert (pos == 0)     -- rotate.1.log     file1 <- run $ openLogFile "/tmp/log4hs/rotate.1.log" utf8@@ -120,7 +143,7 @@     run $ hClose file1     assert $ all (== message) msgs1     -- rollover again-    file' <- run $ readIORef rotateFileRef+    file' <- run $ readMVar rotateFileMVar     run $ forM [1..10] $ \_ -> handle rotateHandler rcd'     closed1 <- run $ hIsClosed file'     assert closed1@@ -131,3 +154,34 @@     run $ hClose file2     -- rotate.2.log     assert $ all (== message) msgs2+  prop "time" $ \(Positive n, rcd) -> monadicIO $ do+    -- open+    now <- run $ getCurrentTime+    let mtime = addUTCTime (negate $ 310 * fromInteger n) now+    run $ do+      createFile "/tmp/log4hs/time.log"+      setModificationTime "/tmp/log4hs/time.log" mtime+      open timeHandler+    rt <- run $ readIORef timeRotateRef+    let ts1 = fromInteger $ 300 * (1 + truncate ((utcTimeToPOSIXSeconds mtime) / 300))+    assert (ts1 == utcTimeToPOSIXSeconds rt)+    -- rotate+    file <- run $ readMVar timeFileMVar+    run $ hSetFileSize file 0 >> hSeek file AbsoluteSeek 0+    run $ handle timeHandler $ rcd {utctime = now}+    closed <- run $ hIsClosed file+    assert closed+    -- contents of new file+    file1 <- run $ readMVar timeFileMVar+    run $ hSeek file1 AbsoluteSeek 0+    msg <- run $ hTryGetLine file1+    assert $ msg == message rcd+    -- latest backup+    exist <- run $ doesFileExist $ appendBaseName "/tmp/log4hs/time.log" $+      format ".{:%Y-%m-%d_%H-%M}" $ addUTCTime (negate 300) rt+    assert exist+    -- max backups+    files <- run $ listDirectory "/tmp/log4hs/"+    assert $ 6 >= length [f | f <- files, isPrefixOf "/tmp/log4hs/time." f]++    run $ close timeHandler