log4hs-0.0.5.0: test/LoggingSpec.hs

{-# 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]