GlobalSpec.hs

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

{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE TypeApplications  #-}

module LoggingTest.GlobalSpec ( spec ) where

import           Control.Monad
import           Data.Generics.Product.Typed
import qualified Data.Map                            as M
import           Data.Time.LocalTime
import           Data.Word
import           Prelude                             hiding (error)

import           System.IO
import           System.Process                      (createPipe)
import           Test.Hspec
import           Test.Hspec.QuickCheck
import           Test.QuickCheck
import           Test.QuickCheck.Monadic
import           Text.Format

import           Logging.Class
import           Logging.Global                      hiding (run)
import           Logging.Handler.FileHandler
import           Logging.Handler.RotatingFileHandler
import           Logging.Handler.StreamHandler
import           Logging.Manager
import           Logging.Sink

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)
                , ("Timezone", "INFO", [], ["INFO"], False, False)
                ]
  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
        setTz = if logger == "Timezone" then setTyped @Format1 "{asctime:%Z}"
                                        else id
        hs' = [setTz $ 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' utc True False
      manager = Manager root sinks' (read "GMT") False False

  prop "timezone" $ \(MessageString message) -> monadicIO $ do
    run $ runLog manager $ $(info) "Timezone" message
    msg <- run $ hTryGetLine $ snd $ handlers M.! "INFO"
    assert $ msg == "GMT"

  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