arbtt-0.8.1: tests/test.hs

{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}

import Test.Tasty hiding (defaultMain)
import Test.Tasty.Golden.Manage
import Test.Tasty.Golden
import Test.Tasty.HUnit
import Test.HUnit
import System.Process.ByteString.Lazy
import qualified Data.ByteString.Lazy as B
import Control.Monad
import Control.Exception
import Data.Typeable
import System.Exit
import System.Posix.Env

import Categorize
import TimeLog
import Data
import Data.Time.Clock

main = do
    putEnv "TZ=UTC" -- to make tests reproducible
    defaultMain tests

tests :: TestTree
tests = testGroup "Tests" [goldenTests, regressionTests]

regressionTests :: TestTree
regressionTests = testGroup "Regression tests"
    [ testCase "Issue #4" $ do
        cat <- readCategorizer "tests/issue4.cfg"
        let sample = TimeLogEntry undefined 0 (CaptureData [(True, "aa", "program")] 0 "")
        let [TimeLogEntry _ _ (_,acts)] = cat [sample]
        [Activity (Just "Cat") "aa"] @=? acts
        return ()
    , testCase "Issue #5" $ do
        cat <- readCategorizer "tests/issue5.cfg"
        let sample = TimeLogEntry undefined 0 (CaptureData [(True, "aa", "program")] 0 "")
        let [TimeLogEntry _ _ (_,acts)] = cat [sample]
        [Activity Nothing "A2"] @=? acts
        return ()
    , testCase "Issue #14" $ do
        cat <- readCategorizer "tests/issue14.cfg"
        now <- getCurrentTime
        let backThen = (-60*60*101) `addUTCTime` now

        let sample = TimeLogEntry backThen 0 (CaptureData [(True, "aa", "program")] 0 "")
        let [TimeLogEntry _ _ (_,acts)] = cat [sample]
        [Activity Nothing "old"] @=? acts
        return ()
    ]


goldenTests :: TestTree
goldenTests = testGroup "Golden tests"
    [ goldenVsString "dump small"
        "tests/small_dump.out" $
        run "dist/build/arbtt-dump/arbtt-dump" ["-f","tests/small.log", "-t", "Show"] B.empty
    , goldenVsFile "import small"
        "tests/small_import.out" "tests/small_import.out.actual" $ void $
        B.readFile "tests/small_import.in" >>=
        run "dist/build/arbtt-import/arbtt-import" ["-f","tests/small_import.out.actual"]
    , goldenVsFile "recover small"
        "tests/small_borked_recover.out" "tests/small_borked_recover.out.actual" $ void $
        run "dist/build/arbtt-recover/arbtt-recover" ["-i","tests/small_borked_recover.out", "-o", "tests/small_borked_recover.out.actual"] B.empty
    , goldenVsString "stats small"
        "tests/small_stats.out" $
        run "dist/build/arbtt-stats/arbtt-stats" ["--logfile", "tests/small.log", "--categorize", "tests/small.cfg"] B.empty
    , goldenVsString "stats small csv"
        "tests/small_stats_csv.out" $
        run "dist/build/arbtt-stats/arbtt-stats" ["--logfile", "tests/small.log", "--categorize", "tests/small.cfg", "--output-format", "csv"] B.empty
    , goldenVsString "stats small unicode"
        "tests/unicode_stats.out" $
        run "dist/build/arbtt-stats/arbtt-stats" ["--logfile", "tests/unicode.log", "--categorize", "tests/unicode.cfg"] B.empty
    ]


run :: FilePath -> [FilePath] -> B.ByteString -> IO B.ByteString
run cmd args stdin = do
   (ex,stdout,stderr) <- readProcessWithExitCode cmd args stdin
   unless (B.null stderr) $ throwIO $ StderrException stderr
   case ex of
     ExitSuccess   -> return stdout
     ExitFailure r -> throwIO $ ExitCodeException r

data StderrException = StderrException B.ByteString
     deriving (Show, Typeable)
data ExitCodeException = ExitCodeException Int
     deriving (Show, Typeable)

instance Exception StderrException
instance Exception ExitCodeException