log4hs 0.0.6.0 → 0.0.7.0

raw patch · 22 files changed

+562/−435 lines, 22 filesdep +aeson-qqdep ~aesondep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson-qq

Dependency ranges changed: aeson, containers

API changes (from Hackage documentation)

Files

• bench/Main.hs +6/−1
• log4hs.cabal +24/−8
• src/Logging/Aeson.hs +8/−17
• src/Logging/Internal.hs +13/−18
• src/Logging/Types.hs +18/−361
• src/Logging/Types/Class.hs +10/−0
• src/Logging/Types/Class/Filterable.hs +14/−0
• src/Logging/Types/Class/Formattable.hs +9/−0
• src/Logging/Types/Class/Handler.hs +81/−0
• src/Logging/Types/Filter.hs +38/−0
• src/Logging/Types/Formatter.hs +79/−0
• src/Logging/Types/Handlers.hs +5/−0
• src/Logging/Types/Handlers/StreamHandler.hs +35/−0
• src/Logging/Types/Level.hs +56/−0
• src/Logging/Types/Logger.hs +5/−0
• src/Logging/Types/Manager.hs +14/−0
• src/Logging/Types/Record.hs +27/−0
• src/Logging/Types/Sink.hs +40/−0
• src/Logging/Utils.hs +59/−0
• test/Logging/AesonSpec.hs +17/−12
• test/Logging/TypesSpec.hs +3/−15
• test/LoggingSpec.hs +1/−3

@@ -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

@@ -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

@@ -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

@@ -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.

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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]

@@ -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

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

@@ -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

@@ -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"

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

@@ -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+                       }

@@ -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+                           }

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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            )