fix numerous problem with test suite on crippled filesystems etc
This commit is contained in:
parent
15148ee9eb
commit
aa569500d5
2 changed files with 61 additions and 39 deletions
|
@ -14,6 +14,7 @@ module Annex.Init (
|
|||
initialize',
|
||||
uninitialize,
|
||||
probeCrippledFileSystem,
|
||||
probeCrippledFileSystem',
|
||||
) where
|
||||
|
||||
import Annex.Common
|
||||
|
@ -134,16 +135,20 @@ isBare = fromRepo Git.repoIsLocalBare
|
|||
- or removing write access from files. -}
|
||||
probeCrippledFileSystem :: Annex Bool
|
||||
probeCrippledFileSystem = do
|
||||
tmp <- fromRepo gitAnnexTmpMiscDir
|
||||
createAnnexDirectory tmp
|
||||
liftIO $ probeCrippledFileSystem' tmp
|
||||
|
||||
probeCrippledFileSystem' :: FilePath -> IO Bool
|
||||
probeCrippledFileSystem' tmp = do
|
||||
#ifdef mingw32_HOST_OS
|
||||
return True
|
||||
#else
|
||||
tmp <- fromRepo gitAnnexTmpMiscDir
|
||||
let f = tmp </> "gaprobe"
|
||||
createAnnexDirectory tmp
|
||||
liftIO $ writeFile f ""
|
||||
uncrippled <- liftIO $ probe f
|
||||
void $ liftIO $ tryIO $ allowWrite f
|
||||
liftIO $ removeFile f
|
||||
writeFile f ""
|
||||
uncrippled <- probe f
|
||||
void $ tryIO $ allowWrite f
|
||||
removeFile f
|
||||
return $ not uncrippled
|
||||
where
|
||||
probe f = catchBoolIO $ do
|
||||
|
|
83
Test.hs
83
Test.hs
|
@ -102,22 +102,25 @@ import qualified Utility.Gpg
|
|||
|
||||
optParser :: Parser TestOptions
|
||||
optParser = TestOptions
|
||||
<$> suiteOptionParser ingredients (tests mempty)
|
||||
<$> suiteOptionParser ingredients (tests False mempty)
|
||||
<*> switch
|
||||
( long "keep-failures"
|
||||
<> help "preserve repositories on test failure"
|
||||
)
|
||||
)
|
||||
|
||||
runner :: Maybe (TestOptions -> IO ())
|
||||
runner = Just $ \opts -> case tryIngredients ingredients (tastyOptionSet opts) (tests opts) of
|
||||
Nothing -> error "No tests found!?"
|
||||
Just act -> ifM act
|
||||
( exitSuccess
|
||||
, do
|
||||
putStrLn " (This could be due to a bug in git-annex, or an incompatability"
|
||||
putStrLn " with utilities, such as git, installed on this system.)"
|
||||
exitFailure
|
||||
)
|
||||
runner = Just $ \opts -> do
|
||||
ensuretmpdir
|
||||
crippledfilesystem <- Annex.Init.probeCrippledFileSystem' tmpdir
|
||||
case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem opts) of
|
||||
Nothing -> error "No tests found!?"
|
||||
Just act -> ifM act
|
||||
( exitSuccess
|
||||
, do
|
||||
putStrLn " (This could be due to a bug in git-annex, or an incompatability"
|
||||
putStrLn " with utilities, such as git, installed on this system.)"
|
||||
exitFailure
|
||||
)
|
||||
|
||||
ingredients :: [Ingredient]
|
||||
ingredients =
|
||||
|
@ -125,18 +128,19 @@ ingredients =
|
|||
, rerunningTests [consoleTestReporter]
|
||||
]
|
||||
|
||||
tests :: TestOptions -> TestTree
|
||||
tests opts = testGroup "Tests" $ properties :
|
||||
tests :: Bool -> TestOptions -> TestTree
|
||||
tests crippledfilesystem opts = testGroup "Tests" $ properties :
|
||||
map (\(d, te) -> withTestMode te (unitTests d)) testmodes
|
||||
where
|
||||
testmodes =
|
||||
[ ("v6 unlocked", (testMode opts "6") { unlockedFiles = True })
|
||||
, ("v5", testMode opts "5")
|
||||
testmodes = catMaybes
|
||||
[ Just ("v6 unlocked", (testMode opts "6") { unlockedFiles = True })
|
||||
, Just ("v5", testMode opts "5")
|
||||
, if crippledfilesystem
|
||||
then Nothing
|
||||
else Just ("v6 locked", testMode opts "6")
|
||||
#ifndef mingw32_HOST_OS
|
||||
-- Windows does not support locked files in v6 yet.
|
||||
, ("v6 locked", testMode opts "6")
|
||||
-- Windows will only use direct mode, so don't test twice.
|
||||
, ("v5 direct", (testMode opts "5") { forceDirect = True })
|
||||
, Just ("v5 direct", (testMode opts "5") { forceDirect = True })
|
||||
#endif
|
||||
]
|
||||
|
||||
|
@ -324,12 +328,12 @@ test_import :: Assertion
|
|||
test_import = intmpclonerepo $ Utility.Tmp.withTmpDir "importtest" $ \importdir -> do
|
||||
(toimport1, importf1, imported1) <- mktoimport importdir "import1"
|
||||
git_annex "import" [toimport1] @? "import failed"
|
||||
annexed_present_locked imported1
|
||||
annexed_present_imported imported1
|
||||
checkdoesnotexist importf1
|
||||
|
||||
(toimport2, importf2, imported2) <- mktoimport importdir "import2"
|
||||
git_annex "import" [toimport2] @? "import of duplicate failed"
|
||||
annexed_present_locked imported2
|
||||
annexed_present_imported imported2
|
||||
checkdoesnotexist importf2
|
||||
|
||||
(toimport3, importf3, imported3) <- mktoimport importdir "import3"
|
||||
|
@ -349,11 +353,11 @@ test_import = intmpclonerepo $ Utility.Tmp.withTmpDir "importtest" $ \importdir
|
|||
|
||||
(toimport5, importf5, imported5) <- mktoimport importdir "import5"
|
||||
git_annex "import" ["--duplicate", toimport5] @? "import --duplicate failed"
|
||||
annexed_present_locked imported5
|
||||
annexed_present_imported imported5
|
||||
checkexists importf5
|
||||
|
||||
git_annex "drop" ["--force", imported1, imported2, imported5] @? "drop failed"
|
||||
annexed_notpresent_locked imported2
|
||||
annexed_notpresent_imported imported2
|
||||
(toimportdup, importfdup, importeddup) <- mktoimport importdir "importdup"
|
||||
git_annex "import" ["--clean-duplicates", toimportdup]
|
||||
@? "import of missing duplicate with --clean-duplicates failed"
|
||||
|
@ -365,6 +369,14 @@ test_import = intmpclonerepo $ Utility.Tmp.withTmpDir "importtest" $ \importdir
|
|||
let importf = subdir </> "f"
|
||||
writeFile (importdir </> importf) (content importf)
|
||||
return (importdir </> subdir, importdir </> importf, importf)
|
||||
annexed_present_imported f = ifM (annexeval Config.crippledFileSystem)
|
||||
( annexed_present_unlocked f
|
||||
, annexed_present_locked f
|
||||
)
|
||||
annexed_notpresent_imported f = ifM (annexeval Config.crippledFileSystem)
|
||||
( annexed_notpresent_unlocked f
|
||||
, annexed_notpresent_locked f
|
||||
)
|
||||
|
||||
test_reinject :: Assertion
|
||||
test_reinject = intmpclonerepoInDirect $ do
|
||||
|
@ -1273,7 +1285,7 @@ test_uncommitted_conflict_resolution = do
|
|||
- lost track of whether a file was a symlink.
|
||||
-}
|
||||
test_conflict_resolution_symlink_bit :: Assertion
|
||||
test_conflict_resolution_symlink_bit =
|
||||
test_conflict_resolution_symlink_bit = unlessM (unlockedFiles <$> getTestMode) $
|
||||
withtmpclonerepo $ \r1 ->
|
||||
withtmpclonerepo $ \r2 ->
|
||||
withtmpclonerepo $ \r3 -> do
|
||||
|
@ -1546,9 +1558,10 @@ test_add_subdirs = intmpclonerepo $ do
|
|||
|
||||
{- Regression test for Windows bug where symlinks were not
|
||||
- calculated correctly for files in subdirs. -}
|
||||
git_annex "sync" [] @? "sync failed"
|
||||
l <- annexeval $ decodeBS <$> Annex.CatFile.catObject (Git.Types.Ref "HEAD:dir/foo")
|
||||
"../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l)
|
||||
unlessM (unlockedFiles <$> getTestMode) $ do
|
||||
git_annex "sync" [] @? "sync failed"
|
||||
l <- annexeval $ decodeBS <$> Annex.CatFile.catObject (Git.Types.Ref "HEAD:dir/foo")
|
||||
"../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l)
|
||||
|
||||
createDirectory "dir2"
|
||||
writeFile ("dir2" </> "foo") $ content annexedfile
|
||||
|
@ -1752,12 +1765,16 @@ cleanup' final dir = whenM (doesDirectoryExist dir) $ do
|
|||
removeDirectoryRecursive dir
|
||||
|
||||
checklink :: FilePath -> Assertion
|
||||
checklink f = do
|
||||
s <- getSymbolicLinkStatus f
|
||||
-- in direct mode, it may be a symlink, or not, depending
|
||||
-- on whether the content is present.
|
||||
unlessM (annexeval Config.isDirect) $
|
||||
isSymbolicLink s @? f ++ " is not a symlink"
|
||||
checklink f = ifM (annexeval Config.crippledFileSystem)
|
||||
( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget f))
|
||||
@? f ++ " is not a (crippled) symlink"
|
||||
, do
|
||||
s <- getSymbolicLinkStatus f
|
||||
-- in direct mode, it may be a symlink, or not, depending
|
||||
-- on whether the content is present.
|
||||
unlessM (annexeval Config.isDirect) $
|
||||
isSymbolicLink s @? f ++ " is not a symlink"
|
||||
)
|
||||
|
||||
checkregularfile :: FilePath -> Assertion
|
||||
checkregularfile f = do
|
||||
|
|
Loading…
Reference in a new issue