diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for logging + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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" + } + } +}|] +``` + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/log4hs.cabal b/log4hs.cabal new file mode 100644 --- /dev/null +++ b/log4hs.cabal @@ -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 +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 diff --git a/src/Data/Aeson/Extra.hs b/src/Data/Aeson/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extra.hs @@ -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 diff --git a/src/Logging.hs b/src/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Logging.hs @@ -0,0 +1,88 @@ +{-| +Module : Logging +Copyright : (c) 2019 Version Cloud +License : BSD3 +Maintainer : Jorah Gao +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 (..)) diff --git a/src/Logging/Internal.hs b/src/Logging/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Internal.hs @@ -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 diff --git a/src/Logging/TH.hs b/src/Logging/TH.hs new file mode 100644 --- /dev/null +++ b/src/Logging/TH.hs @@ -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" |] diff --git a/src/Logging/Types.hs b/src/Logging/Types.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Types.hs @@ -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)) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 "" flag, or it will affect test, + -- it works fine in normal situation. + replaceLine :: String -> String + replaceLine = intercalate "" . 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