Made the test suite significantly less noisy

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.

diff --git a/CHANGELOG b/CHANGELOG
index b654e3585761e4e8a61caf357e664e8ad755e8c9..4402056e2117821860729363718dec9c66a24e91 100644 (file)
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -22,6 +22,8 @@ git-annex (8.20201117) UNRELEASED; urgency=medium
     Thanks, Kyle Meyer.
   * upgrade: Support an edge case upgrading a v5 direct mode repo
     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
 

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

diff --git a/Test/Framework.hs b/Test/Framework.hs
index c369daf5e25a22d741fc285bd9e93b7e6d8d1206..634d3ba8c07749b0c18f956af74c95ca5e9dd7be 100644 (file)
--- a/Test/Framework.hs
+++ b/Test/Framework.hs
@@ -40,26 +40,48 @@ import qualified Annex.Path
 import qualified Annex.Action
 import qualified Annex.AdjustedBranch
 import qualified Utility.Process
+import qualified Utility.Process.Transcript
 import qualified Utility.Env
 import qualified Utility.Env.Set
 import qualified Utility.Exception
 import qualified Utility.ThreadScheduler
 import qualified Utility.Tmp.Dir
 import qualified Utility.Metered
-import qualified Utility.SafeCommand
 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.
 git_annex :: String -> [String] -> IO Bool
 git_annex command params = do
        pp <- Annex.Path.programPath
-       Utility.SafeCommand.boolSystem pp $
-               map Utility.SafeCommand.Param (command:params)
+       testProcess pp (command:params) True
 
 -- For when git-annex is expected to fail.
--- Run with -q to squelch error.
 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. -}
 git_annex_output :: String -> [String] -> IO String
@@ -96,7 +118,7 @@ with_ssh_origin cloner a = cloner $ do
        origindir <- absPath . Git.Types.fromConfigValue
                =<< annexeval (Config.getConfig k v)
        let originurl = "localhost:" ++ fromRawFilePath origindir
-       boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed"
+       git "config" [config, originurl] @? "git config failed"
        a
   where
        config = "remote.origin.url"
@@ -135,7 +157,7 @@ withtmpclonerepo' cfg a = do
                        throwM e
 
 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 a = do
@@ -163,7 +185,7 @@ setuprepo :: FilePath -> IO FilePath
 setuprepo dir = do
        cleanup dir
        ensuretmpdir
-       boolSystem "git" [Param "init", Param "-q", File dir] @? "git init failed"
+       git "init" ["-q", dir] @? "git init failed"
        configrepo dir
        return dir
 
@@ -184,14 +206,13 @@ clonerepo old new cfg = do
        cleanup new
        ensuretmpdir
        let cloneparams = catMaybes
-               [ Just $ Param "clone"
-               , Just $ Param "-q"
-               , if bareClone cfg then Just (Param "--bare") else Nothing
-               , if sharedClone cfg then Just (Param "--shared") else Nothing
-               , Just $ File old
-               , Just $ File new
+               [ Just "-q"
+               , if bareClone cfg then Just "--bare" else Nothing
+               , if sharedClone cfg then Just "--shared" else Nothing
+               , Just old
+               , Just new
                ]
-       boolSystem "git" cloneparams @? "git clone failed"
+       git "clone" cloneparams @? "git clone failed"
        configrepo new
        indir new $ do
                ver <- annexVersion <$> getTestMode
@@ -204,16 +225,16 @@ clonerepo old new cfg = do
 configrepo :: FilePath -> IO ()
 configrepo dir = indir dir $ do
        -- ensure git is set up to let commits happen
-       boolSystem "git" [Param "config", Param "user.name", Param "Test User"] @? "git config failed"
-       boolSystem "git" [Param "config", Param "user.email", Param "test@example.com"] @? "git config failed"
+       git "config" ["user.name", "Test User"]
+               @? "git config failed"
+       git "config" ["user.email", "test@example.com"]
+               @? "git config failed"
        -- 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
-       boolSystem "git"
-               [ Param "config"
-               , Param "annex.largefiles"
-               , Param ("exclude=" ++ ingitfile)
-               ] @? "git config annex.largefiles failed"
+       git "config" ["annex.largefiles", "exclude=" ++ ingitfile]
+               @? "git config annex.largefiles failed"
 
 ensuretmpdir :: IO ()
 ensuretmpdir = do
@@ -396,7 +417,7 @@ unannexed = runchecks [checkregularfile, checkcontent, checkwritable]
 
 add_annex :: FilePath -> IO Bool
 add_annex f = ifM (unlockedFiles <$> getTestMode)
-       ( boolSystem "git" [Param "add", File f]
+       ( git "add" [f]
        , git_annex "add" [f]
        )
 
@@ -471,7 +492,7 @@ setupTestMode :: IO ()
 setupTestMode = do
        testmode <- getTestMode
        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"
 
 changeToTmpDir :: FilePath -> IO ()