mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

Made the test suite significantly less noisy

Browse source 
Only displaying git-annex and git command output when something went wrong.

A few could still leak stderr. These include the couple of calls
to readProcess, which reads stdin but lets stderr through. But they don't
leak any usually, so probably only would when failing anyway.

Currently, there is no excess output at all!

This commit was sponsored by Brock Spratlen on Patreon.
This commit is contained in:
Joey Hess 2020-11-24 14:07:46 -04:00
parent a3b714ddd9
commit ff4354c6e4
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 92 additions and 79 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
CHANGELOG
View file

@ -22,6 +22,8 @@ git-annex (8.20201117) UNRELEASED; urgency=medium
Thanks, Kyle Meyer. Thanks, Kyle Meyer.
* upgrade: Support an edge case upgrading a v5 direct mode repo * upgrade: Support an edge case upgrading a v5 direct mode repo
where nothing had ever been committed to the head branch. where nothing had ever been committed to the head branch.
* Made the test suite significantly less noisy, only displaying command
output when something failed.
-- Joey Hess <id@joeyh.name> Mon, 16 Nov 2020 09:38:32 -0400 -- Joey Hess <id@joeyh.name> Mon, 16 Nov 2020 09:38:32 -0400

98
Test.hs
View file

@ -387,8 +387,8 @@ test_add = inmainrepo $ do
annexed_present sha1annexedfile annexed_present sha1annexedfile
checkbackend sha1annexedfile backendSHA1 checkbackend sha1annexedfile backendSHA1
writecontent ingitfile $ content ingitfile writecontent ingitfile $ content ingitfile
boolSystem "git" [Param "add", File ingitfile] @? "git add failed" git "add" [ingitfile] @? "git add failed"
boolSystem "git" [Param "commit", Param "-q", Param "-m", Param "commit"] @? "git commit failed" git "commit" ["-q", "-m", "commit"] @? "git commit failed"
git_annex "add" [ingitfile] @? "add ingitfile should be no-op" git_annex "add" [ingitfile] @? "add ingitfile should be no-op"
unannexed ingitfile unannexed ingitfile
@ -461,11 +461,8 @@ test_view = intmpclonerepo $ do
test_magic :: Assertion test_magic :: Assertion
test_magic = intmpclonerepo $ do test_magic = intmpclonerepo $ do
#ifdef WITH_MAGICMIME #ifdef WITH_MAGICMIME
boolSystem "git" git "config" ["annex.largefiles", "mimeencoding=binary"]
[ Param "config" @? "git config annex.largefiles failed"
, Param "annex.largefiles"
, Param "mimeencoding=binary"
] @? "git config annex.largefiles failed"
writeFile "binary" "\127" writeFile "binary" "\127"
writeFile "text" "test\n" writeFile "text" "test\n"
git_annex "add" ["binary", "text"] git_annex "add" ["binary", "text"]
@ -562,8 +559,7 @@ test_unannex_withcopy = intmpclonerepo $ do
test_drop_noremote :: Assertion test_drop_noremote :: Assertion
test_drop_noremote = intmpclonerepo $ do test_drop_noremote = intmpclonerepo $ do
git_annex "get" [annexedfile] @? "get failed" git_annex "get" [annexedfile] @? "get failed"
boolSystem "git" [Param "remote", Param "rm", Param "origin"] git "remote" ["rm", "origin"] @? "git remote rm origin failed"
@? "git remote rm origin failed"
git_annex_shouldfail "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file" git_annex_shouldfail "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file"
annexed_present annexedfile annexed_present annexedfile
git_annex "drop" ["--force", annexedfile] @? "drop --force failed" git_annex "drop" ["--force", annexedfile] @? "drop --force failed"
@ -765,12 +761,12 @@ test_lock = intmpclonerepo $ do
git_annex "unlock" [annexedfile] @? "unlock failed" git_annex "unlock" [annexedfile] @? "unlock failed"
unannexed annexedfile unannexed annexedfile
changecontent annexedfile changecontent annexedfile
boolSystem "git" [Param "add", Param annexedfile] @? "add of modified file failed" git "add" [annexedfile] @? "add of modified file failed"
runchecks [checkregularfile, checkwritable] annexedfile runchecks [checkregularfile, checkwritable] annexedfile
c <- readFile annexedfile c <- readFile annexedfile
assertEqual "content of modified file" c (changedcontent annexedfile) assertEqual "content of modified file" c (changedcontent annexedfile)
r' <- git_annex "drop" [annexedfile] git_annex_shouldfail "drop" [annexedfile]
not r' @? "drop wrongly succeeded with no known copy of modified file" @? "drop wrongly succeeded with no known copy of modified file"
-- Regression test: lock --force when work tree file -- Regression test: lock --force when work tree file
-- was modified lost the (unmodified) annex object. -- was modified lost the (unmodified) annex object.
@ -804,12 +800,11 @@ test_edit' precommit = intmpclonerepo $ do
git_annex "edit" [annexedfile] @? "edit failed" git_annex "edit" [annexedfile] @? "edit failed"
unannexed annexedfile unannexed annexedfile
changecontent annexedfile changecontent annexedfile
boolSystem "git" [Param "add", File annexedfile] git "add" [annexedfile] @? "git add of edited file failed"
@? "git add of edited file failed"
if precommit if precommit
then git_annex "pre-commit" [] then git_annex "pre-commit" []
@? "pre-commit failed" @? "pre-commit failed"
else boolSystem "git" [Param "commit", Param "-q", Param "-m", Param "contentchanged"] else git "commit" ["-q", "-m", "contentchanged"]
@? "git commit of edited file failed" @? "git commit of edited file failed"
runchecks [checkregularfile, checkwritable] annexedfile runchecks [checkregularfile, checkwritable] annexedfile
c <- readFile annexedfile c <- readFile annexedfile
@ -822,7 +817,7 @@ test_partial_commit = intmpclonerepo $ do
annexed_present annexedfile annexed_present annexedfile
git_annex "unlock" [annexedfile] @? "unlock failed" git_annex "unlock" [annexedfile] @? "unlock failed"
changecontent annexedfile changecontent annexedfile
boolSystem "git" [Param "commit", Param "-q", Param "-m", Param "test", File annexedfile] git "commit" ["-q", "-m", "test", annexedfile]
@? "partial commit of unlocked file should be allowed" @? "partial commit of unlocked file should be allowed"
test_fix :: Assertion test_fix :: Assertion
@ -835,8 +830,7 @@ test_fix = intmpclonerepo $ unlessM (hasUnlockedFiles <$> getTestMode) $ do
git_annex "fix" [annexedfile] @? "fix of present file failed" git_annex "fix" [annexedfile] @? "fix of present file failed"
annexed_present annexedfile annexed_present annexedfile
createDirectory subdir createDirectory subdir
boolSystem "git" [Param "mv", File annexedfile, File subdir] git "mv" [annexedfile, subdir] @? "git mv failed"
@? "git mv failed"
git_annex "fix" [newfile] @? "fix of moved file failed" git_annex "fix" [newfile] @? "fix of moved file failed"
runchecks [checklink, checkunwritable] newfile runchecks [checklink, checkunwritable] newfile
c <- readFile newfile c <- readFile newfile
@ -973,16 +967,16 @@ test_unused = intmpclonerepo $ do
annexedfilekey <- getKey backendSHA256E annexedfile annexedfilekey <- getKey backendSHA256E annexedfile
sha1annexedfilekey <- getKey backendSHA1 sha1annexedfile sha1annexedfilekey <- getKey backendSHA1 sha1annexedfile
checkunused [] "after get" checkunused [] "after get"
boolSystem "git" [Param "rm", Param "-fq", File annexedfile] @? "git rm failed" git "rm" ["-fq", annexedfile] @? "git rm failed"
checkunused [] "after rm" checkunused [] "after rm"
-- commit the rm, and when on an adjusted branch, sync it back to -- commit the rm, and when on an adjusted branch, sync it back to
-- the master branch -- the master branch
git_annex "sync" ["--no-push", "--no-pull"] @? "git-annex sync failed" git_annex "sync" ["--no-push", "--no-pull"] @? "git-annex sync failed"
checkunused [] "after commit" checkunused [] "after commit"
-- unused checks origin/master; once it's gone it is really unused -- unused checks origin/master; once it's gone it is really unused
boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "git remote rm origin failed" git "remote" ["rm", "origin"] @? "git remote rm origin failed"
checkunused [annexedfilekey] "after origin branches are gone" checkunused [annexedfilekey] "after origin branches are gone"
boolSystem "git" [Param "rm", Param "-fq", File sha1annexedfile] @? "git rm failed" git "rm" ["-fq", sha1annexedfile] @? "git rm failed"
git_annex "sync" ["--no-push", "--no-pull"] @? "git-annex sync failed" git_annex "sync" ["--no-push", "--no-pull"] @? "git-annex sync failed"
checkunused [annexedfilekey, sha1annexedfilekey] "after rm sha1annexedfile" checkunused [annexedfilekey, sha1annexedfilekey] "after rm sha1annexedfile"
@ -1006,7 +1000,7 @@ test_unused = intmpclonerepo $ do
git_annex "add" ["unusedfile"] @? "add of unusedfile failed" git_annex "add" ["unusedfile"] @? "add of unusedfile failed"
unusedfilekey <- getKey backendSHA256E "unusedfile" unusedfilekey <- getKey backendSHA256E "unusedfile"
renameFile "unusedfile" "unusedunstagedfile" renameFile "unusedfile" "unusedunstagedfile"
boolSystem "git" [Param "rm", Param "-qf", File "unusedfile"] @? "git rm failed" git "rm" ["-qf", "unusedfile"] @? "git rm failed"
checkunused [] "with unstaged link" checkunused [] "with unstaged link"
removeFile "unusedunstagedfile" removeFile "unusedunstagedfile"
checkunused [unusedfilekey] "with renamed link deleted" checkunused [unusedfilekey] "with renamed link deleted"
@ -1015,17 +1009,17 @@ test_unused = intmpclonerepo $ do
-- manually -- manually
writecontent "unusedfile" "unusedcontent" writecontent "unusedfile" "unusedcontent"
git_annex "add" ["unusedfile"] @? "add of unusedfile failed" git_annex "add" ["unusedfile"] @? "add of unusedfile failed"
boolSystem "git" [Param "add", File "unusedfile"] @? "git add failed" git "add" ["unusedfile"] @? "git add failed"
unusedfilekey' <- getKey backendSHA256E "unusedfile" unusedfilekey' <- getKey backendSHA256E "unusedfile"
checkunused [] "with staged deleted link" checkunused [] "with staged deleted link"
boolSystem "git" [Param "rm", Param "-qf", File "unusedfile"] @? "git rm failed" git "rm" ["-qf", "unusedfile"] @? "git rm failed"
checkunused [unusedfilekey'] "with staged link deleted" checkunused [unusedfilekey'] "with staged link deleted"
-- unused used to false positive on symlinks that were -- unused used to false positive on symlinks that were
-- deleted or modified manually, but not staged as such -- deleted or modified manually, but not staged as such
writecontent "unusedfile" "unusedcontent" writecontent "unusedfile" "unusedcontent"
git_annex "add" ["unusedfile"] @? "add of unusedfile failed" git_annex "add" ["unusedfile"] @? "add of unusedfile failed"
boolSystem "git" [Param "add", File "unusedfile"] @? "git add failed" git "add" ["unusedfile"] @? "git add failed"
checkunused [] "with staged file" checkunused [] "with staged file"
removeFile "unusedfile" removeFile "unusedfile"
checkunused [] "with staged deleted file" checkunused [] "with staged deleted file"
@ -1036,11 +1030,11 @@ test_unused = intmpclonerepo $ do
whenM (hasUnlockedFiles <$> getTestMode) $ do whenM (hasUnlockedFiles <$> getTestMode) $ do
let f = "unlockedfile" let f = "unlockedfile"
writecontent f "unlockedcontent1" writecontent f "unlockedcontent1"
boolSystem "git" [Param "add", File "unlockedfile"] @? "git add failed" git "add" ["unlockedfile"] @? "git add failed"
checkunused [] "with unlocked file before modification" checkunused [] "with unlocked file before modification"
writecontent f "unlockedcontent2" writecontent f "unlockedcontent2"
checkunused [] "with unlocked file after modification" checkunused [] "with unlocked file after modification"
not <$> boolSystem "git" [Param "diff", Param "--quiet", File f] @? "git diff did not show changes to unlocked file" git_shouldfail "diff" ["--quiet", f] @? "git diff did not show changes to unlocked file"
-- still nothing unused because one version is in the index -- still nothing unused because one version is in the index
-- and the other is in the work tree -- and the other is in the work tree
checkunused [] "with unlocked file after git diff" checkunused [] "with unlocked file after git diff"
@ -1133,8 +1127,7 @@ test_concurrent_get_of_dup_key_regression = intmpclonerepo $ do
makedup f = do makedup f = do
Utility.CopyFile.copyFileExternal Utility.CopyFile.CopyAllMetaData annexedfile f Utility.CopyFile.copyFileExternal Utility.CopyFile.CopyAllMetaData annexedfile f
@? "copying annexed file failed" @? "copying annexed file failed"
boolSystem "git" [Param "add", File f] git "add" [f] @? "git add failed"
@? "git add failed"
{- Regression test for union merge bug fixed in {- Regression test for union merge bug fixed in
- 0214e0fb175a608a49b812d81b4632c081f63027 -} - 0214e0fb175a608a49b812d81b4632c081f63027 -}
@ -1146,13 +1139,13 @@ test_union_merge_regression =
withtmpclonerepo $ \r3 -> do withtmpclonerepo $ \r3 -> do
forM_ [r1, r2, r3] $ \r -> indir r $ do forM_ [r1, r2, r3] $ \r -> indir r $ do
when (r /= r1) $ when (r /= r1) $
boolSystem "git" [Param "remote", Param "add", Param "r1", File ("../../" ++ r1)] @? "remote add" git "remote" ["add", "r1", "../../" ++ r1] @? "remote add"
when (r /= r2) $ when (r /= r2) $
boolSystem "git" [Param "remote", Param "add", Param "r2", File ("../../" ++ r2)] @? "remote add" git "remote" ["add", "r2", "../../" ++ r2] @? "remote add"
when (r /= r3) $ when (r /= r3) $
boolSystem "git" [Param "remote", Param "add", Param "r3", File ("../../" ++ r3)] @? "remote add" git "remote" ["add", "r3", "../../" ++ r3] @? "remote add"
git_annex "get" [annexedfile] @? "get failed" git_annex "get" [annexedfile] @? "get failed"
boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "remote rm" git "remote" ["rm", "origin"] @? "remote rm"
forM_ [r3, r2, r1] $ \r -> indir r $ forM_ [r3, r2, r1] $ \r -> indir r $
git_annex "sync" [] @? ("sync failed in " ++ r) git_annex "sync" [] @? ("sync failed in " ++ r)
forM_ [r3, r2] $ \r -> indir r $ forM_ [r3, r2] $ \r -> indir r $
@ -1366,12 +1359,11 @@ test_nonannexed_file_conflict_resolution = do
indir r2 $ do indir r2 $ do
disconnectOrigin disconnectOrigin
writecontent conflictor nonannexed_content writecontent conflictor nonannexed_content
boolSystem "git" git "config"
[ Param "config" [ "annex.largefiles"
, Param "annex.largefiles" , "exclude=" ++ ingitfile ++ " and exclude=" ++ conflictor
, Param ("exclude=" ++ ingitfile ++ " and exclude=" ++ conflictor)
] @? "git config annex.largefiles failed" ] @? "git config annex.largefiles failed"
boolSystem "git" [Param "add", File conflictor] @? "git add conflictor failed" git "add" [conflictor] @? "git add conflictor failed"
git_annex "sync" [] @? "sync failed in r2" git_annex "sync" [] @? "sync failed in r2"
pair r1 r2 pair r1 r2
let l = if inr1 then [r1, r2] else [r2, r1] let l = if inr1 then [r1, r2] else [r2, r1]
@ -1417,7 +1409,7 @@ test_nonannexed_symlink_conflict_resolution = do
indir r2 $ do indir r2 $ do
disconnectOrigin disconnectOrigin
createSymbolicLink symlinktarget "conflictor" createSymbolicLink symlinktarget "conflictor"
boolSystem "git" [Param "add", File conflictor] @? "git add conflictor failed" git "add" [conflictor] @? "git add conflictor failed"
git_annex "sync" [] @? "sync failed in r2" git_annex "sync" [] @? "sync failed in r2"
pair r1 r2 pair r1 r2
let l = if inr1 then [r1, r2] else [r2, r1] let l = if inr1 then [r1, r2] else [r2, r1]
@ -1591,16 +1583,16 @@ test_adjusted_branch_subtree_regression =
writecontent "a/b/x/y" "foo" writecontent "a/b/x/y" "foo"
git_annex "add" ["a/b/x"] @? "add a/b/x failed" git_annex "add" ["a/b/x"] @? "add a/b/x failed"
git_annex "sync" [] @? "sync failed" git_annex "sync" [] @? "sync failed"
boolSystem "git" [Param "checkout", Param origbranch] @? "git checkout failed" git "checkout" [origbranch] @? "git checkout failed"
doesFileExist "a/b/x/y" @? ("a/b/x/y missing from master after adjusted branch sync") doesFileExist "a/b/x/y" @? ("a/b/x/y missing from master after adjusted branch sync")
{- Set up repos as remotes of each other. -} {- Set up repos as remotes of each other. -}
pair :: FilePath -> FilePath -> Assertion pair :: FilePath -> FilePath -> Assertion
pair r1 r2 = forM_ [r1, r2] $ \r -> indir r $ do pair r1 r2 = forM_ [r1, r2] $ \r -> indir r $ do
when (r /= r1) $ when (r /= r1) $
boolSystem "git" [Param "remote", Param "add", Param "r1", File ("../../" ++ r1)] @? "remote add" git "remote" ["add", "r1", "../../" ++ r1] @? "remote add"
when (r /= r2) $ when (r /= r2) $
boolSystem "git" [Param "remote", Param "add", Param "r2", File ("../../" ++ r2)] @? "remote add" git "remote" ["add", "r2", "../../" ++ r2] @? "remote add"
test_map :: Assertion test_map :: Assertion
test_map = intmpclonerepo $ do test_map = intmpclonerepo $ do
@ -1620,7 +1612,7 @@ test_uninit = intmpclonerepo $ do
test_uninit_inbranch :: Assertion test_uninit_inbranch :: Assertion
test_uninit_inbranch = intmpclonerepo $ do test_uninit_inbranch = intmpclonerepo $ do
boolSystem "git" [Param "checkout", Param "git-annex"] @? "git checkout git-annex" git "checkout" ["git-annex"] @? "git checkout git-annex"
git_annex_shouldfail "uninit" [] @? "uninit failed to fail when git-annex branch was checked out" git_annex_shouldfail "uninit" [] @? "uninit failed to fail when git-annex branch was checked out"
test_upgrade :: Assertion test_upgrade :: Assertion
@ -1663,7 +1655,7 @@ test_hook_remote = intmpclonerepo $ do
where where
dir = "dir" dir = "dir"
loc = dir ++ "/$ANNEX_KEY" loc = dir ++ "/$ANNEX_KEY"
git_config k v = boolSystem "git" [Param "config", Param k, Param v] git_config k v = git "config" [k, v]
@? "git config failed" @? "git config failed"
#else #else
-- this test doesn't work in Windows TODO -- this test doesn't work in Windows TODO
@ -1741,7 +1733,7 @@ test_crypto = do
@? "test harness self-test failed" @? "test harness self-test failed"
void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ do void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ do
createDirectory "dir" createDirectory "dir"
let a cmd = git_annex cmd $ let initps =
[ "foo" [ "foo"
, "type=directory" , "type=directory"
, "encryption=" ++ scheme , "encryption=" ++ scheme
@ -1750,10 +1742,10 @@ test_crypto = do
] ++ if scheme `elem` ["hybrid","pubkey"] ] ++ if scheme `elem` ["hybrid","pubkey"]
then ["keyid=" ++ Utility.Gpg.testKeyId] then ["keyid=" ++ Utility.Gpg.testKeyId]
else [] else []
a "initremote" @? "initremote failed" git_annex "initremote" initps @? "initremote failed"
not <$> a "initremote" @? "initremote failed to fail when run twice in a row" git_annex_shouldfail "initremote" initps @? "initremote failed to fail when run twice in a row"
a "enableremote" @? "enableremote failed" git_annex "enableremote" initps @? "enableremote failed"
a "enableremote" @? "enableremote failed when run twice in a row" git_annex "enableremote" initps @? "enableremote failed when run twice in a row"
git_annex "get" [annexedfile] @? "get of file failed" git_annex "get" [annexedfile] @? "get of file failed"
annexed_present annexedfile annexed_present annexedfile
git_annex "copy" [annexedfile, "--to", "foo"] @? "copy --to encrypted remote failed" git_annex "copy" [annexedfile, "--to", "foo"] @? "copy --to encrypted remote failed"
@ -1879,7 +1871,7 @@ test_export_import = intmpclonerepo $ do
-- resolving import conflict -- resolving import conflict
git_annex "import" [origbranch, "--from", "foo"] @? "import from dir failed" git_annex "import" [origbranch, "--from", "foo"] @? "import from dir failed"
not <$> boolSystem "git" [Param "merge", Param "foo/master", Param "-mmerge"] @? "git merge of conflict failed to exit nonzero" git_shouldfail "merge" ["foo/master", "-mmerge"] @? "git merge of conflict failed to exit nonzero"
removeWhenExistsWith R.removeLink (toRawFilePath "import") removeWhenExistsWith R.removeLink (toRawFilePath "import")
writecontent "import" (content "newimport3") writecontent "import" (content "newimport3")
git_annex "add" ["import"] @? "add of import failed" git_annex "add" ["import"] @? "add of import failed"
@ -1904,10 +1896,8 @@ test_export_import_subdir = intmpclonerepo $ do
annexed_present annexedfile annexed_present annexedfile
createDirectory subdir createDirectory subdir
boolSystem "git" [Param "mv", File annexedfile, File subannexedfile] git "mv" [annexedfile, subannexedfile] @? "git mv failed"
@? "git mv failed" git "commit" ["-m", "moved"] @? "git commit failed"
boolSystem "git" [Param "commit", Param "-m", Param "moved"]
@? "git commit failed"
-- When on an adjusted branch, this updates the master branch -- When on an adjusted branch, this updates the master branch
-- to match it, which is necessary since the master branch is going -- to match it, which is necessary since the master branch is going

71
Test/Framework.hs
View file

@ -40,26 +40,48 @@ import qualified Annex.Path
import qualified Annex.Action import qualified Annex.Action
import qualified Annex.AdjustedBranch import qualified Annex.AdjustedBranch
import qualified Utility.Process import qualified Utility.Process
import qualified Utility.Process.Transcript
import qualified Utility.Env import qualified Utility.Env
import qualified Utility.Env.Set import qualified Utility.Env.Set
import qualified Utility.Exception import qualified Utility.Exception
import qualified Utility.ThreadScheduler import qualified Utility.ThreadScheduler
import qualified Utility.Tmp.Dir import qualified Utility.Tmp.Dir
import qualified Utility.Metered import qualified Utility.Metered
import qualified Utility.SafeCommand
import qualified Command.Uninit import qualified Command.Uninit
-- Run a process. The output and stderr is captured, and is only
-- displayed if the process does not return the expected value.
-- Returns true if the process returned the expected value.
testProcess :: String -> [String] -> Bool -> IO Bool
testProcess command params expectedret = do
(transcript, ret) <- Utility.Process.Transcript.processTranscript command params Nothing
if ret == expectedret
then return True
else do
hPutStrLn stderr transcript
return False
-- Run git. (Do not use to run git-annex as the one being tested
-- may not be in path.)
git :: String -> [String] -> IO Bool
git command params = testProcess "git" (command:params) True
-- For when git is expected to fail.
git_shouldfail :: String -> [String] -> IO Bool
git_shouldfail command params = testProcess "git" (command:params) False
-- Run git-annex. -- Run git-annex.
git_annex :: String -> [String] -> IO Bool git_annex :: String -> [String] -> IO Bool
git_annex command params = do git_annex command params = do
pp <- Annex.Path.programPath pp <- Annex.Path.programPath
Utility.SafeCommand.boolSystem pp $ testProcess pp (command:params) True
map Utility.SafeCommand.Param (command:params)
-- For when git-annex is expected to fail. -- For when git-annex is expected to fail.
-- Run with -q to squelch error.
git_annex_shouldfail :: String -> [String] -> IO Bool git_annex_shouldfail :: String -> [String] -> IO Bool
git_annex_shouldfail command params = not <$> git_annex command ("-q":params) git_annex_shouldfail command params = do
pp <- Annex.Path.programPath
-- Run with -q to squelch error.
testProcess pp (command:"-q":params) False
{- Runs git-annex and returns its output. -} {- Runs git-annex and returns its output. -}
git_annex_output :: String -> [String] -> IO String git_annex_output :: String -> [String] -> IO String
@ -96,7 +118,7 @@ with_ssh_origin cloner a = cloner $ do
origindir <- absPath . Git.Types.fromConfigValue origindir <- absPath . Git.Types.fromConfigValue
=<< annexeval (Config.getConfig k v) =<< annexeval (Config.getConfig k v)
let originurl = "localhost:" ++ fromRawFilePath origindir let originurl = "localhost:" ++ fromRawFilePath origindir
boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed" git "config" [config, originurl] @? "git config failed"
a a
where where
config = "remote.origin.url" config = "remote.origin.url"
@ -135,7 +157,7 @@ withtmpclonerepo' cfg a = do
throwM e throwM e
disconnectOrigin :: Assertion disconnectOrigin :: Assertion
disconnectOrigin = boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "remote rm" disconnectOrigin = git "remote" ["rm", "origin"] @? "remote rm"
withgitrepo :: (FilePath -> Assertion) -> Assertion withgitrepo :: (FilePath -> Assertion) -> Assertion
withgitrepo a = do withgitrepo a = do
@ -163,7 +185,7 @@ setuprepo :: FilePath -> IO FilePath
setuprepo dir = do setuprepo dir = do
cleanup dir cleanup dir
ensuretmpdir ensuretmpdir
boolSystem "git" [Param "init", Param "-q", File dir] @? "git init failed" git "init" ["-q", dir] @? "git init failed"
configrepo dir configrepo dir
return dir return dir
@ -184,14 +206,13 @@ clonerepo old new cfg = do
cleanup new cleanup new
ensuretmpdir ensuretmpdir
let cloneparams = catMaybes let cloneparams = catMaybes
[ Just $ Param "clone" [ Just "-q"
, Just $ Param "-q" , if bareClone cfg then Just "--bare" else Nothing
, if bareClone cfg then Just (Param "--bare") else Nothing , if sharedClone cfg then Just "--shared" else Nothing
, if sharedClone cfg then Just (Param "--shared") else Nothing , Just old
, Just $ File old , Just new
, Just $ File new
] ]
boolSystem "git" cloneparams @? "git clone failed" git "clone" cloneparams @? "git clone failed"
configrepo new configrepo new
indir new $ do indir new $ do
ver <- annexVersion <$> getTestMode ver <- annexVersion <$> getTestMode
@ -204,16 +225,16 @@ clonerepo old new cfg = do
configrepo :: FilePath -> IO () configrepo :: FilePath -> IO ()
configrepo dir = indir dir $ do configrepo dir = indir dir $ do
-- ensure git is set up to let commits happen -- ensure git is set up to let commits happen
boolSystem "git" [Param "config", Param "user.name", Param "Test User"] @? "git config failed" git "config" ["user.name", "Test User"]
boolSystem "git" [Param "config", Param "user.email", Param "test@example.com"] @? "git config failed" @? "git config failed"
git "config" ["user.email", "test@example.com"]
@? "git config failed"
-- avoid signed commits by test suite -- avoid signed commits by test suite
boolSystem "git" [Param "config", Param "commit.gpgsign", Param "false"] @? "git config failed" git "config" ["commit.gpgsign", "false"]
@? "git config failed"
-- tell git-annex to not annex the ingitfile -- tell git-annex to not annex the ingitfile
boolSystem "git" git "config" ["annex.largefiles", "exclude=" ++ ingitfile]
[ Param "config" @? "git config annex.largefiles failed"
, Param "annex.largefiles"
, Param ("exclude=" ++ ingitfile)
] @? "git config annex.largefiles failed"
ensuretmpdir :: IO () ensuretmpdir :: IO ()
ensuretmpdir = do ensuretmpdir = do
@ -396,7 +417,7 @@ unannexed = runchecks [checkregularfile, checkcontent, checkwritable]
add_annex :: FilePath -> IO Bool add_annex :: FilePath -> IO Bool
add_annex f = ifM (unlockedFiles <$> getTestMode) add_annex f = ifM (unlockedFiles <$> getTestMode)
( boolSystem "git" [Param "add", File f] ( git "add" [f]
, git_annex "add" [f] , git_annex "add" [f]
) )
@ -471,7 +492,7 @@ setupTestMode :: IO ()
setupTestMode = do setupTestMode = do
testmode <- getTestMode testmode <- getTestMode
when (adjustedUnlockedBranch testmode) $ do when (adjustedUnlockedBranch testmode) $ do
boolSystem "git" [Param "commit", Param "--allow-empty", Param "-m", Param "empty"] @? "git commit failed" git "commit" ["--allow-empty", "-m", "empty"] @? "git commit failed"
git_annex "adjust" ["--unlock"] @? "git annex adjust failed" git_annex "adjust" ["--unlock"] @? "git annex adjust failed"
changeToTmpDir :: FilePath -> IO () changeToTmpDir :: FilePath -> IO ()