darcs-2.16.3: 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, run, defaultConfig, Config(..) ) where
import Darcs.Prelude
import qualified Darcs.Test.Misc
import qualified Darcs.Test.Patch
import qualified Darcs.Test.Patch.RepoPatchV1
import qualified Darcs.Test.Email
import qualified Darcs.Test.Repository.Inventory
import qualified Darcs.Test.HashedStorage
import Darcs.Util.Exception ( die )
import Control.Monad ( filterM )
import Control.Exception ( SomeException )
import Data.Text ( Text, pack, unpack )
import qualified Data.Text as T
import Data.List ( isPrefixOf, isSuffixOf, sort )
import GHC.IO.Encoding ( textEncodingName )
import System.Console.CmdArgs hiding ( args )
import System.Console.CmdArgs.Explicit ( process )
import System.Directory ( doesFileExist )
import System.Environment.FindBin ( getProgPath )
import System.FilePath( takeDirectory, takeBaseName, isAbsolute, makeRelative )
import qualified System.FilePath as Native ( searchPathSeparator, splitSearchPath )
import qualified System.FilePath.Posix as Posix ( searchPathSeparator )
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.RepoPatchV1.testSuite : Darcs.Test.Patch.testSuite)
-- ----------------------------------------------------------------------
-- shell tests
-- ----------------------------------------------------------------------
data Format = Darcs1 | Darcs2 | Darcs3 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
-- |Environment variable values may need translating depending
-- on whether we are setting them directly or writing out a shell script
-- to set them, and depending on the kind of value and the platform.
-- This type captures the different kinds of values.
data EnvItem
= EnvString String -- ^ A normal string that won't need conversion
| EnvFilePath Shelly.FilePath -- ^ A path on disk that may need conversion for the platform
| EnvSearchPath [Shelly.FilePath] -- ^ A list of paths on disk, for the PATH variable
runtest' :: ShellTest -> Text -> Sh Result
runtest' (ShellTest fmt _ _ dp da) srcdir =
do wd <- pwd
p <- unpack <$> get_env_text "PATH"
let pathToUse = map (fromText . pack) $ takeDirectory dp:Native.splitSearchPath p
let env =
[ ("HOME", EnvFilePath wd)
-- in case someone has XDG_CACHE_HOME set:
, ("XDG_CACHE_HOME", EnvFilePath (wd </> ".cache"))
, ("TESTDATA", EnvFilePath (srcdir </> "tests" </> "data"))
, ("TESTBIN", EnvFilePath (srcdir </> "tests" </> "bin"))
, ("DARCS_TESTING_PREFS_DIR", EnvFilePath $ wd </> ".darcs")
, ("EMAIL", EnvString "tester")
, ("GIT_AUTHOR_NAME", EnvString "tester")
, ("GIT_AUTHOR_EMAIL", EnvString "tester")
, ("GIT_COMMITTER_NAME", EnvString "tester")
, ("GIT_COMMITTER_EMAIL", EnvString "tester")
, ("DARCS_DONT_COLOR", EnvString "1")
, ("DARCS_DONT_ESCAPE_ANYTHING", EnvString "1")
, ("PATH", EnvSearchPath pathToUse)
-- the DARCS variable is passed to the tests purely so they can
-- double-check that the darcs on the path is the expected one,
-- so is passed as a string directly without any translation
, ("DARCS", EnvString dp)
, ("GHC_VERSION", EnvString $ show (__GLASGOW_HASKELL__ :: Int))
]
-- we write the variables to a shell script and source them from there in ./lib,
-- so that it's easy to reproduce a test failure after running the harness with -d.
writefile "env" $ T.unlines $
map (\(k,v) -> T.concat ["export ", k, "=", envItemForScript v]) env
-- just in case the test script doesn't source ./lib:
mapM_ (\(k,v) -> setenv k (envItemForEnv v)) env
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
Darcs3 -> "darcs-3"
Darcs2 -> "darcs-2"
Darcs1 -> "darcs-1"
daf = case da of
PatienceDiff -> "patience"
MyersDiff -> "myers"
-- convert an 'EnvItem' to a string you can put in the environment directly
envItemForEnv :: EnvItem -> Text
envItemForEnv (EnvString v) = pack v
envItemForEnv (EnvFilePath v) = toTextIgnore v
envItemForEnv (EnvSearchPath vs) =
T.intercalate (T.singleton Native.searchPathSeparator) $ map toTextIgnore vs
-- convert an 'EnvItem' to a string that will evaluate to the right value
-- when embedded in a bash script
envItemForScript :: EnvItem -> Text
envItemForScript (EnvString v) = pack (show v)
envItemForScript (EnvFilePath v) = filePathForScript v
envItemForScript (EnvSearchPath vs) =
-- note the use of the Posix search path separator (':') regardless of platform
T.intercalate (T.singleton Posix.searchPathSeparator) $ map filePathForScript vs
-- add quotes around a 'Shelly.FilePath'
quotedFilePath :: Shelly.FilePath -> Text
quotedFilePath = pack . show . toTextIgnore
-- convert a 'Shelly.FilePath' into a string that will evaluate to the right
-- value when put in a bash script
filePathForScript :: Shelly.FilePath -> Text
#ifdef WIN32
-- we have a native Windows path, but we are going to put it in an bash script
-- run in an environment like msys2 which works with an illusion of a Unix style
-- filesystem. Calling cygpath at runtime does the necessary translation.
filePathForScript v = T.concat ["$(cygpath ", quotedFilePath v, ")"]
#else
filePathForScript v = quotedFilePath v
#endif
takeTestName :: FilePath -> Shelly.FilePath
takeTestName n =
let n' = makeRelative "tests" n in
takeBaseName (takeDirectory n') </> takeBaseName n'
runtest :: ShellTest -> Sh Result
runtest t =
withTmp $ \dir -> do
cp "tests/lib" dir
cp "tests/network/sshlib" dir
cp "tests/network/httplib" 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) </> takeTestName (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 (toString (takeTestName 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
, darcs3 :: Bool
, full :: Bool
, darcs :: String
, tests :: [String]
, testDir :: Maybe FilePath
, plain :: Bool
, hideSuccesses :: Bool
, threads :: Int
, qcCount :: Int
, replay :: Maybe Integer
}
deriving (Data, Typeable, Eq, Show)
defaultConfigAnn :: Annotate Ann
defaultConfigAnn
= 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]"
, network := True += help "Run the network shell tests [yes]"
, 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 := True += help "Use darcs-1 repo format [yes]" += name "1"
, darcs2 := True += help "Use darcs-2 repo format [yes]" += name "2"
, darcs3 := True += help "Use darcs-3 repo format [yes]" += name "3"
, 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"
, replay := Nothing += help "Replay QC tests with given seed" += typ "SEED"
]
+= summary "Darcs test harness"
+= program "darcs-test"
defaultConfig :: Config
Right defaultConfig = fmap cmdArgsValue $ process (cmdArgsMode_ defaultConfigAnn) []
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) ]
++ [ "--test-seed="++show seed | Just seed <- [replay conf] ]
case testDir conf of
Nothing -> return ()
Just d -> do e <- shelly (test_e (fromText $ pack d))
when e $ die ("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" ] ++
-- nowadays cabal v2-build produces more complicated structures:
-- t/darcs-test/build/darcs-test/darcs-test and x/darcs/build/darcs/darcs
[takeDirectory path </> ".." </> ".." </> ".." </> "x"
</> "darcs" </> "build" </> "darcs" </> ("darcs" ++ exeSuffix)
| takeBaseName path == "darcs-test" ] ++
[takeDirectory path </> ".." </> ".." </> ".." </> ".." </> "x"
</> "darcs" </> "noopt" </> "build" </> "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
[] -> die ("No darcs specified or found nearby. Tried:\n" ++ unlines (map toString candidates))
v -> return v
when (shell conf || network conf || failing conf) $ do
unless (isAbsolute $ darcsBin) $
die ("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)
. (if darcs3 conf then (Darcs3:) 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_ defaultConfigAnn
run $
if full clp then clp
{ hashed = True
, shell = True
, network = True
, unit = True
, myers = True
, patience = True
, darcs1 = True
, darcs2 = True
}
else clp