diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} @@ -5,7 +6,11 @@ import Criterion.Main import Data.Aeson -import Data.Aeson.QQ.Simple +#if MIN_VERSION_aeson(1, 4, 3) +import Data.Aeson.QQ.Simple (aesonQQ) +#else +import Data.Aeson.QQ (aesonQQ) +#endif import Data.Maybe import Logging import System.IO.Unsafe 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: f2370e21e4ee599e5f39cb01456bcda6598b0a4ed115c1b69a0f94049635a3d5 +-- hash: 14d30e39d3ff2113f4ac08f122aa6f61a676b9d34facaafce1bc794bbeda7e10 name: log4hs -version: 0.0.6.0 +version: 0.0.7.0 synopsis: A python logging style log library description: Please see the http://hackage.haskell.org/package/log4hs category: logging @@ -25,17 +25,31 @@ Logging Logging.Aeson Logging.Types + Logging.Utils other-modules: Logging.Deprecated Logging.Internal Logging.TH + Logging.Types.Class + Logging.Types.Class.Filterable + Logging.Types.Class.Formattable + Logging.Types.Class.Handler + Logging.Types.Filter + Logging.Types.Formatter + Logging.Types.Handlers + 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 build-depends: - aeson >=1.2 && <1.5 + aeson >=1.2 && <2.0 , base >=4.7 && <5 - , containers >=0.5 && <0.7 + , containers >=0.5.10 && <1.0 , data-default >=0.5 && <1.0 , directory >=1.2 && <1.4 , filepath >=1.3 && <1.5 @@ -59,9 +73,10 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck >=2.0 && <3.0 - , aeson >=1.2 && <1.5 + , aeson >=1.2 && <2.0 + , aeson-qq >=0.8 && <1.0 , base >=4.7 && <5 - , containers >=0.5 && <0.7 + , containers >=0.5.10 && <1.0 , data-default >=0.5 && <1.0 , directory >=1.2 && <1.4 , filepath >=1.3 && <1.5 @@ -85,9 +100,10 @@ bench ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - aeson >=1.2 && <1.5 + aeson >=1.2 && <2.0 + , aeson-qq >=0.8 && <1.0 , base >=4.7 && <5 - , containers >=0.5 && <0.7 + , containers >=0.5.10 && <1.0 , criterion >=1.0 && <2.0 , data-default >=0.5 && <1.0 , directory >=1.2 && <1.4 diff --git a/src/Logging/Aeson.hs b/src/Logging/Aeson.hs --- a/src/Logging/Aeson.hs +++ b/src/Logging/Aeson.hs @@ -12,7 +12,6 @@ ) where import Control.Applicative (pure) -import Control.Concurrent.MVar import Control.Lens (set) import Data.Aeson import Data.Aeson.Types (Parser, typeMismatch) @@ -25,6 +24,7 @@ import Logging.Internal import Logging.Types +import Logging.Utils mapAp :: (Applicative f1, Applicative f2) => f1 (a -> b) -> f2 a -> (f1 (f2 b)) @@ -143,8 +143,8 @@ parseJSON invalid = typeMismatch "Object" invalid -instance FromJSON (IO StreamHandler) where - parseJSON = withObject "StreamHandler" $ \v -> flip mapAp (newMVar ()) $ +instance FromJSON (StreamHandler) where + parseJSON = withObject "StreamHandler" $ \v -> StreamHandler <$> (parseStream <$> (v .:? "stream" .!= "stderr")) <*> v .:? "level" .!= def <*> v .:? "filterer" .!= [] @@ -159,24 +159,15 @@ instance FromJSON (IO SomeHandler) where parseJSON = withObject "Handler" $ \v -> (v .: "type") >>= (`parseHandler` v) where - openLogFile :: FilePath -> IO Handle - openLogFile file = do - file' <- makeAbsolute file - createDirectoryIfMissing True $ takeDirectory file' - stream <- openFile file AppendMode - hSetEncoding stream utf8 - return stream - parseHandler :: String -> Object -> Parser (IO SomeHandler) parseHandler "StreamHandler" v = do hdl <- parseJSON (Object v) - return $ toHandler <$> (hdl :: IO StreamHandler) + return $ return $ toHandler (hdl :: StreamHandler) parseHandler "FileHandler" v = do - hdl :: (IO StreamHandler) <- parseJSON (Object v) - stream <- openLogFile <$> (v .: "file" .!= "default.log") - hdl' <- mapAp2 (pure $ \h s -> h {stream = s}) hdl stream - return $ toHandler <$> hdl' - parseHandler t _ = error $ "Logging.Aeson: no parse (Handler" ++ t ++")" + hdl <- parseJSON (Object v) + file <- v .: "file" .!= "default.log" + return $ openLogFile file utf8 >>= \stream -> return $ + toHandler (hdl {stream = stream} :: StreamHandler) instance FromJSON (M.Map String Formatter -> IO SomeHandler) where diff --git a/src/Logging/Internal.hs b/src/Logging/Internal.hs --- a/src/Logging/Internal.hs +++ b/src/Logging/Internal.hs @@ -12,7 +12,6 @@ , defaultRoot ) where -import Control.Concurrent.MVar import Control.Exception (SomeException, bracket_) import Control.Lens (view) import Control.Monad (forM_, void, when) @@ -20,13 +19,13 @@ import Data.Default import Data.Generics.Product.Typed import Data.IORef -import Data.List (dropWhileEnd) -import Data.Map.Lazy ((!?)) +import Data.List (dropWhileEnd, group) +import Data.Map.Lazy (elems, (!?)) import Data.Time.Clock import Data.Time.LocalTime import GHC.Conc (setUncaughtExceptionHandler) import Prelude hiding (filter, log) -import System.IO (Handle, stderr, stdout) +import System.IO (stderr, stdout) import System.IO.Unsafe (unsafePerformIO) import Logging.Types @@ -50,20 +49,23 @@ run :: Manager -> IO a -> IO a run mgr@Manager{..} io = do when catchUncaughtException $ setUncaughtExceptionHandler uceHandler - bracket_ (atomicWriteIORef _mgr mgr) shutdown io + bracket_ (atomicWriteIORef _mgr mgr >> start) shutdown io where unknownLoc = ("unknown file", "unknown package", "unknown module", 0) uceHandler :: SomeException -> IO () uceHandler e = log "" "ERROR" (show e) unknownLoc - shutdown :: IO () - shutdown = closeHandlers root >> forM_ sinks closeHandlers + allHandlers = map head $ group $ + concat [ handlers s | s <- (root : (elems sinks)) ] - closeHandlers :: Sink -> IO () - closeHandlers Sink{..} = forM_ handlers close + start :: IO () + start = forM_ allHandlers open + shutdown :: IO () + shutdown = forM_ allHandlers close + -- |Low-level logging routine which creates a LogRecord and then calls -- all the handlers of this logger to handle the record. log :: MonadIO m @@ -111,20 +113,13 @@ | otherwise = filter (view (typed @Filterer) hdl) rcd --- |A ultility function for creating 'StreamHandler' -makeStreamHandler :: Handle -> IO StreamHandler -makeStreamHandler stream = StreamHandler stream def [] def <$> newMVar () - - -{-# NOINLINE stderrHandler #-} -- |A 'StreamHandler' bound to 'stderr' stderrHandler :: StreamHandler -stderrHandler = unsafePerformIO $ makeStreamHandler stderr +stderrHandler = StreamHandler stderr def [] def -{-# NOINLINE stdoutHandler #-} -- |A 'StreamHandler' bound to 'stdout' stdoutHandler :: StreamHandler -stdoutHandler = unsafePerformIO $ makeStreamHandler stdout +stdoutHandler = StreamHandler stdout def [] def {-# NOINLINE defaultRoot #-} -- |Default root sink which is used by 'jsonToManager' when __root__ is missed. diff --git a/src/Logging/Types.hs b/src/Logging/Types.hs --- a/src/Logging/Types.hs +++ b/src/Logging/Types.hs @@ -1,364 +1,21 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - module Logging.Types - ( Logger(..) - , Level(..) - , LogRecord(..) - , Filter(..) - , Filterer - , Formatter(..) - , SomeHandler(..) - , StreamHandler(..) - , Sink(..) - , Manager(..) - , Filterable(..) - , Formattable(..) - , Handler(..) + ( module Logging.Types.Logger + , module Logging.Types.Level + , module Logging.Types.Filter + , module Logging.Types.Formatter + , module Logging.Types.Record + , module Logging.Types.Handlers + , module Logging.Types.Sink + , module Logging.Types.Manager + , module Logging.Types.Class ) where -import Control.Concurrent.MVar (MVar, putMVar, takeMVar) -import Control.Exception (bracket) -import Control.Lens (set, view) -import Control.Monad (unless, when) -import Data.Default -import Data.Generics.Product.Typed -import Data.List (stripPrefix) -import Data.Map.Lazy (Map) -import Data.String -import Data.Time.Clock -import qualified Data.Time.Format as TF -import Data.Time.LocalTime -import Data.Typeable -import GHC.Generics -import Prelude hiding (filter) -import System.FilePath -import System.IO -import Text.Printf (printf) - --- |'Logger' is just a name. -type Logger = String - - --- |'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" - - --- |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. --- -data LogRecord = LogRecord { logger :: Logger - , level :: Level - , message :: String - , filename :: String - , packagename :: String - , modulename :: String - , lineno :: Int - , created :: ZonedTime - } - - --- | 'Filter's are used to perform arbitrary filtering of 'LogRecord's. --- --- 'Sink's and 'Handler's can optionally use 'Filter' to filter records --- as desired. It allows events which are below a certain point in the --- sink hierarchy. For example, a filter initialized with "A.B" will allow --- events logged by loggers "A.B", "A.B.C", "A.B.C.D", "A.B.D" etc. --- but not "A.BB", "B.A.B" etc. --- If initialized name with the empty string, all events are passed. -newtype Filter = Filter Logger deriving (Read, Show, Eq) - -instance IsString Filter where - fromString = Filter - - --- |List of Filter -type Filterer = [Filter] - - --- |'Formatter's are used to convert a LogRecord to text. --- --- 'Formatter's need to know how a 'LogRecord' is constructed. They are --- responsible for converting a 'LogRecord' to (usually) a string which can --- be interpreted by either a human or an external system. The base 'Formatter' --- allows a formatting string to be specified. If none is supplied, the --- default value, "%(message)s" is used. --- --- --- The 'Formatter' can be initialized with a format string which makes use of --- knowledge of the 'LogRecord' attributes - e.g. the default value mentioned --- above makes use of a 'LogRecord''s message attribute. Currently, the useful --- attributes in a 'LogRecord' are described by: --- --- [@%(logger)s@] Name of the logger (logging channel) --- [@%(level)s@] Numeric logging level for the message (DEBUG, INFO, WARN, --- ERROR, FATAL, LEVEL v) --- [@%(pathname)s@] Full pathname of the source file where the logging --- call was issued (if available) --- [@%(filename)s@] Filename portion of pathname --- [@%(module)s@] Module (name portion of filename) --- [@%(lineno)d@] Source line number where the logging call was issued --- (if available) --- [@%(created)f@] Time when the LogRecord was created (picoseconds --- since '1970-01-01 00:00:00') --- [@%(asctime)s@] Textual time when the 'LogRecord' was created --- [@%(msecs)d@] Millisecond portion of the creation time --- [@%(message)s@] The main message passed to 'logv' 'debug' 'info' .. --- -data Formatter = Formatter { fmt :: String - , datefmt :: String -- ^ see "Data.Time.Format" - } deriving (Eq) - -instance Default Formatter where - def = Formatter "%(message)s" "%Y-%m-%dT%H:%M:%S%6Q%z" - - -type Lock = MVar () - - --- |The 'SomeHandler' type is the root of the handler type hierarchy. --- It hold 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 Formatter SomeHandler where - getTyped (SomeHandler h) = view (typed @Formatter) h - setTyped v (SomeHandler h) = SomeHandler $ set (typed @Formatter) v h - -instance {-# OVERLAPPING #-} HasType Lock SomeHandler where - getTyped (SomeHandler h) = view (typed @Lock) h - setTyped v (SomeHandler h) = SomeHandler $ set (typed @Lock) v h - - --- | A handler type which writes logging records, appropriately formatted, --- to a stream. --- --- Note that this class does not close the stream when the stream is a --- terminal device, e.g. 'stderr' and 'stdout'. --- --- Note: 'FileHandler' is an alias of 'StreamHandler' -data StreamHandler = StreamHandler { stream :: Handle - , level :: Level - , filterer :: Filterer - , formatter :: Formatter - , lock :: Lock - } deriving (Generic) - - --- |'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 - } - - --- |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 - } - - --- |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) - -instance Filterable Filter where - filter (Filter self) rcd@LogRecord{..} - | self == "" = True - | otherwise = case stripPrefix self logger of - Just "" -> True -- self == logger - Just ('.':_) -> True -- self == parent logger - _ -> False - -instance Filterable Sink where - filter Sink{..} = filter filterer - - --- |A class represents a common trait of formatting 'LogRecord' as 'String'. -class Formattable a where - format :: a -> LogRecord -> String - formatTime :: a -> LogRecord -> String - -instance Formattable Formatter where - format f@Formatter{..} rcd@LogRecord{..} = formats fmt - where - formats :: String -> String - formats ('%':'%':cs) = ('%' :) $ formats cs - formats ('%':'(':cs) = - case break (== ')') cs of - (attr, ')':c:cs') -> (formatAttr attr c) ++ (formats cs') - _ -> error "Logging.Types.Formattable: no parse (Formatter)" - formats (c:cs) = (c :) $ formats cs - formats "" = "" - - formatAttr :: String -> Char -> String - formatAttr "logger" fc = printf ['%', fc] logger -- %(logger)s - formatAttr "level" fc = printf ['%', fc] $ show level -- %(level)s - formatAttr "pathname" fc = printf ['%', fc] $ takeDirectory filename -- %(pathname)s - formatAttr "filename" fc = printf ['%', fc] $ takeFileName filename -- %(filename)s - formatAttr "module" fc = printf ['%', fc] modulename -- %(module)s - formatAttr "lineno" fc = printf ['%', fc] lineno -- %(lineno)d - formatAttr "created" fc = printf ['%', fc] $ toTimestamp created -- %(created)f - formatAttr "asctime" fc = printf ['%', fc] $ formatTime f rcd -- %(asctime)s - formatAttr "msecs" fc = printf ['%', fc] $ toMilliseconds created -- %(msecs)d - formatAttr "message" fc = printf ['%', fc] message -- %(message)s - formatAttr _ _ = "unknown" - - utcZero :: UTCTime - utcZero = read "1970-01-01 00:00:00 UTC" - - toTimestamp :: ZonedTime -> Double - toTimestamp lt = fromRational $ toRational $ diffUTCTime (zonedTimeToUTC lt) utcZero - - toMilliseconds :: ZonedTime -> Integer - toMilliseconds lt = round $ (toTimestamp lt) * 1000 - - formatTime Formatter{..} LogRecord{..} = - TF.formatTime TF.defaultTimeLocale datefmt created - - --- |A type class that abstracts the characteristics of a 'Handler' -class ( HasType Level a - , HasType Filterer a - , HasType Formatter a - , HasType Lock a - , Typeable a - ) => Handler a where - emit :: a -> LogRecord -> IO () - - flush :: a -> IO () - flush _ = return () - - close :: a -> IO () - close _ = return () - - handle :: a -> LogRecord -> IO Bool - handle hdl rcd = do - let rv = filter (view (typed @Filterer) hdl) rcd - when rv $ with hdl (`emit` rcd) - return rv - where - acquire :: a -> IO () - acquire = takeMVar . (view $ typed @Lock) - - release :: a -> IO () - release = (`putMVar` ()) . (view $ typed @Lock) - - with :: a -> (a -> IO b) -> IO b - with l io = bracket (acquire l) (\_ -> release l) (\_ -> io l) - - fromHandler :: SomeHandler -> Maybe a - fromHandler (SomeHandler h) = cast h - - toHandler :: a -> SomeHandler - toHandler = SomeHandler - -instance Handler SomeHandler where - emit (SomeHandler h) = emit h - flush (SomeHandler h) = flush h - close (SomeHandler h) = close h - fromHandler = Just . id - toHandler = id - -instance Handler StreamHandler where - emit hdl rcd = do - hPutStrLn (stream hdl) $ format (view (typed @Formatter) hdl) rcd - flush hdl - - flush = hFlush . stream - - close StreamHandler{..} = do - isClosed <- hIsClosed stream - unless isClosed $ hIsTerminalDevice stream >>= (`unless` (hClose stream)) +import Logging.Types.Class +import Logging.Types.Filter +import Logging.Types.Formatter +import Logging.Types.Handlers +import Logging.Types.Level +import Logging.Types.Logger +import Logging.Types.Manager +import Logging.Types.Record +import Logging.Types.Sink diff --git a/src/Logging/Types/Class.hs b/src/Logging/Types/Class.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Types/Class.hs @@ -0,0 +1,10 @@ +module Logging.Types.Class + ( module Logging.Types.Class.Filterable + , module Logging.Types.Class.Formattable + , module Logging.Types.Class.Handler + ) where + + +import Logging.Types.Class.Filterable +import Logging.Types.Class.Formattable +import Logging.Types.Class.Handler diff --git a/src/Logging/Types/Class/Filterable.hs b/src/Logging/Types/Class/Filterable.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Types/Class/Filterable.hs @@ -0,0 +1,14 @@ +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/Formattable.hs b/src/Logging/Types/Class/Formattable.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Types/Class/Formattable.hs @@ -0,0 +1,9 @@ +module Logging.Types.Class.Formattable ( Formattable(..) ) where + +import Logging.Types.Record + + +-- |A class represents a common trait of formatting 'LogRecord' as 'String'. +class Formattable a where + format :: a -> LogRecord -> String + formatTime :: a -> LogRecord -> String diff --git a/src/Logging/Types/Class/Handler.hs b/src/Logging/Types/Class/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Types/Class/Handler.hs @@ -0,0 +1,81 @@ +{-# 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 Logging.Types.Class.Filterable +import Logging.Types.Filter +import Logging.Types.Formatter +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 Formatter SomeHandler where + getTyped (SomeHandler h) = view (typed @Formatter) h + setTyped v (SomeHandler h) = SomeHandler $ set (typed @Formatter) v h + +instance Eq SomeHandler where + (SomeHandler h1) == h2 = Just h1 == fromHandler h2 + +instance Handler SomeHandler where + emit (SomeHandler h) = emit h + flush (SomeHandler h) = flush h + close (SomeHandler h) = close 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 Formatter a + , Typeable a + , Eq a + ) => Handler a where + open :: a -> IO () + open _ = return () + + emit :: a -> LogRecord -> IO () + + flush :: a -> IO () + flush _ = return () + + close :: a -> IO () + close _ = return () + + handle :: a -> LogRecord -> IO Bool + handle hdl rcd = do + let rv = filter (view (typed @Filterer) hdl) rcd + when rv $ emit hdl rcd + return rv + + 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 new file mode 100644 --- /dev/null +++ b/src/Logging/Types/Filter.hs @@ -0,0 +1,38 @@ +{-# 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 records +-- as desired. It allows events which are below a certain point in the +-- sink hierarchy. For example, a filter initialized with "A.B" will allow +-- events logged by loggers "A.B", "A.B.C", "A.B.C.D", "A.B.D" etc. +-- but not "A.BB", "B.A.B" etc. +-- If initialized name with the empty string, all events are passed. +newtype Filter = Filter Logger deriving (Read, Show, Eq) + +instance IsString Filter where + fromString = Filter + +instance Filterable Filter where + filter (Filter self) rcd@LogRecord{..} + | self == "" = True + | otherwise = case stripPrefix self logger of + Just "" -> True -- self == logger + Just ('.':_) -> True -- self == parent logger + _ -> False + + +-- |List of Filter +type Filterer = [Filter] diff --git a/src/Logging/Types/Formatter.hs b/src/Logging/Types/Formatter.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Types/Formatter.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE RecordWildCards #-} + +module Logging.Types.Formatter ( Formatter(..) ) where + +import Data.Default +import qualified Data.Time.Format as TF +import System.FilePath +import Text.Printf + +import Logging.Types.Class.Formattable +import Logging.Types.Record +import Logging.Utils + + +-- |'Formatter's are used to convert a LogRecord to text. +-- +-- 'Formatter's need to know how a 'LogRecord' is constructed. They are +-- responsible for converting a 'LogRecord' to (usually) a string which can +-- be interpreted by either a human or an external system. The base 'Formatter' +-- allows a formatting string to be specified. If none is supplied, the +-- default value, "%(message)s" is used. +-- +-- +-- The 'Formatter' can be initialized with a format string which makes use of +-- knowledge of the 'LogRecord' attributes - e.g. the default value mentioned +-- above makes use of a 'LogRecord''s message attribute. Currently, the useful +-- attributes in a 'LogRecord' are described by: +-- +-- [@%(logger)s@] Name of the logger (logging channel) +-- [@%(level)s@] Numeric logging level for the message (DEBUG, INFO, WARN, +-- ERROR, FATAL, LEVEL v) +-- [@%(pathname)s@] Full pathname of the source file where the logging +-- call was issued (if available) +-- [@%(filename)s@] Filename portion of pathname +-- [@%(module)s@] Module (name portion of filename) +-- [@%(lineno)d@] Source line number where the logging call was issued +-- (if available) +-- [@%(created)f@] Time when the LogRecord was created (picoseconds +-- since '1970-01-01 00:00:00') +-- [@%(asctime)s@] Textual time when the 'LogRecord' was created +-- [@%(msecs)d@] Millisecond portion of the creation time +-- [@%(message)s@] The main message passed to 'logv' 'debug' 'info' .. +-- +data Formatter = Formatter { fmt :: String + , datefmt :: String -- ^ see "Data.Time.Format" + } deriving (Eq) + +instance Default Formatter where + def = Formatter "%(message)s" "%Y-%m-%dT%H:%M:%S%6Q%z" + +instance Formattable Formatter where + format f@Formatter{..} rcd@LogRecord{..} = formats fmt + where + diffTime = zonedTimeToPOSIXSeconds created + + formats :: String -> String + formats ('%':'%':cs) = ('%' :) $ formats cs + formats ('%':'(':cs) = + case break (== ')') cs of + (attr, ')':c:cs') -> (formatAttr attr c) ++ (formats cs') + _ -> error "Logging.Types.Formattable: no parse (Formatter)" + formats (c:cs) = (c :) $ formats cs + formats "" = "" + + formatAttr :: String -> Char -> String + formatAttr "logger" fc = printf ['%', fc] logger -- %(logger)s + formatAttr "level" fc = printf ['%', fc] $ show level -- %(level)s + formatAttr "pathname" fc = printf ['%', fc] $ takeDirectory filename -- %(pathname)s + formatAttr "filename" fc = printf ['%', fc] $ takeFileName filename -- %(filename)s + formatAttr "module" fc = printf ['%', fc] modulename -- %(module)s + formatAttr "lineno" fc = printf ['%', fc] lineno -- %(lineno)d + formatAttr "created" fc = printf ['%', fc] $ timestamp diffTime -- %(created)f + formatAttr "asctime" fc = printf ['%', fc] $ formatTime f rcd -- %(asctime)s + formatAttr "msecs" fc = printf ['%', fc] $ microseconds diffTime -- %(msecs)d + formatAttr "message" fc = printf ['%', fc] message -- %(message)s + formatAttr _ _ = "unknown" + + formatTime Formatter{..} LogRecord{..} = + TF.formatTime TF.defaultTimeLocale datefmt created diff --git a/src/Logging/Types/Handlers.hs b/src/Logging/Types/Handlers.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Types/Handlers.hs @@ -0,0 +1,5 @@ +module Logging.Types.Handlers + ( module Logging.Types.Handlers.StreamHandler + ) where + +import Logging.Types.Handlers.StreamHandler diff --git a/src/Logging/Types/Handlers/StreamHandler.hs b/src/Logging/Types/Handlers/StreamHandler.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Types/Handlers/StreamHandler.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} + +module Logging.Types.Handlers.StreamHandler ( StreamHandler(..) ) where + +import Control.Monad (unless) +import GHC.Generics +import System.IO + +import Logging.Types.Class +import Logging.Types.Filter +import Logging.Types.Formatter +import Logging.Types.Level + + +-- | A handler type which writes logging records, appropriately formatted, +-- to a stream. +-- +-- Note that this class does not close the stream when the stream is a +-- terminal device, e.g. 'stderr' and 'stdout'. +-- +-- Note: 'FileHandler' is an alias of 'StreamHandler' +data StreamHandler = StreamHandler { stream :: Handle + , level :: Level + , filterer :: Filterer + , formatter :: Formatter + } deriving (Generic, Eq) + +instance Handler StreamHandler where + emit hdl@StreamHandler{..} rcd = do + hPutStrLn stream $ format formatter rcd + flush hdl + + flush = hFlush . stream diff --git a/src/Logging/Types/Level.hs b/src/Logging/Types/Level.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Types/Level.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Logging.Types.Level ( Level(..) ) where + +import Data.Default +import Data.List (stripPrefix) +import Data.String + + +-- |'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" diff --git a/src/Logging/Types/Logger.hs b/src/Logging/Types/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Types/Logger.hs @@ -0,0 +1,5 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Logging/Types/Manager.hs @@ -0,0 +1,14 @@ +module Logging.Types.Manager ( Manager(..) ) where + +import Data.Map.Lazy (Map) + +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 + } diff --git a/src/Logging/Types/Record.hs b/src/Logging/Types/Record.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Types/Record.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module Logging.Types.Record ( LogRecord(..) ) where + +import Data.Time.LocalTime + +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. +-- +data LogRecord = LogRecord { logger :: Logger + , level :: Level + , message :: String + , filename :: String + , packagename :: String + , modulename :: String + , lineno :: Int + , created :: ZonedTime + } diff --git a/src/Logging/Types/Sink.hs b/src/Logging/Types/Sink.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Types/Sink.hs @@ -0,0 +1,40 @@ +{-# 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/src/Logging/Utils.hs b/src/Logging/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Utils.hs @@ -0,0 +1,59 @@ +module Logging.Utils + ( addZonedTime + , diffZonedTime + , zonedTimeToPOSIXSeconds + , timestamp + , seconds + , milliseconds + , microseconds + , openLogFile + ) where + +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Data.Time.LocalTime +import System.Directory +import System.Environment +import System.FilePath +import System.IO + + +addZonedTime :: NominalDiffTime -> ZonedTime -> ZonedTime +addZonedTime ndt zt@(ZonedTime _ tz) = + utcToZonedTime tz $ addUTCTime ndt $ zonedTimeToUTC zt + + +diffZonedTime :: ZonedTime -> ZonedTime -> NominalDiffTime +diffZonedTime zt1 zt2 = diffUTCTime (zonedTimeToUTC zt1) (zonedTimeToUTC zt2) + + +zonedTimeToPOSIXSeconds :: ZonedTime -> NominalDiffTime +zonedTimeToPOSIXSeconds = utcTimeToPOSIXSeconds . zonedTimeToUTC + + +timestamp :: NominalDiffTime -> Double +timestamp = fromRational . toRational + + +seconds :: NominalDiffTime -> Integer +seconds = truncate + + +milliseconds :: NominalDiffTime -> Integer +milliseconds = truncate . (* 1000) + + +microseconds :: NominalDiffTime -> Integer +microseconds = truncate . (* 1000000) + + +openLogFile :: FilePath -> TextEncoding -> IO Handle +openLogFile path encoding = do + absPath <- makeAbsolute path + progName <- getProgName + let dir = takeDirectory absPath + file = if dir == absPath then dir (progName ++ ".log") else absPath + createDirectoryIfMissing True dir + stream <- openFile file AppendMode + hSetEncoding stream encoding + return stream diff --git a/test/Logging/AesonSpec.hs b/test/Logging/AesonSpec.hs --- a/test/Logging/AesonSpec.hs +++ b/test/Logging/AesonSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} @@ -9,7 +10,11 @@ import Control.Lens (view) import Control.Monad import Data.Aeson +#if MIN_VERSION_aeson(1, 4, 3) import Data.Aeson.QQ.Simple (aesonQQ) +#else +import Data.Aeson.QQ (aesonQQ) +#endif import Data.Default (def) import Data.Generics.Product.Typed import Data.List (intercalate) @@ -56,24 +61,24 @@ handlerSpec :: Spec handlerSpec = describe "Handler" $ modifyMaxSize (const 1000) $ do it "decode StreamHandler simple" $ do - StreamHandler{..} <- fromJust $ decode $ encode $ - [aesonQQ|{"type": "StreamHandler"}|] + let StreamHandler{..} = fromJust $ decode $ encode $ + [aesonQQ|{"type": "StreamHandler"}|] stream == stderr `shouldBe` True level == def `shouldBe` True filterer == [] `shouldBe` True formatter == def `shouldBe` True it "decode StreamHandler standard" $ do - StreamHandler{..} <- fromJust $ decode $ encode $ - [aesonQQ| - { - "type": "StreamHandler", - "stream": "stdout", - "level": "DEBUG", - "filterer": ["Module.Submodule"], - "formatter": "default" - } - |] + let StreamHandler{..} = fromJust $ decode $ encode $ + [aesonQQ| + { + "type": "StreamHandler", + "stream": "stdout", + "level": "DEBUG", + "filterer": ["Module.Submodule"], + "formatter": "default" + } + |] stream == stdout `shouldBe` True level == "DEBUG" `shouldBe` True diff --git a/test/Logging/TypesSpec.hs b/test/Logging/TypesSpec.hs --- a/test/Logging/TypesSpec.hs +++ b/test/Logging/TypesSpec.hs @@ -15,6 +15,7 @@ import Text.Printf import Logging.Types +import Logging.Utils spec :: Spec spec = levelSpec >> formatterSpec @@ -70,8 +71,8 @@ levelFmt = \LogRecord{..} -> show level pathnameFmt = takeDirectory . filename filenameFmt = takeFileName . filename - createdFmt = (printf "%f") . zt2timestamp . created - msecsFmt = show . zt2millisecs . created + createdFmt = (printf "%f") . timestamp . zonedTimeToPOSIXSeconds . created + msecsFmt = show . milliseconds . zonedTimeToPOSIXSeconds . created asctimeFmt = TF.formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" . created asctimeLevelLoggerFmt rcd = asctimeFmt rcd ++ " - " ++ (levelFmt rcd) ++ " - " ++(loggerFmt rcd) @@ -94,18 +95,5 @@ <*> (((`addZonedTime` zeroTime) . toEnum) <$> arbitrary) -addZonedTime :: NominalDiffTime -> ZonedTime -> ZonedTime -addZonedTime ndt zt@(ZonedTime _ tz) = - utcToZonedTime tz $ addUTCTime ndt $ zonedTimeToUTC zt - -diffZonedTime :: ZonedTime -> ZonedTime -> NominalDiffTime -diffZonedTime zt1 zt2 = diffUTCTime (zonedTimeToUTC zt1) (zonedTimeToUTC zt2) - zeroTime :: ZonedTime zeroTime = read "1970-01-01 00:00:00" - -zt2timestamp :: ZonedTime -> Double -zt2timestamp zt = fromRational $ toRational $ diffZonedTime zt zeroTime - -zt2millisecs :: ZonedTime -> Integer -zt2millisecs zt = round $ zt2timestamp zt * 1000 diff --git a/test/LoggingSpec.hs b/test/LoggingSpec.hs --- a/test/LoggingSpec.hs +++ b/test/LoggingSpec.hs @@ -5,7 +5,6 @@ module LoggingSpec ( spec ) where -import Control.Concurrent.MVar import Control.Monad import Data.Default (def) import Data.List (intercalate) @@ -145,11 +144,10 @@ createPipeHandler :: Level -> Filterer -> Formatter -> IO (SomeHandler, Handle) createPipeHandler level filterer formatter = do - lock <- newMVar () (read, write) <- createPipe hSetEncoding read utf8 hSetEncoding write utf8 - return $ ( toHandler $ StreamHandler write level filterer formatter lock + return $ ( toHandler $ StreamHandler write level filterer formatter , read )