log4hs (empty) → 0.0.1.0
raw patch · 11 files changed
+1115/−0 lines, 11 filesdep +QuickCheckdep +aesondep +basesetup-changed
Dependencies added: QuickCheck, aeson, base, containers, data-default, directory, filepath, hspec, hspec-core, log4hs, process, template-haskell, text, time, unordered-containers
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +69/−0
- Setup.hs +2/−0
- log4hs.cabal +71/−0
- src/Data/Aeson/Extra.hs +32/−0
- src/Logging.hs +88/−0
- src/Logging/Internal.hs +231/−0
- src/Logging/TH.hs +42/−0
- src/Logging/Types.hs +321/−0
- test/Spec.hs +226/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for logging++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019 Version Cloud++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of QK.G nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,69 @@+# A python logging style log library.++### A full example:++```haskell+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+++module Main (main) where++import Data.Aeson.QQ.Simple (aesonQQ)+import Prelude hiding (error)+import Logging (runJson, debug, info, warn, error, fatal, logv)++main :: IO ()+main = runJson manager app++myLogger = "MyLogger.Main"++app :: IO ()+app = do+ $(debug) myLogger "this message should print into MyLogger"+ $(info) myLogger "this message should print into MyLogger"+ $(warn) myLogger "this message should print into MyLogger"+ $(error) myLogger "this message should print into MyLogger"+ $(fatal) myLogger "this message should print into MyLogger"+ $(logv) myLogger "LEVEL 100" "this message should print into MyLogger"++-- The best practice is putting all config into a separate file,+-- e.g "Logging.json"+manager = [aesonQQ|{+ "loggers": {+ "root": {+ "level": "DEBUG",+ "handlers": ["console"],+ "propagate": false+ },+ "MyLogger": {+ "level": "INFO",+ "filterer": ["MyLogger.Main"],+ "handlers": ["file"],+ "propagate": false+ }+ },+ "handlers": {+ "console": {+ "type": "StreamHandler",+ "stream": "stderr",+ "level": "DEBUG",+ "formatter": "defaultFormatter"+ },+ "file": {+ "type": "FileHandler",+ "level": "INFO",+ "formatter": "defaultFormatter",+ "file": "./default.log"+ }+ },+ "formatters": {+ "defaultFormatter": {+ "fmt": "%(asctime)s - %(level)s - %(logger)s - %(pathname)s/%(filename)s:%(lineno)d] %(message)s"+ }+ }+}|]+```+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ log4hs.cabal view
@@ -0,0 +1,71 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 079eb73a7023c732592ffb83519d9d0edb3f5deb7e12f1786a072b767bbb249b++name: log4hs+version: 0.0.1.0+synopsis: A python logging style log library+description: Please see the README+category: logging+maintainer: Jorah Gao <gqk007@gmail.com>+copyright: (c) 2019 Version Cloud+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++library+ exposed-modules:+ Logging+ other-modules:+ Data.Aeson.Extra+ Logging.Internal+ Logging.TH+ Logging.Types+ Paths_log4hs+ hs-source-dirs:+ src+ build-depends:+ aeson >=1.4+ , base >=4.7 && <5+ , containers >=0.6+ , data-default >=0.7+ , directory >=1.3+ , filepath >=1.4+ , template-haskell >=2.14+ , text >=1.2+ , time >=1.8+ , unordered-containers >=0.2+ default-language: Haskell2010++test-suite log4hs-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_log4hs+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck >=2.12+ , aeson >=1.4+ , base >=4.7 && <5+ , containers >=0.6+ , data-default >=0.7+ , directory >=1.3+ , filepath >=1.4+ , hspec >=2.6+ , hspec-core >=2.6+ , log4hs+ , process >=1.6+ , template-haskell >=2.14+ , text >=1.2+ , time >=1.8+ , unordered-containers >=0.2+ default-language: Haskell2010
+ src/Data/Aeson/Extra.hs view
@@ -0,0 +1,32 @@+module Data.Aeson.Extra+ ( lookupObject+ , lookupArray+ , lookupString+ , lookupBool+ ) where+++import Data.Aeson+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T++lookupObject key kvs =+ case (HM.lookup key kvs) of+ Just (Object obj) ->+ HM.fromList $ map (\(k, v) -> (T.unpack k, v)) $ HM.toList obj+ _ -> HM.empty++lookupArray key kvs =+ case (HM.lookup key kvs) of+ Just (Array arr) -> foldr (:) [] arr+ _ -> []++lookupString def key kvs =+ case (HM.lookup key kvs) of+ Just (String t) -> T.unpack t+ _ -> def++lookupBool def key kvs =+ case (HM.lookup key kvs) of+ Just (Bool b) -> b+ _ -> def
+ src/Logging.hs view
@@ -0,0 +1,88 @@+{-|+Module : Logging+Copyright : (c) 2019 Version Cloud+License : BSD3+Maintainer : Jorah Gao <gqk007@gmail.com>+Stability : experimental+Portability : portable++= A python logging style log library.++=== A full example:++@+ \{\-\# LANGUAGE OverloadedStrings \#\-\}+ \{\-\# LANGUAGE QuasiQuotes \#\-\}+ \{\-\# LANGUAGE RecordWildCards \#\-\}+ \{\-\# LANGUAGE TemplateHaskell \#\-\}+++ module Main (main) where++ import Data.Aeson.QQ.Simple (aesonQQ)+ import Prelude hiding (error)+ import Logging (runJson, debug, info, warn, error, fatal, logv)++ main :: IO ()+ main = 'runJson' manager app++ myLogger = \"MyLogger.Main\"++ app :: IO ()+ app = do+ \$(debug) myLogger \"this message should print into MyLogger\"+ \$(info) myLogger \"this message should print into MyLogger\"+ \$(warn) myLogger \"this message should print into MyLogger\"+ \$(error) myLogger \"this message should print into MyLogger\"+ \$(fatal) myLogger \"this message should print into MyLogger\"+ \$(logv) myLogger "LEVEL 100" \"this message should print into MyLogger\"++ \-\- The best practice is putting all config into a separate file,+ \-\- e.g "Logging.json"+ manager = [aesonQQ|{+ \"loggers\": {+ \"root\": {+ \"level\": \"DEBUG\",+ \"handlers\": [\"console\"],+ \"propagate\": false+ },+ \"MyLogger\": {+ \"level\": \"INFO\",+ \"filterer\": [\"MyLogger.Main\"],+ \"handlers\": [\"file\"],+ \"propagate\": false+ }+ },+ \"handlers\": {+ \"console\": {+ \"type\": \"StreamHandler\",+ \"stream\": \"stderr\",+ \"level\": \"DEBUG\",+ \"formatter\": \"defaultFormatter\"+ },+ \"file\": {+ \"type\": \"FileHandler\",+ \"level\": \"INFO\",+ \"formatter\": \"defaultFormatter\",+ \"file\": \"./default.log\"+ }+ },+ \"formatters\": {+ \"defaultFormatter\": {+ \"fmt\": \"%(asctime)s - %(level)s - %(logger)s - %(pathname)s/%(filename)s:%(lineno)d] %(message)s\"+ }+ }+ }|]+@+-}+module Logging+ ( module Logging.Internal+ -- ** Logging THs+ , module Logging.TH+ -- ** Types+ , module Logging.Types+ ) where++import Logging.Internal hiding (log)+import Logging.TH+import Logging.Types hiding (Filterable (..), Formattable (..))
+ src/Logging/Internal.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Logging.Internal+ ( run+ , runJson+ , jsonToManager+ , log+ , stderrHandler+ , stdoutHandler+ , defaultRoot+ ) where++import Control.Concurrent.MVar (MVar, newMVar)+import Control.Exception (SomeException, bracket_)+import Control.Monad (forM_, sequence, void, when)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Aeson (Value (..))+import Data.Default+import qualified Data.HashMap.Strict as HM+import Data.IORef+import Data.List (dropWhileEnd)+import Data.Map.Lazy (Map, delete, fromList, (!?))+import qualified Data.Text as T+import Data.Time.Clock+import Data.Time.LocalTime+import GHC.Conc (setUncaughtExceptionHandler)+import Prelude hiding (filter, log)+import System.Directory (createDirectoryIfMissing,+ makeAbsolute)+import System.FilePath+import System.IO (Handle, IOMode (..), hSetEncoding,+ openFile, stderr, stdout, utf8)+import System.IO.Unsafe (unsafePerformIO)++import Data.Aeson.Extra+import Logging.Types++{-# NOINLINE _mgr #-}+_mgr :: IORef Manager+_mgr = unsafePerformIO $ newIORef undefined+++-- |Run a logging environment.+--+-- You should always write you application inside a logging environment.+--+-- 1. rename "main" function to "originMain" (or whatever you call it)+-- 2. write "main" as below+--+-- > main :: IO ()+-- > main = run manager originMain+-- > ...+--+run :: Manager -> IO a -> IO a+run mgr@Manager{..} io = do+ when catchUncaughtException $ setUncaughtExceptionHandler uceHandler+ bracket_ (atomicWriteIORef _mgr mgr) 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++ closeHandlers :: Sink -> IO ()+ closeHandlers Sink{..} = forM_ handlers $ \(HandlerT hdl) -> close hdl+++-- |Run a logging environment from JSON 'Value'.+--+-- A combinator of 'run' and 'jsonToManager'.+--+runJson :: Value -> IO a -> IO a+runJson val io = jsonToManager val >>= (`run` io)++-- | Parse JSON to Formatter+jsonToFormatter :: Value -> Formatter+jsonToFormatter (Object obj) =+ Formatter (lookupString fmt "fmt" obj) (lookupString datefmt "datefmt" obj)+ where+ Formatter{..} = def+jsonToFormatter (String fmt) = def {fmt = T.unpack fmt}+jsonToFormatter _ = def+++-- | Parse JSON to Filter+jsonToFilter :: Value -> Filter+jsonToFilter (String s) = let s' = T.unpack s in Filter s' (length s')+jsonToFilter _ = error "Logging.Internal: no parse (Filter)"+++-- | Parse JSON to Handler(T)+jsonToHandler :: Value -> (String -> Formatter) -> IO HandlerT+jsonToHandler (Object obj) lookupFmt = jsonToHandler' type_+ where+ type_ = lookupString "" "type" obj+ level = read $ lookupString "NOTSET" "level" obj+ filterer = map jsonToFilter $ lookupArray "filterer" obj+ formatter = lookupFmt $ lookupString "" "formatter" obj++ lock :: IO (MVar ())+ lock = newMVar ()++ nameToStream :: String -> Handle+ nameToStream "stderr" = stderr+ nameToStream "stdout" = stdout+ nameToStream _ = error "Logging.Internal: no parse (stream)"++ jsonToHandler' :: String -> IO HandlerT+ jsonToHandler' "StreamHandler" = do+ let stream = nameToStream $ lookupString "stderr" "stream" obj+ (HandlerT . (StreamHandler stream level filterer formatter)) <$> lock+ jsonToHandler' "FileHandler" = do+ file <- makeAbsolute $ lookupString "default.log" "file" obj+ createDirectoryIfMissing True $ takeDirectory file+ stream <- openFile file AppendMode+ hSetEncoding stream utf8+ (HandlerT . (StreamHandler stream level filterer formatter)) <$> lock+ jsonToHandler' _ = error $ "Logging.Internal: no parse (Handler)"+jsonToHandler _ _ = undefined+++-- | Parse JSON to Sink+jsonToSink :: (String, Value) -> (String -> HandlerT) -> Sink+jsonToSink (logger, Object obj) lookupHdl =+ Sink logger' level filterer handlers disabled propagate+ where+ logger' = if logger == "root" then "" else logger+ level = read $ lookupString "NOTSET" "level" obj+ filterer = map jsonToFilter $ lookupArray "filterer" obj+ handlers = [lookupHdl (T.unpack v) | (String v) <- lookupArray "handlers" obj]+ disabled = lookupBool False "disabled" obj+ propagate = lookupBool False "propagate" obj+jsonToSink _ _ = error "Logging.Internal: no parse (Logger)"+++-- |Make a 'Manager' from JSON 'Value'.+jsonToManager :: Value -> IO Manager+jsonToManager (Object obj) = do+ let formatters = HM.map jsonToFormatter $ lookupObject "formatters" obj+ lookupFmt k = HM.lookupDefault def k formatters+ handlerNames = lookupObject "handlers" obj++ handlers <- sequence $ HM.map (`jsonToHandler` lookupFmt) handlerNames++ let lookupHdl = (HM.!) handlers+ sinkVals = lookupObject "loggers" obj+ sinks = HM.mapWithKey (curry (`jsonToSink` lookupHdl)) sinkVals++ root = HM.lookupDefault defaultRoot "root" sinks+ sinks' = delete "root" $ fromList $ HM.toList sinks+ disabled = lookupBool False "disabled" obj+ catchUncaughtException = lookupBool False "catchUncaughtException" obj++ return $ Manager root sinks' disabled catchUncaughtException+jsonToManager _ = error "Logging.Internal: no parse (Manager)"+++-- |Low-level logging routine which creates a LogRecord and then calls+-- all the handlers of this logger to handle the record.+log :: MonadIO m+ => Logger -> Level -> String -> (String, String, String, Int) -> m ()+log logger level message location = liftIO $ do+ mgr@Manager{..} <- readIORef _mgr+ created <- getZonedTime++ let (file, package, modulename, lineno) = location++ when (not disabled) $ process logger mgr $+ LogRecord logger level message file package modulename lineno created+ where+ process :: Logger -> Manager -> LogRecord -> IO ()+ process logger mgr rcd =+ case lookupSink logger mgr of+ Just sink@Sink{..} -> do+ when (isSinkEnabledFor sink rcd) $ callHandlers handlers rcd+ let parentLogger = parent logger+ shouldPropagate = propagate && logger /= parentLogger+ when shouldPropagate $ process parentLogger mgr rcd+ Nothing -> process (parent logger) mgr rcd++ parent :: Logger -> Logger+ parent = dropWhileEnd (== '.') . dropWhileEnd (/= '.')++ lookupSink :: Logger -> Manager -> Maybe Sink+ lookupSink logger mgr@Manager{root=root@Sink{logger=rootLogger}, ..}+ | logger `elem` ["", rootLogger] = Just root+ | otherwise = sinks !? logger++ callHandlers :: [HandlerT] -> LogRecord -> IO ()+ callHandlers handlers rcd = forM_ handlers $ \hdlt@(HandlerT hdl) ->+ when (isHandlerEnableFor hdlt rcd) $ void $ 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++ isHandlerEnableFor :: HandlerT -> LogRecord -> Bool+ isHandlerEnableFor (HandlerT hdl) rcd@LogRecord{level=level'}+ | level' < getLevel hdl = False+ | otherwise = filter (getFilterer 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++{-# NOINLINE stdoutHandler #-}+-- |A 'StreamHandler' bound to 'stdout'+stdoutHandler :: StreamHandler+stdoutHandler = unsafePerformIO $ makeStreamHandler stdout++{-# NOINLINE defaultRoot #-}+-- |Default root sink which is used by 'jsonToManager' when __root__ is missed.+--+-- You can use it when you make 'Manager' manually.+defaultRoot :: Sink+defaultRoot = Sink "" "DEBUG" [] [HandlerT stderrHandler] False False
+ src/Logging/TH.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Logging.TH+ ( logv+ , debug+ , info+ , warn+ , error+ , fatal+ ) where++import Language.Haskell.TH++import Logging.Internal+import Logging.Types++import Prelude hiding (error, log)++-- | Log "message" with the severity "level".+--+-- The missing type signature: 'MonadIO' m => 'Logger' -> 'Level' -> 'String' -> m ()+logv :: ExpQ+logv = do+ loc <- location+ let filename = loc_filename loc+ packagename = loc_package loc+ modulename = loc_module loc+ lineno = fst $ loc_start loc+ location = (filename, packagename, modulename, lineno)+ [| \logger level msg -> log logger level msg location |]++-- | Log "message" with a specific severity.+--+-- The missing type signature: 'MonadIO' m => 'Logger' -> 'String' -> m ()+debug, info, warn, error, fatal :: ExpQ+debug = [| \logger -> $(logv) logger $ read "DEBUG" |]+info = [| \logger -> $(logv) logger $ read "INFO" |]+warn = [| \logger -> $(logv) logger $ read "WARN" |]+error = [| \logger -> $(logv) logger $ read "ERROR" |]+fatal = [| \logger -> $(logv) logger $ read "FATAL" |]
+ src/Logging/Types.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++module Logging.Types+ ( Logger(..)+ , Level(..)+ , LogRecord(..)+ , Filter(..)+ , Filterer+ , Formatter(..)+ , StreamHandler(..)+ , HandlerT(..)+ , Sink(..)+ , Manager(..)+ , Filterable(..)+ , Formattable(..)+ , Handler(..)+ ) where++import Control.Concurrent.MVar (MVar, putMVar, takeMVar)+import Control.Exception (bracket)+import Control.Monad (unless, when)+import Data.Default+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 Language.Haskell.TH.Syntax (Lift)+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'.+newtype Level = Level Int deriving (Lift, 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.+data Filter = Filter { name :: String+ , nlen :: Int+ }++instance IsString Filter where+ fromString s = Filter s $ length s++instance Eq Filter where+ (==) f s = (==) (name f) (name s)+++-- |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+ } deriving (Eq)++instance Default Formatter where+ def = Formatter "%(message)s" "%Y-%m-%dT%H:%M:%S%6Q%z"+++-- | 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'.+--+data StreamHandler = StreamHandler { stream :: Handle+ , level :: Level+ , filterer :: Filterer+ , formatter :: Formatter+ , lock :: MVar ()+ }+++-- |A GADT represents any 'Handler' instance+data HandlerT where+ HandlerT :: Handler a => a -> HandlerT+++-- |'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 :: [HandlerT]+ , disabled :: Bool+ , propagate :: Bool+ }+++-- |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 f rcd@LogRecord{..}+ | (nlen f) == 0 = True+ | otherwise = case stripPrefix (name f) logger of+ Just "" -> True -- filter name == record logger+ Just ('.':_) -> True -- filter name is record logger's child+ _ -> 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 Handler a where+ getLevel :: a -> Level+ setLevel :: a -> Level -> a++ getFilterer :: a -> Filterer+ setFilterer :: a -> Filterer -> a++ getFormatter :: a -> Formatter+ setFormatter :: a -> Formatter -> a++ acquire :: a -> IO ()+ release :: a -> IO ()++ with :: a -> (a -> IO b) -> IO b+ with l io = bracket (acquire l) (\_ -> release l) (\_ -> io l)++ emit :: a -> LogRecord -> IO ()+ flush :: a -> IO ()+ close :: a -> IO ()++ handle :: a -> LogRecord -> IO Bool+ handle hdl rcd = do+ let rv = filter (getFilterer hdl) rcd+ when rv $ with hdl (`emit` rcd)+ return rv++instance Handler StreamHandler where+ getLevel = level+ setLevel h v = h { level = v }++ getFilterer = filterer+ setFilterer h f = h { filterer = f }++ getFormatter = formatter+ setFormatter h f = h { formatter = f }++ acquire = takeMVar . lock+ release = (`putMVar` ()) . lock++ emit hdl rcd = do+ hPutStrLn (stream hdl) $ format (getFormatter hdl) rcd+ flush hdl++ flush = hFlush . stream+ close StreamHandler{..} = do+ isClosed <- hIsClosed stream+ unless isClosed $ hIsTerminalDevice stream >>= (`unless` (hClose stream))
+ test/Spec.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++import Control.Concurrent.MVar+import Control.Monad+import Data.Aeson.QQ.Simple (aesonQQ)+import Data.Default (def)+import Data.List (intercalate, lines)+import qualified Data.Map as M+import Data.String (fromString)+import Data.Time.LocalTime (ZonedTime)+import System.FilePath+import System.IO+import System.Process (createPipe)+import Test.Hspec+import Test.Hspec.Core.QuickCheck (modifyMaxSize)+import Test.QuickCheck+import qualified Test.QuickCheck.Monadic as QC++import Logging++main :: IO ()+main = hspec $ do+ describe "Level" $+ modifyMaxSize (const 1000) $ do+ it "read is reverse to show" $+ property $ \x -> (read . show) (Level x) == (Level x)+ it "overload string is equivalent to read" $+ property $ \x -> fromString (show (Level x)) == (Level x)++ describe "Formatter" $ do+ modifyMaxSize (const 1000) $ do+ it "format \"%(logger)s\" to LogRecord's logger record" $+ testFormatter (def {fmt = "%(logger)s"}) $ \LogRecord{..} -> logger+ it "format \"%(level)s\" to LogRecord's level record" $+ testFormatter (def {fmt = "%(level)s"}) $ \LogRecord{..} -> show level+ it "format \"%(message)s\" to LogRecord's message record" $+ testFormatter (def {fmt = "%(message)s"}) message+ it "format \"%(pathname)s\" to LogRecord's filename record's directory" $+ testFormatter (def {fmt = "%(pathname)s"}) $+ \LogRecord{..} -> takeDirectory filename+ it "format \"%(filename)s\" to LogRecord's filename record's base filename" $+ testFormatter (def {fmt = "%(filename)s"}) $+ \LogRecord{..} -> takeFileName filename+ it "format \"%(module)s\" to LogRecord's modulename record" $+ testFormatter (def {fmt = "%(module)s"}) modulename++ it "format \"%(lineno)d\" to LogRecord's lineno record" $+ testFormatter (def {fmt = "%(lineno)d"}) (show . lineno)++ it "format \"%(created)f\" to LogRecord's create time (second timestamp)" $+ testFormatter (def {fmt = "%(created)f"}) (const (show (1 :: Double)))++ it "format \"%(asctime)f\" to LogRecord's create time (human readdable)" $+ testFormatter+ (def {fmt = "%(asctime)s", datefmt="%Y-%m-%dT%H:%M:%S"})+ (const "1970-01-01T00:00:01")++ it "format \"%(msecs)d\" to LogRecord's create time (millisecond timestamp)" $+ testFormatter (def {fmt = "%(msecs)d"}) (const "1000" )++ describe "Manager" $+ modifyMaxSize (const 1000) $ do+ it "parse json to Manager" testJsonToManager+ it "run logging environment && logging THs" testRunLogging+++makeRecord :: (Logger, Int, String, FilePath, String, String, Int) -> LogRecord+makeRecord (logger, level, message, file, package, modulename, line) =+ LogRecord { logger = replaceLine logger+ , level = Level level+ , message = replaceLine message+ , filename = replaceLine file+ , packagename = replaceLine package+ , modulename = replaceLine modulename+ , lineno = line+ , created = created+ }+ where+ created :: ZonedTime+ created = read "1970-01-01 00:00:01"+ -- replace '\n' with "<newline>" flag, or it will affect test,+ -- it works fine in normal situation.+ replaceLine :: String -> String+ replaceLine = intercalate "<newline>" . lines++++testFormatter :: Formatter -> (LogRecord -> String) -> Property+testFormatter formatter format = property $ \x -> QC.monadicIO $ do+ (readEnd, writeEnd) <- QC.run $ createPipe+ QC.run $ hSetEncoding writeEnd utf8+ QC.run $ hSetEncoding readEnd utf8+ let rcd = makeRecord x+ handler = stderrHandler {formatter = formatter, stream = writeEnd }+ QC.run $ handle handler rcd+ msg <- QC.run $ hGetLine readEnd+ QC.assert (msg == format rcd)++testJsonToManager :: IO ()+testJsonToManager = do+ mgr@Manager{..} <- jsonToManager managerJson+ -- root+ testSink "root" root+ -- sinks+ length sinks `shouldBe` 1+ M.member "MyLogger" sinks `shouldBe` True+ testSink "MyLogger" $ sinks M.! "MyLogger"+ where+ testSink :: Logger -> Sink -> IO ()+ testSink "root" Sink{..} = do+ logger `shouldBe` ""+ level `shouldBe` "DEBUG"+ propagate `shouldBe` False+ disabled `shouldBe` False+ length filterer `shouldBe` 0+ length handlers `shouldBe` 1+ void $ forM_ handlers testHandler+ testSink "MyLogger" Sink{..} = do+ logger `shouldBe` "MyLogger"+ level `shouldBe` "INFO"+ propagate `shouldBe` False+ disabled `shouldBe` False+ length filterer `shouldBe` 1+ filterer == [Filter "MyLogger.Main" 13] `shouldBe` True+ length handlers `shouldBe` 2+ void $ forM_ handlers testHandler++ testHandler :: HandlerT -> IO ()+ testHandler (HandlerT hdl) = do+ let fmt = "%(asctime)s - %(level)s - %(logger)s - %(pathname)s/%(filename)s:%(lineno)d] %(message)s"+ getFilterer hdl == [] `shouldBe` True+ getFormatter hdl == def {fmt = fmt} `shouldBe` True+ getLevel hdl `elem` ["DEBUG", "INFO"] `shouldBe` True++ managerJson = [aesonQQ|{+ "loggers": {+ "root": {+ "level": "DEBUG",+ "handlers": ["console"],+ "propagate": false+ },+ "MyLogger": {+ "level": "INFO",+ "filterer": ["MyLogger.Main"],+ "handlers": ["console", "file"],+ "propagate": false+ }+ },+ "handlers": {+ "console": {+ "type": "StreamHandler",+ "stream": "stderr",+ "level": "DEBUG",+ "formatter": "defaultFormatter"+ },+ "file": {+ "type": "FileHandler",+ "level": "INFO",+ "formatter": "defaultFormatter",+ "file": "./default.log"+ }+ },+ "formatters": {+ "defaultFormatter": {+ "fmt": "%(asctime)s - %(level)s - %(logger)s - %(pathname)s/%(filename)s:%(lineno)d] %(message)s"+ }+ }+ }|]+++testRunLogging :: IO ()+testRunLogging = do+ (mgr, consoleReadEnd, fileReadEnd) <- prepare+ let msg = "this is a test msg"+ run mgr $ do+ -- root+ forM ["debug", "info", "warn", "error", "fatal"] $ \logx -> do+ runLog logx "" msg [(consoleReadEnd, msg), (fileReadEnd, "")]++ -- MyLogger (filter)+ forM ["debug", "info", "warn", "error", "fatal"] $ \logx -> do+ runLog logx "MyLogger" msg [(consoleReadEnd, ""), (fileReadEnd, "")]++ -- debug MyLogger.Main+ runLog "debug" "MyLogger.Main" msg [(consoleReadEnd, ""), (fileReadEnd, "") ]+ -- the rest logs of MyLogger.Main+ forM ["info", "warn", "error", "fatal"] $ \logx -> do+ runLog logx "MyLogger.Main" msg [(consoleReadEnd, msg), (fileReadEnd, msg)]++ return ()+ where+ prepare :: IO (Manager, Handle, Handle)+ prepare = do+ (consoleReadEnd, consoleWriteEnd) <- createPipe+ hSetEncoding consoleReadEnd utf8+ hSetEncoding consoleWriteEnd utf8++ (fileReadEnd, fileWriteEnd) <- createPipe+ hSetEncoding fileReadEnd utf8+ hSetEncoding fileWriteEnd utf8++ console <- StreamHandler consoleWriteEnd "DEBUG" [] def <$> newMVar ()+ file <- StreamHandler fileWriteEnd "INFO" [] def <$> newMVar ()++ let root = Sink "" "DEBUG" [] [HandlerT console] False False+ myLogger = Sink "MyLogger" "INFO" ["MyLogger.Main"] [HandlerT console, HandlerT file] False False+ sinks = M.fromList [("MyLogger", myLogger)]+ return (Manager root sinks False True, consoleReadEnd, fileReadEnd)++ runLog :: String -> String -> String -> [(Handle, String)] -> IO ()+ runLog logx logger msg asserts = do+ case logx of+ "debug" -> $(debug) logger msg+ "info" -> $(info) logger msg+ "warn" -> $(warn) logger msg+ "error" -> $(Logging.error) logger msg+ "fatal" -> $(fatal) logger msg+ _ -> expectationFailure "unknown log function"++ void $ forM_ asserts $ \(handle, value) -> do+ ready <- hReady handle -- pipe read end will wait until write end has been written+ real <- if ready then hGetLine handle else return ""+ real `shouldBe` value