TypesSpec.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeApplications  #-}

module LoggingTest.TypesSpec ( spec ) where

import           Control.Concurrent.MVar
import           Control.Lens                            hiding (Level (..))
import           Control.Monad
import           Data.Default                            (def)
import           Data.Generics.Product.Typed
import           Data.IORef
import           Data.List                               (isPrefixOf)
import           Data.String                             (fromString)
import           Data.Time.Clock
import           Data.Time.Clock.POSIX
import           Data.Time.LocalTime
import           Prelude                                 hiding (filter)
import           System.Directory
import           System.FilePath
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.Filter
import           Logging.Handler.FileHandler
import           Logging.Handler.RotatingFileHandler
import           Logging.Handler.StreamHandler
import           Logging.Handler.TimeRotatingFileHandler
import           Logging.Level
import           Logging.Logger
import           Logging.Prelude
import           Logging.Record
import           Logging.Sink

import           LoggingTest.Prelude

spec :: Spec
spec = do
  levelSpec
  filterSpec
  handlerSpec


levelSpec :: Spec
levelSpec = describe "Level" $ do
  prop "read & show" $ \v ->
    let level = Level v in read (show level) == level

  prop "overload string" $ \v ->
    let level = Level v in fromString (show level) == level

filterSpec :: Spec
filterSpec = describe "Filter" $ do
  prop "pass" $ \rcd@LogRecord{..} ->
    let filterer = map fromString $
                    [logger, parent logger, parent $ parent logger, ""]
    in filter (filterer :: Filterer) rcd

  prop "reject" $ \rcd@LogRecord{..} ->
    let filters = map (fromString . (++ "Test")) $
                    [logger, parent logger, parent $ parent logger, ""]
    in all (== False) [filter (f :: Filter) rcd | f <- filters]


handlerSpec :: Spec
handlerSpec = describe "Handler" $ do
  (read, write) <- runIO createPipe
  fileRef <- runIO $ newIORef undefined
  rotateFileMVar <- runIO newEmptyMVar
  timeRotateRef <- runIO $ newIORef undefined
  timeFileMVar <- runIO newEmptyMVar
  runIO $ hSetEncoding read utf8 >> hSetEncoding write utf8
  let handler = toHandler $ StreamHandler def [] "{message}" write
      fileHandler = toHandler $
        FileHandler def [] "{message}" "/tmp/log4hs/file.log" utf8 fileRef
      rotateHandler = toHandler $
        RotatingFileHandler def [] "{message}" "/tmp/log4hs/rotate.log" utf8
          1000 5 rotateFileMVar
      timeHandler = toHandler $
        TimeRotatingFileHandler def [] "{message}" "/tmp/log4hs/time.log" utf8
          utc (Minute 5) 5 timeRotateRef timeFileMVar
  runIO $ open handler >> open fileHandler >> open rotateHandler

  prop "filter" $ \(rcd@LogRecord{..}) -> monadicIO $ do
    let loggers = [logger, parent logger, parent $ parent logger, ""]
    -- level reject
    forM_ logger $ \logger -> do
      let handler' = handler & typed @Level .~ (succ level)
      res <- run $ handle handler' rcd
      assert $ not res
    -- filterer reject
    forM_ loggers $ \logger -> do
      let handler' = handler & typed @Filterer .~ [fromString $ logger ++ "Test"]
      res <- run $ handle handler' rcd
      assert $ not res
    -- filterer pass
    forM_ loggers $ \logger -> do
      let handler' = handler & typed @Filterer .~ [fromString logger]
      res <- run $ handle handler' rcd
      msg <- run $ hTryGetLine read
      assert res
      assert (msg == message)
    -- empty filterer
    res <- run $ handle handler rcd
    msg <- run $ hTryGetLine read
    assert res
    assert (msg == message)

  prop "file" $ \(rcd@LogRecord{..}) -> monadicIO $ do
    file <- run $ readIORef fileRef
    run $ hSetFileSize file 0 >> hSeek file AbsoluteSeek 0
    run $ handle fileHandler rcd
    run $ hSeek file AbsoluteSeek 0
    msg <- run $ hTryGetLine file
    assert (msg == message)

  prop "rotate" $ \(rcd, Alphabet c) -> monadicIO $ do
    file <- run $ readMVar rotateFileMVar
    run $ hSetFileSize file 0 >> hSeek file AbsoluteSeek 0
    let message = replicate 99 c
        rcd' = rcd { message = message }
    -- not rollover yet
    run $ forM [1..9] $ \_ -> handle rotateHandler rcd'
    run $ hSeek file AbsoluteSeek 0
    msgs <- run $ forM [1..9] $ \_ -> hTryGetLine file
    assert $ all (== message) msgs
    -- rollover
    run $ handle rotateHandler rcd'
    closed <- run $ hIsClosed file
    assert closed
    pos <- run $ readMVar rotateFileMVar >>= hTell
    assert (pos == 0)
    -- rotate.1.log
    file1 <- run $ openLogFile "/tmp/log4hs/rotate.1.log" utf8
    run $ hSeek file1 AbsoluteSeek 0
    msgs1 <- run $ forM [1..10] $ \_ -> hTryGetLine file1
    run $ hClose file1
    assert $ all (== message) msgs1
    -- rollover again
    file' <- run $ readMVar rotateFileMVar
    run $ forM [1..10] $ \_ -> handle rotateHandler rcd'
    closed1 <- run $ hIsClosed file'
    assert closed1
    -- rotate.2.log
    file2 <- run $ openLogFile "/tmp/log4hs/rotate.2.log" utf8
    run $ hSeek file2 AbsoluteSeek 0
    msgs2 <- run $ forM [1..10] $ \_ -> hTryGetLine file2
    run $ hClose file2
    -- rotate.2.log
    assert $ all (== message) msgs2
  prop "time" $ \(Positive n, rcd) -> monadicIO $ do
    -- open
    now <- run $ getCurrentTime
    let mtime = addUTCTime (negate $ 310 * fromInteger n) now
    run $ do
      createFile "/tmp/log4hs/time.log"
      setModificationTime "/tmp/log4hs/time.log" mtime
      open timeHandler
    rt <- run $ readIORef timeRotateRef
    let ts1 = fromInteger $ 300 * (1 + truncate ((utcTimeToPOSIXSeconds mtime) / 300))
    assert (ts1 == utcTimeToPOSIXSeconds rt)
    -- rotate
    file <- run $ readMVar timeFileMVar
    run $ hSetFileSize file 0 >> hSeek file AbsoluteSeek 0
    run $ handle timeHandler $ rcd {utctime = now}
    closed <- run $ hIsClosed file
    assert closed
    -- contents of new file
    file1 <- run $ readMVar timeFileMVar
    run $ hSeek file1 AbsoluteSeek 0
    msg <- run $ hTryGetLine file1
    assert $ msg == message rcd
    -- latest backup
    exist <- run $ doesFileExist $ appendBaseName "/tmp/log4hs/time.log" $
      format ".{:%Y-%m-%d_%H-%M}" $ addUTCTime (negate 300) rt
    assert exist
    -- max backups
    files <- run $ listDirectory "/tmp/log4hs/"
    assert $ 6 >= length [f | f <- files, isPrefixOf "/tmp/log4hs/time." f]

    run $ close timeHandler