darcs-2.14.0: harness/test.hs
{-# LANGUAGE CPP, MultiParamTypeClasses, DeriveDataTypeable, ViewPatterns, OverloadedStrings, ExtendedDefaultRules #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Main ( main ) where
import qualified Darcs.Test.Misc
import qualified Darcs.Test.Patch
import qualified Darcs.Test.Email
import qualified Darcs.Test.Repository.Inventory
import qualified Darcs.Test.HashedStorage
import Control.Monad ( filterM )
import Control.Exception ( SomeException )
import Data.Text ( Text, pack, unpack )
import Data.List ( isPrefixOf, isSuffixOf, sort )
import GHC.IO.Encoding ( textEncodingName )
import System.Console.CmdArgs hiding ( args )
import System.Directory ( doesFileExist )
import System.Environment.FindBin ( getProgPath )
import System.FilePath( takeDirectory, takeBaseName, isAbsolute )
import System.IO( hSetBinaryMode, hSetBuffering, BufferMode( NoBuffering ), stdin, stdout, stderr, localeEncoding )
import Test.Framework.Providers.API
( TestResultlike(..), Testlike(..), Test, runImprovingIO, yieldImprovement, Test(..), liftIO )
import Test.Framework ( defaultMainWithArgs )
import Shelly hiding ( liftIO, run, FilePath, path )
import qualified Shelly
doUnit :: IO [Test]
doUnit = return unitTests
-- | TODO make runnable in parallel
doHashed :: IO [Test]
doHashed = return Darcs.Test.HashedStorage.tests
-- | This is the big list of tests that will be run using testrunner.
unitTests :: [Test]
unitTests =
[ Darcs.Test.Email.testSuite
, Darcs.Test.Misc.testSuite
, Darcs.Test.Repository.Inventory.testSuite
] ++ Darcs.Test.Patch.testSuite
-- ----------------------------------------------------------------------
-- shell tests
-- ----------------------------------------------------------------------
data Format = Darcs1 | Darcs2 deriving (Show, Eq, Typeable, Data)
data DiffAlgorithm = MyersDiff | PatienceDiff deriving (Show, Eq, Typeable, Data)
data Running = Running deriving Show
data Result = Success | Skipped | Failed String
instance Show Result where
show Success = "Success"
show Skipped = "Skipped"
show (Failed f) = unlines (map ("| " ++) $ lines f)
instance TestResultlike Running Result where
testSucceeded Success = True
testSucceeded Skipped = True
testSucceeded _ = False
data ShellTest = ShellTest { format :: Format
, testfile :: FilePath
, testdir :: Maybe FilePath -- ^ only if you want to set it explicitly
, _darcspath :: FilePath
, diffalgorithm :: DiffAlgorithm
}
deriving Typeable
runtest' :: ShellTest -> Text -> Sh Result
runtest' (ShellTest fmt _ _ dp da) srcdir =
do wd <- toTextIgnore <$> pwd
setenv "HOME" wd
setenv "TESTDATA" (toTextIgnore (srcdir </> "tests" </> "data"))
setenv "TESTBIN" (toTextIgnore (srcdir </> "tests" </> "bin"))
setenv "DARCS_TESTING_PREFS_DIR" $ toTextIgnore $ wd </> ".darcs"
setenv "EMAIL" "tester"
setenv "GIT_AUTHOR_NAME" "tester"
setenv "GIT_AUTHOR_EMAIL" "tester"
setenv "GIT_COMMITTER_NAME" "tester"
setenv "GIT_COMMITTER_EMAIL" "tester"
setenv "DARCS_DONT_COLOR" "1"
setenv "DARCS_DONT_ESCAPE_ANYTHING" "1"
p <- get_env_text "PATH"
setenv "PATH" (pack (takeDirectory dp ++ pathVarSeparator ++ unpack p))
setenv "DARCS" $ pack dp
setenv "GHC_VERSION" $ pack $ show (__GLASGOW_HASKELL__ :: Int)
mkdir ".darcs"
writefile ".darcs/defaults" defaults
_ <- onCommandHandles (initOutputHandles (\h -> hSetBinaryMode h True)) $
Shelly.run "bash" [ "test" ]
return Success
`catch_sh` \(_::SomeException)
-> do code <- lastExitCode
case code of
200 -> return Skipped
_ -> Failed <$> unpack <$> lastStderr
where defaults = pack $ unlines
[ "ALL " ++ fmtstr
, "send no-edit-description"
, "ALL ignore-times"
, "ALL " ++ daf
]
fmtstr = case fmt of
Darcs2 -> "darcs-2"
Darcs1 -> "darcs-1"
daf = case da of
PatienceDiff -> "patience"
MyersDiff -> "myers"
#ifdef WIN32
pathVarSeparator = ";"
#else
pathVarSeparator = ":"
#endif
runtest :: ShellTest -> Sh Result
runtest t =
withTmp $ \dir -> do
cp "tests/lib" dir
cp "tests/network/sshlib" dir
cp (fromText $ pack $ testfile t) (dir </> "test")
srcdir <- pwd
silently $ sub $ cd dir >> runtest' t (toTextIgnore srcdir)
where
withTmp =
case testdir t of
Just dir -> \job -> do
let d = (dir </> show (format t) </> show (diffalgorithm t) </> takeBaseName (testfile t))
mkdir_p d
job d
Nothing -> withTmpDir
instance Testlike Running Result ShellTest where
testTypeName _ = "Shell"
runTest _ test = runImprovingIO $ do yieldImprovement Running
liftIO (shelly $ runtest test)
shellTest :: FilePath -> Format -> Maybe FilePath -> String -> DiffAlgorithm -> Test
shellTest dp fmt tdir file da =
Test (takeBaseName file ++ " (" ++ show fmt ++ ")" ++ " (" ++ show da ++ ")") $
ShellTest fmt file tdir dp da
toString :: Shelly.FilePath -> String
toString = unpack . toTextIgnore
findShell :: FilePath -> Text -> Maybe FilePath -> Bool -> [DiffAlgorithm] -> [Format] -> Sh [Test]
findShell dp sdir tdir isFailing diffAlgorithms repoFormats =
do files <- ls (fromText sdir)
let test_files = sort $ filter relevant $ filter (hasExt "sh") files
return [ shellTest dp fmt tdir file da
| file <- map toString test_files
, fmt <- repoFormats
, da <- diffAlgorithms ]
where relevant = (if isFailing then id else not) . ("failing-" `isPrefixOf`) . takeBaseName . toString
-- ----------------------------------------------------------------------
-- harness
-- ----------------------------------------------------------------------
data Config = Config { hashed :: Bool
, failing :: Bool
, shell :: Bool
, network :: Bool
, unit :: Bool
, myers :: Bool
, patience :: Bool
, darcs1 :: Bool
, darcs2 :: Bool
, full :: Bool
, darcs :: String
, tests :: [String]
, testDir :: Maybe FilePath
, plain :: Bool
, hideSuccesses :: Bool
, threads :: Int
, qcCount :: Int
}
deriving (Data, Typeable, Eq)
defaultConfig :: Annotate Ann
defaultConfig
= record Config{}
[ hashed := False += help "Run hashed-storage tests [no]"
, failing := False += help "Run the failing (shell) tests [no]"
, shell := True += help "Run the passing, non-network shell tests [yes]"
-- RELEASE BRANCH ONLY: disable network tests (too fragile)
-- , network := True += help "Run the network shell tests [yes]"
, network := False += help "Run the network shell tests [no]"
, unit := True += help "Run the unit tests [yes]"
, myers := False += help "Use myers diff [no]"
, patience := True += help "Use patience diff [yes]" += name "p"
, darcs1 := False += help "Use darcs-1 repo format [no]" += name "1"
, darcs2 := True += help "Use darcs-2 repo format [yes]" += name "2"
, full := False += help "Run all tests in all variants"
, darcs := "" += help "Darcs binary path" += typ "PATH"
, tests := [] += help "Pattern to limit the tests to run" += typ "PATTERN" += name "t"
, testDir := Nothing += help "Directory to run tests in" += typ "PATH" += name "d"
, plain := False += help "Use plain-text output [no]"
, hideSuccesses := False += help "Hide successes [no]"
, threads := 1 += help "Number of threads [1]" += name "j"
, qcCount := 100 += help "Number of QuickCheck iterations per test [100]" += name "q"
]
+= summary "Darcs test harness"
+= program "darcs-test"
run :: Config -> IO ()
run conf = do
let args = [ "-j", show $ threads conf ]
++ concat [ ["-t", x ] | x <- tests conf ]
++ [ "--plain" | True <- [plain conf] ]
++ [ "--hide-successes" | True <- [hideSuccesses conf] ]
-- this multiplier is calibrated against the observed behaviour of the test harness -
-- increase it if we see lots of "arguments exhausted" errors or similar
++ [ "--maximum-unsuitable-generated-tests", show (7 * qcCount conf) ]
++ [ "--maximum-generated-tests", show (qcCount conf) ]
case testDir conf of
Nothing -> return ()
Just d -> do e <- shelly (test_e (fromText $ pack d))
when e $ fail ("Directory " ++ d ++ " already exists. Cowardly exiting")
darcsBin <-
case darcs conf of
"" -> do
path <- getProgPath
let candidates =
-- if darcs-test lives in foo/something, look for foo/darcs[.exe]
-- for example if we've done cabal install -ftest, there'll be a darcs-test and darcs in the cabal
-- installation folder
[path </> ("darcs" ++ exeSuffix)] ++
-- if darcs-test lives in foo/darcs-test/something, look for foo/darcs/darcs[.exe]
-- for example after cabal build we can run dist/build/darcs-test/darcs-test and it'll find
-- the darcs in dist/build/darcs/darcs
[takeDirectory path </> "darcs" </> ("darcs" ++ exeSuffix) | takeBaseName path == "darcs-test" ]
availableCandidates <- filterM doesFileExist (map toString candidates)
case availableCandidates of
(darcsBin:_) -> do
putStrLn $ "Using darcs executable in " ++ darcsBin
return darcsBin
[] -> fail ("No darcs specified or found nearby. Perhaps --darcs `pwd`/dist/build/darcs/darcs" ++ exeSuffix ++ "?")
v -> return v
when (shell conf || network conf || failing conf) $ do
unless (isAbsolute $ darcsBin) $
fail ("Argument to --darcs should be an absolute path")
unless (exeSuffix `isSuffixOf` darcsBin) $
putStrLn $ "Warning: --darcs flag does not end with " ++ exeSuffix ++ " - some tests may fail (case does matter)"
putStrLn $ "Locale encoding is " ++ textEncodingName localeEncoding
let repoFormat = (if darcs1 conf then (Darcs1:) else id)
. (if darcs2 conf then (Darcs2:) else id)
$ []
let diffAlgorithm = (if myers conf then (MyersDiff:) else id)
. (if patience conf then (PatienceDiff:) else id)
$ []
stests <- shelly $
if shell conf
then findShell darcsBin "tests" (testDir conf) (failing conf) diffAlgorithm repoFormat
else return []
utests <- if unit conf then doUnit else return []
ntests <- shelly $ if network conf then findShell darcsBin "tests/network" (testDir conf) (failing conf) diffAlgorithm repoFormat else return []
hstests <- if hashed conf then doHashed else return []
defaultMainWithArgs (stests ++ utests ++ ntests ++ hstests) args
where
exeSuffix :: String
#ifdef WIN32
exeSuffix = ".exe"
#else
exeSuffix = ""
#endif
main :: IO ()
main = do hSetBinaryMode stdout True
hSetBuffering stdout NoBuffering
hSetBinaryMode stderr True
hSetBinaryMode stdin True
clp <- cmdArgs_ defaultConfig
run $
if full clp then clp
{ hashed = True
, shell = True
, network = True
, unit = True
, myers = True
, patience = True
, darcs1 = True
, darcs2 = True
}
else clp