import Options.Applicative.Types
import Test.Tasty
-import Test.Tasty.Runners
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
-import Test.Tasty.Ingredients.Rerun
-import Test.Tasty.Options
import Options.Applicative (switch, long, help, internal)
import qualified Data.Map as M
import qualified Data.ByteString.Lazy.UTF8 as BU8
-import System.Environment
import Control.Concurrent.STM hiding (check)
import Common
import qualified Crypto
import qualified Database.Keys
import qualified Annex.WorkTree
-import qualified Annex.Init
import qualified Annex.CatFile
-import qualified Annex.Path
import qualified Annex.VectorClock
import qualified Annex.VariantFile
-import qualified Annex.AdjustedBranch
import qualified Annex.View
import qualified Annex.View.ViewedFile
import qualified Logs.View
import qualified Utility.Process
import qualified Utility.Misc
import qualified Utility.InodeCache
-import qualified Utility.Env
-import qualified Utility.Env.Set
import qualified Utility.Matcher
import qualified Utility.Hash
import qualified Utility.Scheduled
optParser :: Parser TestOptions
optParser = TestOptions
- <$> snd tastyParser
+ <$> snd (tastyParser (tests False True mempty))
<*> switch
( long "keep-failures"
<> help "preserve repositories on test failure"
)
<*> cmdParams "non-options are for internal use only"
-tastyParser :: ([String], Parser Test.Tasty.Options.OptionSet)
-#if MIN_VERSION_tasty(1,3,0)
-tastyParser = go
-#else
-tastyParser = ([], go)
-#endif
- where
- go = suiteOptionParser ingredients (tests False True mempty)
-
runner :: TestOptions -> IO ()
-runner opts
- | fakeSsh opts = runFakeSsh (internalData opts)
- | otherwise = runsubprocesstests =<< Utility.Env.getEnv subenv
- where
- -- Run git-annex test in a subprocess, so that any files
- -- it may open will be closed before running finalCleanup.
- -- This should prevent most failures to clean up after the test
- -- suite.
- subenv = "GIT_ANNEX_TEST_SUBPROCESS"
- runsubprocesstests Nothing = do
- let warnings = fst tastyParser
- unless (null warnings) $ do
- hPutStrLn stderr "warnings from tasty:"
- mapM_ (hPutStrLn stderr) warnings
- pp <- Annex.Path.programPath
- Utility.Env.Set.setEnv subenv "1" True
- ps <- getArgs
- exitcode <- withCreateProcess (proc pp ps) $
- \_ _ _ pid -> waitForProcess pid
- unless (keepFailuresOption opts) finalCleanup
- exitWith exitcode
- runsubprocesstests (Just _) = isolateGitConfig $ do
- ensuretmpdir
- crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem'
- (toRawFilePath tmpdir)
- Nothing Nothing False
- adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported
- case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem adjustedbranchok opts) of
- Nothing -> error "No tests found!?"
- Just act -> ifM act
- ( exitSuccess
- , do
- putStrLn " (Failures above could be due to a bug in git-annex, or an incompatibility"
- putStrLn " with utilities, such as git, installed on this system.)"
- exitFailure
- )
-
-ingredients :: [Ingredient]
-ingredients =
- [ listingTests
- , rerunningTests [consoleTestReporter]
- ]
+runner opts = parallelTestRunner opts tests
-tests :: Bool -> Bool -> TestOptions -> TestTree
+tests :: Bool -> Bool -> TestOptions -> [TestTree]
tests crippledfilesystem adjustedbranchok opts =
- testGroup "Tests" $ properties
+ properties
: withTestMode remotetestmode Nothing testRemotes
: map (\(d, te) -> withTestMode te (Just initTests) (unitTests d)) testmodes
where
withtmpclonerepo $ \r3 -> do
forM_ [r1, r2, r3] $ \r -> indir r $ do
when (r /= r1) $
- git "remote" ["add", "r1", "../../" ++ r1] "remote add"
+ git "remote" ["add", "r1", "../" ++ r1] "remote add"
when (r /= r2) $
- git "remote" ["add", "r2", "../../" ++ r2] "remote add"
+ git "remote" ["add", "r2", "../" ++ r2] "remote add"
when (r /= r3) $
- git "remote" ["add", "r3", "../../" ++ r3] "remote add"
+ git "remote" ["add", "r3", "../" ++ r3] "remote add"
git_annex "get" [annexedfile] "get"
git "remote" ["rm", "origin"] "remote rm"
forM_ [r3, r2, r1] $ \r -> indir r $
{- git-annex test suite framework
-
- - Copyright 2010-2021 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2022 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
import Test.Tasty
import Test.Tasty.Runners
import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck
+import Test.Tasty.Options
+import Test.Tasty.Ingredients.Rerun
+import Options.Applicative.Types
import Control.Concurrent
+import Control.Concurrent.Async
+import System.Environment (getArgs)
import Common
import Types.Test
import qualified Annex.Path
import qualified Annex.Action
import qualified Annex.AdjustedBranch
+import qualified Annex.Init
import qualified Utility.Process
import qualified Utility.Process.Transcript
import qualified Utility.Env
-- any type of error and change back to currdir before
-- rethrowing.
r <- bracket_
- (changeToTmpDir dir)
+ (changeToTopDir dir)
(setCurrentDirectory currdir)
(tryNonAsync a)
case r of
setuprepo :: FilePath -> IO FilePath
setuprepo dir = do
cleanup dir
- ensuretmpdir
git "init" ["-q", dir] "git init"
configrepo dir
return dir
clonerepo :: FilePath -> FilePath -> CloneRepoConfig -> IO FilePath
clonerepo old new cfg = do
cleanup new
- ensuretmpdir
let cloneparams = catMaybes
[ Just "-q"
, if bareClone cfg then Just "--bare" else Nothing
git "config" ["annex.largefiles", "exclude=" ++ ingitfile]
"git config annex.largefiles"
-ensuretmpdir :: IO ()
-ensuretmpdir = do
- e <- doesDirectoryExist tmpdir
+ensuredir :: FilePath -> IO ()
+ensuredir d = do
+ e <- doesDirectoryExist d
unless e $
- createDirectory tmpdir
+ createDirectory d
{- Prevent global git configs from affecting the test suite. -}
isolateGitConfig :: IO a -> IO a
git "commit" ["--allow-empty", "-m", "empty"] "git commit failed"
git_annex "adjust" ["--unlock"] "git annex adjust failed"
-changeToTmpDir :: FilePath -> IO ()
-changeToTmpDir t = do
+changeToTopDir :: FilePath -> IO ()
+changeToTopDir t = do
topdir <- Utility.Env.getEnvDefault "TOPDIR" (error "TOPDIR not set")
setCurrentDirectory $ topdir ++ "/" ++ t
newmainrepodir = go (0 :: Int)
where
go n = do
- let d = tmpdir </> "main" ++ show n
+ let d = "main" ++ show n
ifM (doesDirectoryExist d)
( go $ n + 1
, do
tmprepodir = go (0 :: Int)
where
go n = do
- let d = tmpdir </> "tmprepo" ++ show n
+ let d = "tmprepo" ++ show n
ifM (doesDirectoryExist d)
( go $ n + 1
, return d
pair :: FilePath -> FilePath -> Assertion
pair r1 r2 = forM_ [r1, r2] $ \r -> indir r $ do
when (r /= r1) $
- git "remote" ["add", "r1", "../../" ++ r1] "remote add"
+ git "remote" ["add", "r1", "../" ++ r1] "remote add"
when (r /= r2) $
- git "remote" ["add", "r2", "../../" ++ r2] "remote add"
+ git "remote" ["add", "r2", "../" ++ r2] "remote add"
{- Runs a query in the current repository, but first makes the repository
make_writeable d = void $
Utility.Process.Transcript.processTranscript
"chmod" ["-R", "u+w", d] Nothing
+
+{- Tests each TestTree in parallel, and exits with succcess/failure.
+ -
+ - Tasty supports parallel tests, but this does not use it, because
+ - many tests need to be run in test repos, and chdir would not be
+ - thread safe. Instead, this starts one child process for each TestTree.
+ -
+ - An added benefit of using child processes is that any files they may
+ - leave open are closed before finalCleanup is run at the end. This
+ - prevents some failures to clean up after the test suite.
+ -}
+parallelTestRunner :: TestOptions -> (Bool -> Bool -> TestOptions -> [TestTree]) -> IO ()
+parallelTestRunner opts mkts
+ | fakeSsh opts = runFakeSsh (internalData opts)
+ | otherwise = go =<< Utility.Env.getEnv subenv
+ where
+ subenv = "GIT_ANNEX_TEST_SUBPROCESS"
+ go Nothing = do
+ ensuredir tmpdir
+ crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem'
+ (toRawFilePath tmpdir)
+ Nothing Nothing False
+ adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported
+ let ts = mkts crippledfilesystem adjustedbranchok opts
+ let warnings = fst (tastyParser ts)
+ unless (null warnings) $ do
+ hPutStrLn stderr "warnings from tasty:"
+ mapM_ (hPutStrLn stderr) warnings
+ environ <- Utility.Env.getEnvironment
+ ps <- getArgs
+ pp <- Annex.Path.programPath
+ exitcodes <- forConcurrently [1..length ts] $ \n -> do
+ let subdir = tmpdir </> show n
+ ensuredir subdir
+ let p = (proc pp ps)
+ { env = Just ((subenv, show (n, crippledfilesystem, adjustedbranchok)):environ)
+ , cwd = Just subdir
+ }
+ withCreateProcess p $
+ \_ _ _ pid -> waitForProcess pid
+ unless (keepFailuresOption opts) finalCleanup
+ if all (== ExitSuccess) exitcodes
+ then exitSuccess
+ else case (filter (/= ExitFailure 1) exitcodes) of
+ [] -> do
+ putStrLn " (Failures above could be due to a bug in git-annex, or an incompatibility"
+ putStrLn " with utilities, such as git, installed on this system.)"
+ exitFailure
+ v -> do
+ putStrLn $ " Test subprocesses exited with unexpected exit codes: " ++ show v
+ exitFailure
+ go (Just subenvval) = case readish subenvval of
+ Nothing -> error ("Bad " ++ subenv)
+ Just (n, crippledfilesystem, adjustedbranchok) -> isolateGitConfig $ do
+ let ts = mkts crippledfilesystem adjustedbranchok opts
+ let t = topLevelTestGroup
+ -- This group is needed to avoid what
+ -- seems to be a tasty bug which causes a
+ -- segfault.
+ [ testGroup "Tasty"
+ [ testProperty "tasty self-check" True
+ ]
+ , ts !! (n - 1)
+ ]
+ case tryIngredients ingredients (tastyOptionSet opts) t of
+ Nothing -> error "No tests found!?"
+ Just act -> ifM act
+ ( exitSuccess
+ , exitFailure
+ )
+
+topLevelTestGroup :: [TestTree] -> TestTree
+topLevelTestGroup = testGroup "Tests"
+
+tastyParser :: [TestTree] -> ([String], Parser Test.Tasty.Options.OptionSet)
+#if MIN_VERSION_tasty(1,3,0)
+tastyParser ts = go
+#else
+tastyParser ts = ([], go)
+#endif
+ where
+ go = suiteOptionParser ingredients (topLevelTestGroup ts)
+
+ingredients :: [Ingredient]
+ingredients =
+ [ listingTests
+ , rerunningTests [consoleTestReporter]
+ ]
+
projects / git-annex.git / commitdiff