diff --git a/log4hs.cabal b/log4hs.cabal --- a/log4hs.cabal +++ b/log4hs.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 39b8ec0bbe2bdbabb40d4ad5b19d1a0ea0755ec5fe019af3de5f56f1f2b55c1f +-- hash: 6da912ef94ad42318d7758fcdd3d5893c0f3d6c4863cc543e25dd6f91ba71bb2 name: log4hs -version: 0.0.4.0 +version: 0.0.5.0 synopsis: A python logging style log library description: Please see the http://hackage.haskell.org/package/log4hs category: logging @@ -48,6 +48,9 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Logging.AesonSpec + Logging.TypesSpec + LoggingSpec Paths_log4hs hs-source-dirs: test diff --git a/src/Logging.hs b/src/Logging.hs --- a/src/Logging.hs +++ b/src/Logging.hs @@ -2,7 +2,7 @@ Module : Logging Copyright : (c) 2019 Version Cloud License : BSD3 -Maintainer : Jorah Gao +Maintainer : Jorah Gao Stability : experimental Portability : portable @@ -37,20 +37,19 @@ @ -__See 'Logging.Aeson' to lean more about decoding json into 'Manager'__ +__See "Logging.Aeson" to lean more about decoding json into 'Manager'__ -} module Logging ( module Logging.Aeson + , module Logging.Types , module Logging.Deprecated , module Logging.Internal -- ** Logging THs , module Logging.TH - -- ** Types - , module Logging.Types ) where import Logging.Aeson import Logging.Deprecated import Logging.Internal hiding (log) import Logging.TH -import Logging.Types hiding (Filterable (..), Formattable (..)) +import Logging.Types diff --git a/src/Logging/Aeson.hs b/src/Logging/Aeson.hs --- a/src/Logging/Aeson.hs +++ b/src/Logging/Aeson.hs @@ -43,7 +43,9 @@ { \"loggers\": {\"root\": {}, \"MyLogger\": {}}, \"handlers\": {\"console\": {}, \"file\": {}}, - \"formatters\": {\"default\": {}, \"simple\": {}} + \"formatters\": {\"default\": {}, \"simple\": {}}, + \"disabled\": false, + \"catchUncaughtException\": true, } @ @@ -94,6 +96,33 @@ \"level\": \"INFO\", \"filterer\": [], \"formatter\": \"simple\", + } +@ + +__Examples of 'Logger' ('Sink') json__ + +@ + -- a standard format + { + \"level\": \"DEBUG\", + \"filterer\": [\"Package.Module.Submodule\"], + \"handlers\": [\"console\"], + \"propagate\": true, + \"disabled\": false + } + + -- this example is equivalent to the first + { + \"level\": \"DEBUG\", + \"filterer\": [\"Package.Module.Submodule\"], + \"handlers\": ["console"] + } + + -- another example + { + \"level\": \"INFO\", + \"handlers\": [\"console\", \"file\"], + \"propagate\": false } @ -} diff --git a/src/Logging/Types.hs b/src/Logging/Types.hs --- a/src/Logging/Types.hs +++ b/src/Logging/Types.hs @@ -43,6 +43,21 @@ -- |'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 (Lift, Eq, Ord) instance Show Level where @@ -148,7 +163,7 @@ -- [@%(message)s@] The main message passed to 'logv' 'debug' 'info' .. -- data Formatter = Formatter { fmt :: String - , datefmt :: String + , datefmt :: String -- ^ see "Data.Time.Format" } deriving (Eq) instance Default Formatter where @@ -196,7 +211,8 @@ , filterer :: Filterer , handlers :: [HandlerT] , disabled :: Bool - , propagate :: Bool + , propagate :: Bool -- ^ It will pop up until root or the + -- ancestor's propagation is disabled } diff --git a/test/Logging/AesonSpec.hs b/test/Logging/AesonSpec.hs new file mode 100644 --- /dev/null +++ b/test/Logging/AesonSpec.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Logging.AesonSpec ( spec ) where + +import Control.Monad +import Data.Aeson +import Data.Aeson.QQ.Simple (aesonQQ) +import Data.Default (def) +import Data.List (intercalate) +import qualified Data.Map as M +import Data.Maybe (fromJust) +import System.IO +import System.IO.Unsafe +import Test.Hspec +import Test.Hspec.QuickCheck + +import Logging +import Logging.Aeson + +spec :: Spec +spec = levelSpec >> filterSpec >> formatterSpec >> handlerSpec >> + sinkSpec >> managerSpec + + +levelSpec :: Spec +levelSpec = describe "Level" $ modifyMaxSize (const 1000) $ do + prop "decode" $ \x -> let v = Level x in (decode $ encode $ show v) == Just v + + +filterSpec :: Spec +filterSpec = describe "Filter" $ modifyMaxSize (const 1000) $ do + prop "decode" $ \fs -> + let name = intercalate "." fs + in (decode $ encode name) == Just (Filter name $ length name) + + +formatterSpec :: Spec +formatterSpec = describe "Formatter" $ modifyMaxSize (const 1000) $ do + prop "decode standard" $ \(fmt, datefmt) -> + let formatter = Formatter fmt datefmt + obj = object [("fmt", toJSON fmt), ("datefmt", toJSON datefmt)] + in (decode $ encode obj) == Just formatter + + prop "decode missing filed" $ \fmt -> + decode (encode $ object [("fmt", toJSON fmt)]) == Just (def {fmt = fmt}) + + prop "decode string" $ \fmt -> decode (encode fmt) == Just (def {fmt = fmt}) + + +handlerSpec :: Spec +handlerSpec = describe "Handler" $ modifyMaxSize (const 1000) $ do + it "decode StreamHandler simple" $ do + 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" + } + |] + + stream == stdout `shouldBe` True + level == "DEBUG" `shouldBe` True + filterer == [Filter "Module.Submodule" 16] `shouldBe` True + formatter == def {fmt = "default"} `shouldBe` True + + it "decode (formatters -> HandlerT)" $ do + let simple = def {fmt = "%(logger)s: %(message)s"} + func = fromJust $ decode $ encode + [aesonQQ| + { + "type": "StreamHandler", + "level": "DEBUG", + "filterer": ["Module.Submodule"], + "formatter": "simple" + } + |] + + (HandlerT handler) <- func $ M.singleton ("simple" :: String) simple + getLevel handler == "DEBUG" `shouldBe` True + getFilterer handler == [Filter "Module.Submodule" 16] `shouldBe` True + getFormatter handler == simple `shouldBe` True + + +sinkSpec :: Spec +sinkSpec = describe "Sink" $ modifyMaxSize (const 1000) $ do + it "decode" $ do + let Sink{..} = fromJust $ decode $ encode $ + [aesonQQ| + { + "level": "DEBUG", + "filterer": ["Module.Submodule"], + "handlers": ["console"], + "disabled": false, + "propagate": true + } + |] + + logger `shouldBe` "placeholder" + level `shouldBe` "DEBUG" + filterer == [Filter "Module.Submodule" 16] `shouldBe` True + length handlers `shouldBe` 0 + disabled `shouldBe` False + propagate `shouldBe` True + + it "decode (logger -> handlers -> sink)" $ do + let handlerMap = M.fromList [ ("console", HandlerT stderrHandler) + , ("file" :: String, HandlerT stderrHandler) + ] + func = fromJust $ decode $ encode $ + [aesonQQ| + { + "level": "INFO", + "filterer": ["Module.Submodule"], + "handlers": ["console", "file"] + } + |] + Sink{..} = func ("MyLogger" :: String) handlerMap + + logger `shouldBe` "MyLogger" + level `shouldBe` "INFO" + filterer == [Filter "Module.Submodule" 16] `shouldBe` True + length handlers `shouldBe` 2 -- deep test handlers + disabled `shouldBe` False + propagate `shouldBe` False + + +managerSpec :: Spec +managerSpec = describe "Manager" $ modifyMaxSize (const 1000) $ do + it "decode" $ do + let Manager{..} = manager_ + + length sinks `shouldBe` 1 + M.member "MyLogger" sinks `shouldBe` True + disabled `shouldBe` False + catchUncaughtException `shouldBe` True + + it "decode root" $ do + let Sink{..} = root manager_ + + logger `shouldBe` "" + level `shouldBe` "DEBUG" + disabled `shouldBe` False + propagate `shouldBe` False + length filterer `shouldBe` 0 + length handlers `shouldBe` 1 + + it "decode sinks" $ do + let Sink{..} = (sinks manager_) M.! "MyLogger" + + 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 + + +-- Decoding manager globally, or it will throw file resouse busy error +manager_ :: Manager +{-# NOINLINE manager_ #-} +manager_ = unsafePerformIO $ fromJust $ decode $ encode [aesonQQ|{ + "catchUncaughtException": true, + "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": "default" + }, + "file": { + "type": "FileHandler", + "level": "INFO", + "formatter": "default", + "file": "./default.log" + } + }, + "formatters": { + "default": { + "fmt": "%(asctime)s - %(level)s - %(logger)s:%(lineno)d] %(message)s" + } + } +}|] diff --git a/test/Logging/TypesSpec.hs b/test/Logging/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Logging/TypesSpec.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Logging.TypesSpec ( spec ) where + +import Data.Default +import Data.String (fromString) +import Data.Time.Clock +import Data.Time.Format as TF +import Data.Time.LocalTime +import System.FilePath +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Text.Printf + +import Logging.Types + +spec :: Spec +spec = levelSpec >> formatterSpec + + +levelSpec :: Spec +levelSpec = describe "Level" $ modifyMaxSize (const 1000) $ do + prop "read and show" $ \x -> (read . show) (Level x) == (Level x) + prop "overload string" $ \x -> fromString (show (Level x)) == (Level x) + + +formatterSpec :: Spec +formatterSpec = describe "Formatter" $ modifyMaxSize (const 1000) $ do + -- one field only + fmtProp "%(logger)s" "LogRecord's logger record" loggerFmt + fmtProp "%(level)s" "LogRecord's level record" levelFmt + fmtProp "%(message)s" "LogRecord's message record" message + fmtProp "%(pathname)s" "LogRecord's filename (dir) record" pathnameFmt + fmtProp "%(filename)s" "LogRecord's filename (no dir) record" filenameFmt + fmtProp "%(module)s" "LogRecord's modulename record" modulename + fmtProp "%(lineno)d" "LogRecord's lineno record" $ show . lineno + fmtProp "%(created)f" + "LogRecord's created (decimal second timestamp) record" + createdFmt + fmtProp "%(msecs)d" + "LogRecord's created (millisecond timestamp) record" + msecsFmt + dateProp "%(asctime)s" "%Y-%m-%dT%H:%M:%S" + "LogRecord's created (human friendly) record" + asctimeFmt + -- mixed fields + dateProp + "%(asctime)s - %(level)s - %(logger)s" "%Y-%m-%dT%H:%M:%S" + "LogRecord's created (human friendly) - level - logger records" + asctimeLevelLoggerFmt + fmtProp "%(pathname)s/%(filename)s" "LogRecord's filename (/ split) record" + pathnameFilenameFmt + fmtProp "%(lineno)d] %(message)s" "LogRecord's lineno] message records" + linenoMessageFmt + where + fmtProp :: String -> String -> (LogRecord -> String) + -> SpecWith (Arg Property) + fmtProp fmt desc manualFmt = prop (printf "format %s to %s" fmt desc) $ + \rcd -> format (def {fmt = fmt}) rcd == manualFmt rcd + + dateProp :: String -> String -> String -> (LogRecord -> String) + -> SpecWith (Arg Property) + dateProp fmt datefmt desc manualFmt = + prop (printf "format %s(%s) to %s" fmt datefmt desc) $ + \rcd -> format (Formatter fmt datefmt) rcd == manualFmt rcd + + loggerFmt = \LogRecord{..} -> logger + levelFmt = \LogRecord{..} -> show level + pathnameFmt = takeDirectory . filename + filenameFmt = takeFileName . filename + createdFmt = (printf "%f") . zt2timestamp . created + msecsFmt = show . zt2millisecs . created + asctimeFmt = TF.formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" . created + asctimeLevelLoggerFmt rcd = + asctimeFmt rcd ++ " - " ++ (levelFmt rcd) ++ " - " ++(loggerFmt rcd) + pathnameFilenameFmt rcd = pathnameFmt rcd ++ "/" ++ (filenameFmt rcd) + linenoMessageFmt rcd = (show $ lineno rcd) ++ "] " ++ (message rcd) + + +deriving instance Show LogRecord + + +instance Arbitrary LogRecord where + arbitrary = LogRecord + <$> arbitrary + <*> (Level <$> arbitrary) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> (((`addZonedTime` zeroTime) . toEnum) <$> arbitrary) + + +addZonedTime :: NominalDiffTime -> ZonedTime -> ZonedTime +addZonedTime ndt zt@(ZonedTime _ tz) = + utcToZonedTime tz $ addUTCTime ndt $ zonedTimeToUTC zt + +diffZonedTime :: ZonedTime -> ZonedTime -> NominalDiffTime +diffZonedTime zt1 zt2 = diffUTCTime (zonedTimeToUTC zt1) (zonedTimeToUTC zt2) + +zeroTime :: ZonedTime +zeroTime = read "1970-01-01 00:00:00" + +zt2timestamp :: ZonedTime -> Double +zt2timestamp zt = fromRational $ toRational $ diffZonedTime zt zeroTime + +zt2millisecs :: ZonedTime -> Integer +zt2millisecs zt = round $ zt2timestamp zt * 1000 diff --git a/test/LoggingSpec.hs b/test/LoggingSpec.hs new file mode 100644 --- /dev/null +++ b/test/LoggingSpec.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module LoggingSpec ( spec ) where + +import Control.Concurrent.MVar +import Control.Monad +import Data.Default (def) +import Data.List (intercalate) +import qualified Data.Map as M +import Data.Word +import Prelude hiding (error) +import System.IO +import System.IO.Unsafe (unsafePerformIO) +import System.Process (createPipe) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck hiding (run) +import qualified Test.QuickCheck.Monadic as Q + +import Logging + +spec :: Spec +spec = basicSpec >> formatSpec >> filterSpec >> propagateSpec + + +basicSpec :: Spec +basicSpec = describe "Basic" $ modifyMaxSize (const 1000) $ do + prop "log to root" $ \(PrintableString msg) -> + runLog "" "DEBUG" msg "debug" (== msg) + prop "log to Log4hs" $ \(PrintableString msg) -> + runLog "Log4hs" "INFO" msg "debug" (== msg) + prop "log to Log4hs.Json" $ \(PrintableString msg) -> + runLog "Log4hs.Json" "WARN" msg "debug" (== msg) + prop "disabled some" $ \(PrintableString msg) level -> + runLog "Log10000hs" level msg "debug" (== "") + prop "disabled all" $ \(PrintableString msg) loggers level -> + let logger = intercalate "." $ [getPrintableString x | x <- loggers] + in runDisabledLog logger level msg + + +formatSpec :: Spec +formatSpec = describe "Format" $ modifyMaxSize (const 1000) $ do + prop "simple" $ \(PrintableString msg) -> + runLog "" "DEBUG" msg "debug" (== msg) + prop "logger" $ \(PrintableString msg) (Log4hsLogger logger) -> do + runLog logger "WARN" msg "info" (== logger ++ ": " ++ msg) + prop "level" $ \(PrintableString msg) (Log4hsLogger logger) fmtlevel -> + let (Log4hsHighLevel level) = fmtlevel + out = logger ++ " " ++ (show level) ++ "] " ++ msg + in runLog logger level msg "error" (== out) + + +filterSpec :: Spec +filterSpec = describe "Filter" $ modifyMaxSize (const 1000) $ do + prop "root sink && debug handler" $ \(PrintableString msg) level -> + runLog "" level msg "debug" $ (== if level >= "DEBUG" then msg else "") + prop "Log4hs sink && info handler" $ \(PrintableString msg) level -> + let out = if level >= "INFO" then "Log4hs: " ++ msg else "" + in runLog "Log4hs" level msg "info" $ (== out) + prop "Log4hs.Json sink && error handler" $ \(PrintableString msg) level -> + let out = if level >= "ERROR" + then "Log4hs.Json " ++ (show level) ++ "] " ++ msg + else "" + in runLog "Log4hs.Json" level msg "error" $ (== out) + prop "handler's filterer" $ \(PrintableString msg) (Small v)-> + let logger = "Log4hs.V" ++ (show v) + out = if v == (3 :: Word8) then logger ++ ": " ++ msg else "" + in runLog logger "INFO" msg "infov3" (== out) + + +propagateSpec :: Spec +propagateSpec = describe "Propagate" $ modifyMaxSize (const 1000) $ do + prop "to root (real)" $ \(PrintableString msg) -> + runLog "Log8hs" "WARN" msg "debug" $ (== msg) + prop "to root (virtual)" $ \(PrintableString msg) -> + runLog "Log0hs" "WARN" msg "debug" $ (== msg) + prop "to parent (real)" $ \(PrintableString msg) -> + runLog "Log4hs.Json" "WARN" msg "info" $ (== "Log4hs.Json: " ++ msg) + prop "to parent (virtual)" $ \(PrintableString msg) -> + runLog "Log4hs.Ini" "WARN" msg "info" $ (== "Log4hs.Ini: " ++ msg) + prop "to grandparent (real)" $ \(PrintableString msg) -> + runLog "Log8hs.Json" "WARN" msg "debug" $ (== msg) + prop "to grandparent (virtual)" $ \(PrintableString msg) -> + runLog "Log0hs.Json" "WARN" msg "debug" $ (== msg) + prop "disabled" $ \(PrintableString msg) -> + runLog "Log4hs" "FATAL" msg "fatal" $ (== "") + + +runLog :: Logger -> Level -> String -> String -> (String -> Bool) -> Property +runLog logger level msg stream test = Q.monadicIO $ do + out <- Q.run $ createManager False >>= \(mgr, streams) -> run mgr $ + $(logv) logger level msg >> hTryGetLine (streams M.! stream) + Q.assert $ test out + + +runDisabledLog :: Logger -> Level -> String -> Property +runDisabledLog logger level msg = Q.monadicIO $ do + outs <- Q.run $ createManager True >>= \(mgr, streams) -> run mgr $ + $(logv) logger level msg >> sequence (M.map hTryGetLine streams) + Q.assert $ M.empty == M.filter (/= "") outs + + +createManager :: Bool -> IO (Manager, M.Map String Handle) +createManager disabled = do + debugPh <- createPipeHandler "DEBUG" [] (formatters M.! "simple") + infoPh <- createPipeHandler "INFO" [] (formatters M.! "logger") + infov3Ph <- createPipeHandler "INFO" ["Log4hs.V3"] (formatters M.! "logger") + errorPh <- createPipeHandler "ERROR" [] (formatters M.! "level") + fatalPh <- createPipeHandler "FATAL" [] (formatters M.! "logger") + + let root = Sink "" "DEBUG" [] [fst debugPh, fst fatalPh] False False + handlers = [fst debugPh, fst infoPh, fst infov3Ph, fst errorPh] + log4hs = Sink "Log4hs" "INFO" [] handlers False False + log4hsJson = Sink "Log4hs.Json" "WARN" [] [] False True + log4hsYaml = Sink "Log4hs.Yaml" "WARN" [] [] False True + log8hs = Sink "Log8hs" "INFO" [] [] False True + log8hsJson = Sink "Log8hs.Json" "INFO" [] [] False True + log10000hs = Sink "Log8hs.Json" "INFO" [] [fst debugPh] True False + sinks = M.fromList [ ("Log4hs", log4hs) + , ("Log4hs.Json", log4hsJson) + , ("Log4hs.Yaml", log4hsYaml) + , ("Log8hs", log8hs) + , ("Log8hs.Json", log8hsJson) + , ("Log10000hs", log10000hs) + ] + streams = M.fromList $ [ ("debug", snd debugPh) + , ("info", snd infoPh) + , ("infov3", snd infov3Ph) + , ("error", snd errorPh) + , ("fatal", snd fatalPh) + ] + return (Manager root sinks disabled False, streams) + + +formatters :: M.Map String Formatter +formatters = M.fromList + [ ("simple", def {fmt = "%(message)s"}) + , ("logger", def {fmt = "%(logger)s: %(message)s"}) + , ("level", def {fmt = "%(logger)s %(level)s] %(message)s"}) + ] + + +createPipeHandler :: Level -> Filterer -> Formatter -> IO (HandlerT, Handle) +createPipeHandler level filterer formatter = do + lock <- newMVar () + (read, write) <- createPipe + hSetEncoding read utf8 + hSetEncoding write utf8 + return $ ( HandlerT $ StreamHandler write level filterer formatter lock + , read + ) + + +hTryGetLine :: Handle -> IO String +hTryGetLine hdl = do + ready <- hReady hdl + if ready then hGetLine hdl else return "" + + +instance Arbitrary Level where + arbitrary = Level <$> arbitrary + + +newtype Log4hsLogger = Log4hsLogger Logger deriving Show + +instance Arbitrary Log4hsLogger where + arbitrary = elements $ + map Log4hsLogger ["Log4hs", "Log4hs.Json", "Log4hs.Yaml"] + + +newtype Log4hsHighLevel = Log4hsHighLevel Level deriving Show + +instance Arbitrary Log4hsHighLevel where + arbitrary = elements $ map Log4hsHighLevel ["ERROR", "FATAL", Level 100] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,230 +1,1 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} - -import Control.Concurrent.MVar -import Control.Monad -import Data.Aeson as A -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 -import Logging.Aeson - -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 = (sequence $ A.fromJSON managerJson) >>= \result -> - case result of - A.Error msg -> expectationFailure msg - A.Success mgr@Manager{..} -> do - -- 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 +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}