{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module LoggingTest.GlobalSpec ( spec ) where 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 import Test.QuickCheck.Monadic import Text.Format import Logging hiding (run) import Logging.TH import LoggingTest.Prelude spec :: Spec spec = describe "run & log" $ do let levels = ["DEBUG", "INFO", "WARN", "ERROR", "FATAL"] loggers = [ ("root", "DEBUG", [], ["DEBUG"], False, False) , ("Disabled", "DEBUG", [], ["DEBUG"], True, False) , ("Debug", "DEBUG", [], ["DEBUG", "INFO"], False, False) , ("Info", "INFO", ["Info.A"], ["DEBUG", "INFO"], False, False) , ("Warn", "WARN", [], ["WARN"], False, False) , ("Warn.Error", "ERROR", [], ["ERROR"], False, False) , ("Error", "ERROR", [], ["ERROR"], False, True) , ("Error.Fatal", "FATAL", [], ["FATAL"], False, True) ] handlers <- fmap M.fromList $ runIO $ forM levels $ \level -> do (read, write) <- createPipe hSetEncoding read utf8 >> hSetEncoding write utf8 let handler = toHandler $ StreamHandler level [] "{message}" write return $ (level, (handler, read)) sinks <- fmap M.fromList $ runIO $ forM loggers $ \item -> do let (logger, level, fs, hs, disabled, propagate) = item logger' = if logger == "root" then "" else logger hs' = [fst (handlers M.! h) | h <- hs] sink = Sink logger' level fs hs' disabled propagate return (logger, sink) let root = sinks M.! "root" sinks' = M.delete "root" sinks disabledManager = Manager root sinks' True False manager = Manager root sinks' False False prop "filter" $ \(MessageString message) -> monadicIO $ do -- manager disabled run $ runLog disabledManager $ $(info) "Debug" message msgs <- run $ forM ["DEBUG", "INFO"] $ \level -> hTryGetLine $ snd $ handlers M.! level assert $ ["", ""] == msgs -- sink disabled run $ runLog manager $ $(debug) "Disabled" message msg1 <- run $ hTryGetLine $ snd $ handlers M.! "DEBUG" assert $ msg1 == "" -- sink level reject run $ runLog manager $ $(debug) "Info.A" message msgs1 <- run $ forM ["DEBUG", "INFO"] $ \level -> hTryGetLine $ snd $ handlers M.! level assert $ ["", ""] == msgs1 -- sink filterer reject run $ runLog manager $ $(info) "Info.B" message msgs2 <- run $ forM ["DEBUG", "INFO"] $ \level -> hTryGetLine $ snd $ handlers M.! level assert $ ["", ""] == msgs2 -- pass 1 run $ runLog manager $ $(info) "Debug" message msgs3 <- run $ forM ["DEBUG", "INFO"] $ \level -> hTryGetLine $ snd $ handlers M.! level assert $ [message, message] == msgs3 -- pass 2 run $ runLog manager $ $(info) "Info.A" message msgs4 <- run $ forM ["DEBUG", "INFO"] $ \level -> hTryGetLine $ snd $ handlers M.! level assert $ [message, message] == msgs4 prop "propagate" $ \(MessageString message) -> monadicIO $ do -- propagation disabled 1 run $ runLog manager $ $(warn) "Warn" message msgs <- run $ forM ["DEBUG", "WARN"] $ \level -> hTryGetLine $ snd $ handlers M.! level assert $ ["", message] == msgs -- propagation disabled 2 run $ runLog manager $ $(error) "Warn.Error" message msgs1 <- run $ forM ["DEBUG", "WARN", "ERROR"] $ \level -> hTryGetLine $ snd $ handlers M.! level assert $ ["", "", message] == msgs1 -- propagation enabled 1 run $ runLog manager $ $(error) "Error" message msgs2 <- run $ forM ["DEBUG", "ERROR"] $ \level -> hTryGetLine $ snd $ handlers M.! level assert $ [message, message] == msgs2 -- propagation enabled 2 run $ runLog manager $ $(fatal) "Error.Fatal" message msgs3 <- run $ forM ["DEBUG", "ERROR", "FATAL"] $ \level -> hTryGetLine $ snd $ handlers M.! level assert $ [message, message, message] == msgs3