InternalSpec.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}

module LoggingTest.InternalSpec ( 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