diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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` diff --git a/log4hs.cabal b/log4hs.cabal --- a/log4hs.cabal +++ b/log4hs.cabal @@ -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 diff --git a/src/Logging/Class.hs b/src/Logging/Class.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Class.hs @@ -0,0 +1,8 @@ +module Logging.Class + ( module Logging.Class.Filterable + , module Logging.Class.Handler + ) where + + +import Logging.Class.Filterable +import Logging.Class.Handler diff --git a/src/Logging/Class/Filterable.hs b/src/Logging/Class/Filterable.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Class/Filterable.hs @@ -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) diff --git a/src/Logging/Class/Handler.hs b/src/Logging/Class/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Class/Handler.hs @@ -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 diff --git a/src/Logging/Config/Json.hs b/src/Logging/Config/Json.hs --- a/src/Logging/Config/Json.hs +++ b/src/Logging/Config/Json.hs @@ -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' diff --git a/src/Logging/Config/Type.hs b/src/Logging/Config/Type.hs --- a/src/Logging/Config/Type.hs +++ b/src/Logging/Config/Type.hs @@ -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 diff --git a/src/Logging/Config/Yaml.hs b/src/Logging/Config/Yaml.hs --- a/src/Logging/Config/Yaml.hs +++ b/src/Logging/Config/Yaml.hs @@ -57,7 +57,7 @@ import Data.Yaml import Logging.Config.Type -import Logging.Types (Manager) +import Logging.Manager -- | decode a 'Manager' from strict 'ByteString' diff --git a/src/Logging/Filter.hs b/src/Logging/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Filter.hs @@ -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] diff --git a/src/Logging/Global.hs b/src/Logging/Global.hs --- a/src/Logging/Global.hs +++ b/src/Logging/Global.hs @@ -16,4 +16,4 @@ import Logging.Global.Internal import Logging.Global.TH -import Logging.Types +import Logging.Manager diff --git a/src/Logging/Global/Internal.hs b/src/Logging/Global/Internal.hs --- a/src/Logging/Global/Internal.hs +++ b/src/Logging/Global/Internal.hs @@ -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 diff --git a/src/Logging/Global/TH.hs b/src/Logging/Global/TH.hs --- a/src/Logging/Global/TH.hs +++ b/src/Logging/Global/TH.hs @@ -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". -- diff --git a/src/Logging/Handler/FileHandler.hs b/src/Logging/Handler/FileHandler.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Handler/FileHandler.hs @@ -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 diff --git a/src/Logging/Handler/RotatingFileHandler.hs b/src/Logging/Handler/RotatingFileHandler.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Handler/RotatingFileHandler.hs @@ -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 diff --git a/src/Logging/Handler/StreamHandler.hs b/src/Logging/Handler/StreamHandler.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Handler/StreamHandler.hs @@ -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 diff --git a/src/Logging/Handler/TimeRotatingFileHandler.hs b/src/Logging/Handler/TimeRotatingFileHandler.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Handler/TimeRotatingFileHandler.hs @@ -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 diff --git a/src/Logging/Level.hs b/src/Logging/Level.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Level.hs @@ -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 diff --git a/src/Logging/Logger.hs b/src/Logging/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Logger.hs @@ -0,0 +1,5 @@ +module Logging.Logger ( Logger(..) ) where + + +-- |'Logger' is just a name. +type Logger = String diff --git a/src/Logging/Manager.hs b/src/Logging/Manager.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Manager.hs @@ -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)) ] diff --git a/src/Logging/Monad.hs b/src/Logging/Monad.hs --- a/src/Logging/Monad.hs +++ b/src/Logging/Monad.hs @@ -17,6 +17,6 @@ ) where +import Logging.Manager import Logging.Monad.Internal import Logging.Monad.TH -import Logging.Types diff --git a/src/Logging/Monad/Internal.hs b/src/Logging/Monad/Internal.hs --- a/src/Logging/Monad/Internal.hs +++ b/src/Logging/Monad/Internal.hs @@ -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) diff --git a/src/Logging/Monad/TH.hs b/src/Logging/Monad/TH.hs --- a/src/Logging/Monad/TH.hs +++ b/src/Logging/Monad/TH.hs @@ -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". -- diff --git a/src/Logging/Prelude.hs b/src/Logging/Prelude.hs --- a/src/Logging/Prelude.hs +++ b/src/Logging/Prelude.hs @@ -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 diff --git a/src/Logging/Record.hs b/src/Logging/Record.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Record.hs @@ -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" #-} diff --git a/src/Logging/Sink.hs b/src/Logging/Sink.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Sink.hs @@ -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 diff --git a/src/Logging/TH.hs b/src/Logging/TH.hs --- a/src/Logging/TH.hs +++ b/src/Logging/TH.hs @@ -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 diff --git a/src/Logging/Types.hs b/src/Logging/Types.hs --- a/src/Logging/Types.hs +++ b/src/Logging/Types.hs @@ -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 diff --git a/src/Logging/Types/Class.hs b/src/Logging/Types/Class.hs deleted file mode 100644 --- a/src/Logging/Types/Class.hs +++ /dev/null @@ -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 diff --git a/src/Logging/Types/Class/Filterable.hs b/src/Logging/Types/Class/Filterable.hs deleted file mode 100644 --- a/src/Logging/Types/Class/Filterable.hs +++ /dev/null @@ -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) diff --git a/src/Logging/Types/Class/Handler.hs b/src/Logging/Types/Class/Handler.hs deleted file mode 100644 --- a/src/Logging/Types/Class/Handler.hs +++ /dev/null @@ -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 diff --git a/src/Logging/Types/Filter.hs b/src/Logging/Types/Filter.hs deleted file mode 100644 --- a/src/Logging/Types/Filter.hs +++ /dev/null @@ -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] diff --git a/src/Logging/Types/Handlers.hs b/src/Logging/Types/Handlers.hs deleted file mode 100644 --- a/src/Logging/Types/Handlers.hs +++ /dev/null @@ -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 diff --git a/src/Logging/Types/Handlers/FileHandler.hs b/src/Logging/Types/Handlers/FileHandler.hs deleted file mode 100644 --- a/src/Logging/Types/Handlers/FileHandler.hs +++ /dev/null @@ -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 diff --git a/src/Logging/Types/Handlers/RotatingFileHandler.hs b/src/Logging/Types/Handlers/RotatingFileHandler.hs deleted file mode 100644 --- a/src/Logging/Types/Handlers/RotatingFileHandler.hs +++ /dev/null @@ -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 diff --git a/src/Logging/Types/Handlers/StreamHandler.hs b/src/Logging/Types/Handlers/StreamHandler.hs deleted file mode 100644 --- a/src/Logging/Types/Handlers/StreamHandler.hs +++ /dev/null @@ -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 diff --git a/src/Logging/Types/Level.hs b/src/Logging/Types/Level.hs deleted file mode 100644 --- a/src/Logging/Types/Level.hs +++ /dev/null @@ -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 diff --git a/src/Logging/Types/Logger.hs b/src/Logging/Types/Logger.hs deleted file mode 100644 --- a/src/Logging/Types/Logger.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Logging.Types.Logger ( Logger(..) ) where - - --- |'Logger' is just a name. -type Logger = String diff --git a/src/Logging/Types/Manager.hs b/src/Logging/Types/Manager.hs deleted file mode 100644 --- a/src/Logging/Types/Manager.hs +++ /dev/null @@ -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)) ] diff --git a/src/Logging/Types/Record.hs b/src/Logging/Types/Record.hs deleted file mode 100644 --- a/src/Logging/Types/Record.hs +++ /dev/null @@ -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 diff --git a/src/Logging/Types/Sink.hs b/src/Logging/Types/Sink.hs deleted file mode 100644 --- a/src/Logging/Types/Sink.hs +++ /dev/null @@ -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 diff --git a/test/LoggingTest/ConfigSpec.hs b/test/LoggingTest/ConfigSpec.hs --- a/test/LoggingTest/ConfigSpec.hs +++ b/test/LoggingTest/ConfigSpec.hs @@ -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 diff --git a/test/LoggingTest/GlobalSpec.hs b/test/LoggingTest/GlobalSpec.hs --- a/test/LoggingTest/GlobalSpec.hs +++ b/test/LoggingTest/GlobalSpec.hs @@ -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 diff --git a/test/LoggingTest/Prelude.hs b/test/LoggingTest/Prelude.hs --- a/test/LoggingTest/Prelude.hs +++ b/test/LoggingTest/Prelude.hs @@ -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 diff --git a/test/LoggingTest/TypesSpec.hs b/test/LoggingTest/TypesSpec.hs --- a/test/LoggingTest/TypesSpec.hs +++ b/test/LoggingTest/TypesSpec.hs @@ -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