{-# 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