little-logger-1.0.0: test/Main.hs

{-# LANGUAGE OverloadedStrings #-}

module Main (main) where

import Control.Exception (finally)
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.Text (Text)
import LittleLogger (LogAction (..), LogActionM, LogLevel (..), fileLogAction, filterActionSeverity, logDebugN,
                     logErrorN, logInfoN, logWarnN, runLogActionM, textLogStr)
import System.Directory (removeFile)
import System.IO.Temp (emptySystemTempFile)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit (testCase, (@?=))

emitLogs :: LogActionM ()
emitLogs = do
  logDebugN "debug"
  logInfoN "info"
  logWarnN "warn"
  logErrorN "error"

refAction :: IORef [(LogLevel, Text)] -> LogAction
refAction ref = LogAction (\_ _ lvl msg -> modifyIORef' ref (++ [(lvl, textLogStr msg)]))

runWithRefAction :: (LogAction -> LogAction) -> (LogActionM ()) -> IO [(LogLevel, Text)]
runWithRefAction f m = do
  ref <- newIORef []
  let action = f (refAction ref)
  runLogActionM m action
  readIORef ref

expectedFiltered :: [(LogLevel, Text)]
expectedFiltered =
  [ (LevelWarn, "warn")
  , (LevelError, "error")
  ]

expectedUnfiltered :: [(LogLevel, Text)]
expectedUnfiltered =
  [ (LevelDebug, "debug")
  , (LevelInfo, "info")
  ] ++ expectedFiltered

testUnfiltered :: TestTree
testUnfiltered = testCase "Unfiltered" $ do
  actual <- runWithRefAction id emitLogs
  actual @?= expectedUnfiltered

testFiltered :: TestTree
testFiltered = testCase "Filtered" $ do
  actual <- runWithRefAction (filterActionSeverity LevelWarn) emitLogs
  actual @?= expectedFiltered

testFile :: TestTree
testFile = testCase "File" $ do
  fp <- emptySystemTempFile "little-logger-test"
  flip finally (removeFile fp) $ do
    fileLogAction fp (runLogActionM emitLogs)
    firstContents <- readFile fp
    length (lines firstContents) @?= 4
    fileLogAction fp (runLogActionM emitLogs)
    secondContents <- readFile fp
    length (lines secondContents) @?= 8

main :: IO ()
main = defaultMain $ testGroup "LittleLogger" $
  [ testUnfiltered
  , testFiltered
  , testFile
  ]