log4hs-0.0.3.0: test/Spec.hs
{-# 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 "<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 = (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