diff options
Diffstat (limited to 'Test.hs')
| -rw-r--r-- | Test.hs | 634 |
1 files changed, 393 insertions, 241 deletions
@@ -36,6 +36,7 @@ import qualified Types.KeySource import qualified Types.Backend import qualified Types.TrustLevel import qualified Types +import qualified Logs import qualified Logs.UUIDBased import qualified Logs.Trust import qualified Logs.Remote @@ -58,11 +59,16 @@ import qualified Utility.Process import qualified Utility.Misc import qualified Utility.InodeCache import qualified Utility.Env -import qualified Utility.Gpg import qualified Utility.Matcher import qualified Utility.Exception +import qualified Utility.Hash +import qualified Utility.Scheduled +import qualified Utility.HumanTime #ifndef mingw32_HOST_OS import qualified GitAnnex +import qualified Remote.Helper.Encryptable +import qualified Types.Crypto +import qualified Utility.Gpg #endif type TestEnv = M.Map String String @@ -91,8 +97,10 @@ properties = testGroup "QuickCheck" , testProperty "prop_idempotent_deencode" Utility.Format.prop_idempotent_deencode , testProperty "prop_idempotent_fileKey" Locations.prop_idempotent_fileKey , testProperty "prop_idempotent_key_encode" Types.Key.prop_idempotent_key_encode + , testProperty "prop_idempotent_key_decode" Types.Key.prop_idempotent_key_decode , testProperty "prop_idempotent_shellEscape" Utility.SafeCommand.prop_idempotent_shellEscape , testProperty "prop_idempotent_shellEscape_multiword" Utility.SafeCommand.prop_idempotent_shellEscape_multiword + , testProperty "prop_logs_sane" Logs.prop_logs_sane , testProperty "prop_idempotent_configEscape" Logs.Remote.prop_idempotent_configEscape , testProperty "prop_parse_show_Config" Logs.Remote.prop_parse_show_Config , testProperty "prop_parentDir_basics" Utility.Path.prop_parentDir_basics @@ -110,6 +118,9 @@ properties = testGroup "QuickCheck" , testProperty "prop_parse_show_log" Logs.Presence.prop_parse_show_log , testProperty "prop_read_show_TrustLevel" Types.TrustLevel.prop_read_show_TrustLevel , testProperty "prop_parse_show_TrustLog" Logs.Trust.prop_parse_show_TrustLog + , testProperty "prop_hashes_stable" Utility.Hash.prop_hashes_stable + , testProperty "prop_schedule_roundtrips" Utility.Scheduled.prop_schedule_roundtrips + , testProperty "prop_duration_roundtrips" Utility.HumanTime.prop_duration_roundtrips ] unitTests :: TestEnv -> String -> TestTree @@ -119,30 +130,39 @@ unitTests env note = testGroup ("Unit Tests " ++ note) , check "add" test_add , check "add sha1dup" test_add_sha1dup , check "add subdirs" test_add_subdirs - {- , check "reinject" test_reinject - , check "unannex" test_unannex - , check "drop" test_drop + , check "unannex (no copy)" test_unannex_nocopy + , check "unannex (with copy)" test_unannex_withcopy + , check "drop (no remote)" test_drop_noremote + , check "drop (with remote)" test_drop_withremote + , check "drop (untrusted remote)" test_drop_untrustedremote , check "get" test_get , check "move" test_move , check "copy" test_copy , check "lock" test_lock - , check "edit" test_edit + , check "edit (no pre-commit)" test_edit + , check "edit (pre-commit)" test_edit_precommit , check "fix" test_fix , check "trust" test_trust - , check "fsck" test_fsck + , check "fsck (basics)" test_fsck_basic + , check "fsck (bare)" test_fsck_bare + , check "fsck (local untrusted)" test_fsck_localuntrusted + , check "fsck (remote untrusted)" test_fsck_remoteuntrusted , check "migrate" test_migrate + , check "migrate (via gitattributes)" test_migrate_via_gitattributes , check" unused" test_unused , check "describe" test_describe , check "find" test_find , check "merge" test_merge - , check "status" test_status + , check "info" test_info , check "version" test_version , check "sync" test_sync , check "union merge regression" test_union_merge_regression , check "conflict resolution" test_conflict_resolution + , check "conflict_resolution (mixed directory and file)" test_mixed_conflict_resolution , check "map" test_map , check "uninit" test_uninit + , check "uninit (in git-annex branch)" test_uninit_inbranch , check "upgrade" test_upgrade , check "whereis" test_whereis , check "hook remote" test_hook_remote @@ -151,7 +171,6 @@ unitTests env note = testGroup ("Unit Tests " ++ note) , check "bup remote" test_bup_remote , check "crypto" test_crypto , check "preferred content" test_preferred_content - -} , check "global cleanup" test_global_cleanup ] where @@ -182,12 +201,21 @@ test_add env = inmainrepo env $ do git_annex env "add" [wormannexedfile, "--backend=WORM"] @? "add with WORM failed" annexed_present wormannexedfile checkbackend wormannexedfile backendWORM - boolSystem "git" [Params "rm --force -q", File wormannexedfile] @? "git rm failed" - writeFile ingitfile $ content ingitfile - boolSystem "git" [Param "add", File ingitfile] @? "git add failed" - boolSystem "git" [Params "commit -q -m commit"] @? "git commit failed" - git_annex env "add" [ingitfile] @? "add ingitfile should be no-op" - unannexed ingitfile + ifM (annexeval Config.isDirect) + ( do + boolSystem "rm" [Params "-f", File wormannexedfile] @? "rm failed" + writeFile ingitfile $ content ingitfile + not <$> boolSystem "git" [Param "add", File ingitfile] @? "git add failed to fail in direct mode" + boolSystem "rm" [Params "-f", File ingitfile] @? "rm failed" + git_annex env "sync" [] @? "sync failed" + , do + boolSystem "git" [Params "rm --force -q", File wormannexedfile] @? "git rm failed" + writeFile ingitfile $ content ingitfile + boolSystem "git" [Param "add", File ingitfile] @? "git add failed" + boolSystem "git" [Params "commit -q -m commit"] @? "git commit failed" + git_annex env "add" [ingitfile] @? "add ingitfile should be no-op" + unannexed ingitfile + ) test_add_sha1dup :: TestEnv -> Assertion test_add_sha1dup env = intmpclonerepo env $ do @@ -209,8 +237,8 @@ test_add_subdirs env = intmpclonerepo env $ do git_annex env "add" [".." </> "dir2"] @? "add of ../subdir failed" #endif -test_reinject :: TestEnv -> Test -test_reinject env = "git-annex reinject/fromkey" ~: TestCase $ intmpclonerepoInDirect env $ do +test_reinject :: TestEnv -> Assertion +test_reinject env = intmpclonerepoInDirect env $ do git_annex env "drop" ["--force", sha1annexedfile] @? "drop failed" writeFile tmp $ content sha1annexedfile r <- annexeval $ Types.Backend.getKey backendSHA1 $ @@ -222,53 +250,57 @@ test_reinject env = "git-annex reinject/fromkey" ~: TestCase $ intmpclonerepoInD where tmp = "tmpfile" -test_unannex :: TestEnv -> Test -test_unannex env = "git-annex unannex" ~: TestList [nocopy, withcopy] - where - nocopy = "no content" ~: intmpclonerepo env $ do - annexed_notpresent annexedfile - git_annex env "unannex" [annexedfile] @? "unannex failed with no copy" - annexed_notpresent annexedfile - withcopy = "with content" ~: intmpclonerepo env $ do - git_annex env "get" [annexedfile] @? "get failed" - annexed_present annexedfile - git_annex env "unannex" [annexedfile, sha1annexedfile] @? "unannex failed" - unannexed annexedfile - git_annex env "unannex" [annexedfile] @? "unannex failed on non-annexed file" - unannexed annexedfile +test_unannex_nocopy :: TestEnv -> Assertion +test_unannex_nocopy env = intmpclonerepo env $ do + annexed_notpresent annexedfile + git_annex env "unannex" [annexedfile] @? "unannex failed with no copy" + annexed_notpresent annexedfile + +test_unannex_withcopy :: TestEnv -> Assertion +test_unannex_withcopy env = intmpclonerepo env $ do + git_annex env "get" [annexedfile] @? "get failed" + annexed_present annexedfile + git_annex env "unannex" [annexedfile, sha1annexedfile] @? "unannex failed" + unannexed annexedfile + git_annex env "unannex" [annexedfile] @? "unannex failed on non-annexed file" + unannexed annexedfile + unlessM (annexeval Config.isDirect) $ do git_annex env "unannex" [ingitfile] @? "unannex ingitfile should be no-op" unannexed ingitfile -test_drop :: TestEnv -> Test -test_drop env = "git-annex drop" ~: TestList [noremote, withremote, untrustedremote] - where - noremote = "no remotes" ~: TestCase $ intmpclonerepo env $ do - git_annex env "get" [annexedfile] @? "get failed" - boolSystem "git" [Params "remote rm origin"] - @? "git remote rm origin failed" - not <$> git_annex env "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file" - annexed_present annexedfile - git_annex env "drop" ["--force", annexedfile] @? "drop --force failed" - annexed_notpresent annexedfile - git_annex env "drop" [annexedfile] @? "drop of dropped file failed" +test_drop_noremote :: TestEnv -> Assertion +test_drop_noremote env = intmpclonerepo env $ do + git_annex env "get" [annexedfile] @? "get failed" + boolSystem "git" [Params "remote rm origin"] + @? "git remote rm origin failed" + not <$> git_annex env "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file" + annexed_present annexedfile + git_annex env "drop" ["--force", annexedfile] @? "drop --force failed" + annexed_notpresent annexedfile + git_annex env "drop" [annexedfile] @? "drop of dropped file failed" + unlessM (annexeval Config.isDirect) $ do git_annex env "drop" [ingitfile] @? "drop ingitfile should be no-op" unannexed ingitfile - withremote = "with remote" ~: TestCase $ intmpclonerepo env $ do - git_annex env "get" [annexedfile] @? "get failed" - annexed_present annexedfile - git_annex env "drop" [annexedfile] @? "drop failed though origin has copy" - annexed_notpresent annexedfile - inmainrepo env $ annexed_present annexedfile - untrustedremote = "untrusted remote" ~: TestCase $ intmpclonerepo env $ do - git_annex env "untrust" ["origin"] @? "untrust of origin failed" - git_annex env "get" [annexedfile] @? "get failed" - annexed_present annexedfile - not <$> git_annex env "drop" [annexedfile] @? "drop wrongly suceeded with only an untrusted copy of the file" - annexed_present annexedfile - inmainrepo env $ annexed_present annexedfile - -test_get :: TestEnv -> Test -test_get env = "git-annex get" ~: TestCase $ intmpclonerepo env $ do + +test_drop_withremote :: TestEnv -> Assertion +test_drop_withremote env = intmpclonerepo env $ do + git_annex env "get" [annexedfile] @? "get failed" + annexed_present annexedfile + git_annex env "drop" [annexedfile] @? "drop failed though origin has copy" + annexed_notpresent annexedfile + inmainrepo env $ annexed_present annexedfile + +test_drop_untrustedremote :: TestEnv -> Assertion +test_drop_untruestedremote env = intmpclonerepo env $ do + git_annex env "untrust" ["origin"] @? "untrust of origin failed" + git_annex env "get" [annexedfile] @? "get failed" + annexed_present annexedfile + not <$> git_annex env "drop" [annexedfile] @? "drop wrongly suceeded with only an untrusted copy of the file" + annexed_present annexedfile + inmainrepo env $ annexed_present annexedfile + +test_get :: TestEnv -> Assertion +test_get env = intmpclonerepo env $ do inmainrepo env $ annexed_present annexedfile annexed_notpresent annexedfile git_annex env "get" [annexedfile] @? "get of file failed" @@ -277,14 +309,15 @@ test_get env = "git-annex get" ~: TestCase $ intmpclonerepo env $ do git_annex env "get" [annexedfile] @? "get of file already here failed" inmainrepo env $ annexed_present annexedfile annexed_present annexedfile - inmainrepo env $ unannexed ingitfile - unannexed ingitfile - git_annex env "get" [ingitfile] @? "get ingitfile should be no-op" - inmainrepo env $ unannexed ingitfile - unannexed ingitfile - -test_move :: TestEnv -> Test -test_move env = "git-annex move" ~: TestCase $ intmpclonerepo env $ do + unlessM (annexeval Config.isDirect) $ do + inmainrepo env $ unannexed ingitfile + unannexed ingitfile + git_annex env "get" [ingitfile] @? "get ingitfile should be no-op" + inmainrepo env $ unannexed ingitfile + unannexed ingitfile + +test_move :: TestEnv -> Assertion +test_move env = intmpclonerepo env $ do annexed_notpresent annexedfile inmainrepo env $ annexed_present annexedfile git_annex env "move" ["--from", "origin", annexedfile] @? "move --from of file failed" @@ -299,17 +332,18 @@ test_move env = "git-annex move" ~: TestCase $ intmpclonerepo env $ do git_annex env "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed" inmainrepo env $ annexed_present annexedfile annexed_notpresent annexedfile - unannexed ingitfile - inmainrepo env $ unannexed ingitfile - git_annex env "move" ["--to", "origin", ingitfile] @? "move of ingitfile should be no-op" - unannexed ingitfile - inmainrepo env $ unannexed ingitfile - git_annex env "move" ["--from", "origin", ingitfile] @? "move of ingitfile should be no-op" - unannexed ingitfile - inmainrepo env $ unannexed ingitfile - -test_copy :: TestEnv -> Test -test_copy env = "git-annex copy" ~: TestCase $ intmpclonerepo env $ do + unlessM (annexeval Config.isDirect) $ do + unannexed ingitfile + inmainrepo env $ unannexed ingitfile + git_annex env "move" ["--to", "origin", ingitfile] @? "move of ingitfile should be no-op" + unannexed ingitfile + inmainrepo env $ unannexed ingitfile + git_annex env "move" ["--from", "origin", ingitfile] @? "move of ingitfile should be no-op" + unannexed ingitfile + inmainrepo env $ unannexed ingitfile + +test_copy :: TestEnv -> Assertion +test_copy env = intmpclonerepo env $ do annexed_notpresent annexedfile inmainrepo env $ annexed_present annexedfile git_annex env "copy" ["--from", "origin", annexedfile] @? "copy --from of file failed" @@ -324,30 +358,31 @@ test_copy env = "git-annex copy" ~: TestCase $ intmpclonerepo env $ do git_annex env "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed" annexed_notpresent annexedfile inmainrepo env $ annexed_present annexedfile - unannexed ingitfile - inmainrepo env $ unannexed ingitfile - git_annex env "copy" ["--to", "origin", ingitfile] @? "copy of ingitfile should be no-op" - unannexed ingitfile - inmainrepo env $ unannexed ingitfile - git_annex env "copy" ["--from", "origin", ingitfile] @? "copy of ingitfile should be no-op" - checkregularfile ingitfile - checkcontent ingitfile - -test_preferred_content :: TestEnv -> Test -test_preferred_content env = "git-annex preferred-content" ~: TestCase $ intmpclonerepo env $ do + unlessM (annexeval Config.isDirect) $ do + unannexed ingitfile + inmainrepo env $ unannexed ingitfile + git_annex env "copy" ["--to", "origin", ingitfile] @? "copy of ingitfile should be no-op" + unannexed ingitfile + inmainrepo env $ unannexed ingitfile + git_annex env "copy" ["--from", "origin", ingitfile] @? "copy of ingitfile should be no-op" + checkregularfile ingitfile + checkcontent ingitfile + +test_preferred_content :: TestEnv -> Assertion +test_preferred_content env = intmpclonerepo env $ do annexed_notpresent annexedfile -- get --auto only looks at numcopies when preferred content is not -- set, and with 1 copy existing, does not get the file. git_annex env "get" ["--auto", annexedfile] @? "get --auto of file failed with default preferred content" annexed_notpresent annexedfile - git_annex env "content" [".", "standard"] @? "set expression to standard failed" + git_annex env "wanted" [".", "standard"] @? "set expression to standard failed" git_annex env "group" [".", "client"] @? "set group to standard failed" git_annex env "get" ["--auto", annexedfile] @? "get --auto of file failed for client" annexed_present annexedfile git_annex env "ungroup" [".", "client"] @? "ungroup failed" - git_annex env "content" [".", "standard"] @? "set expression to standard failed" + git_annex env "wanted" [".", "standard"] @? "set expression to standard failed" git_annex env "group" [".", "manual"] @? "set group to manual failed" -- drop --auto with manual leaves the file where it is git_annex env "drop" ["--auto", annexedfile] @? "drop --auto of file failed with manual preferred content" @@ -359,7 +394,7 @@ test_preferred_content env = "git-annex preferred-content" ~: TestCase $ intmpcl annexed_notpresent annexedfile git_annex env "ungroup" [".", "client"] @? "ungroup failed" - git_annex env "content" [".", "exclude=*"] @? "set expression to exclude=* failed" + git_annex env "wanted" [".", "exclude=*"] @? "set expression to exclude=* failed" git_annex env "get" [annexedfile] @? "get of file failed" annexed_present annexedfile git_annex env "drop" ["--auto", annexedfile] @? "drop --auto of file failed with exclude=*" @@ -367,8 +402,8 @@ test_preferred_content env = "git-annex preferred-content" ~: TestCase $ intmpcl git_annex env "get" ["--auto", annexedfile] @? "get --auto of file failed with exclude=*" annexed_notpresent annexedfile -test_lock :: TestEnv -> Test -test_lock env = "git-annex unlock/lock" ~: intmpclonerepoInDirect env $ do +test_lock :: TestEnv -> Assertion +test_lock env = intmpclonerepoInDirect env $ do -- regression test: unlock of not present file should skip it annexed_notpresent annexedfile not <$> git_annex env "unlock" [annexedfile] @? "unlock failed to fail with not present file" @@ -394,9 +429,14 @@ test_lock env = "git-annex unlock/lock" ~: intmpclonerepoInDirect env $ do r' <- git_annex env "drop" [annexedfile] not r' @? "drop wrongly succeeded with no known copy of modified file" -test_edit :: TestEnv -> Test -test_edit env = "git-annex edit/commit" ~: TestList [t False, t True] - where t precommit = TestCase $ intmpclonerepoInDirect env $ do +test_edit :: TestEnv -> Assertion +test_edit = test_edit' False + +test_edit_precommit :: TestEnv -> Assertion +test_edit_precommit = test_edit' True + +test_edit' :: Bool -> TestEnv -> Assertion +test_edit' precommit env = intmpclonerepoInDirect env $ do git_annex env "get" [annexedfile] @? "get of file failed" annexed_present annexedfile git_annex env "edit" [annexedfile] @? "edit failed" @@ -414,8 +454,8 @@ test_edit env = "git-annex edit/commit" ~: TestList [t False, t True] assertEqual "content of modified file" c (changedcontent annexedfile) not <$> git_annex env "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of modified file" -test_fix :: TestEnv -> Test -test_fix env = "git-annex fix" ~: intmpclonerepoInDirect env $ do +test_fix :: TestEnv -> Assertion +test_fix env = intmpclonerepoInDirect env $ do annexed_notpresent annexedfile git_annex env "fix" [annexedfile] @? "fix of not present failed" annexed_notpresent annexedfile @@ -434,8 +474,8 @@ test_fix env = "git-annex fix" ~: intmpclonerepoInDirect env $ do subdir = "s" newfile = subdir ++ "/" ++ annexedfile -test_trust :: TestEnv -> Test -test_trust env = "git-annex trust/untrust/semitrust/dead" ~: intmpclonerepo env $ do +test_trust :: TestEnv -> Assertion +test_trust env = intmpclonerepo env $ do git_annex env "trust" [repo] @? "trust failed" trustcheck Logs.Trust.Trusted "trusted 1" git_annex env "trust" [repo] @? "trust of trusted failed" @@ -461,33 +501,15 @@ test_trust env = "git-annex trust/untrust/semitrust/dead" ~: intmpclonerepo env return $ u `elem` l assertBool msg present -test_fsck :: TestEnv -> Test -test_fsck env = "git-annex fsck" ~: TestList [basicfsck, barefsck, withlocaluntrusted, withremoteuntrusted] +test_fsck_basic :: TestEnv -> Assertion +test_fsck_basic env = intmpclonerepo env $ do + git_annex env "fsck" [] @? "fsck failed" + boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed" + fsck_should_fail env "numcopies unsatisfied" + boolSystem "git" [Params "config annex.numcopies 1"] @? "git config failed" + corrupt env annexedfile + corrupt env sha1annexedfile where - basicfsck = TestCase $ intmpclonerepo env $ do - git_annex env "fsck" [] @? "fsck failed" - boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed" - fsck_should_fail "numcopies unsatisfied" - boolSystem "git" [Params "config annex.numcopies 1"] @? "git config failed" - corrupt annexedfile - corrupt sha1annexedfile - barefsck = TestCase $ intmpbareclonerepo env $ do - git_annex env "fsck" [] @? "fsck failed" - withlocaluntrusted = TestCase $ intmpclonerepo env $ do - git_annex env "get" [annexedfile] @? "get failed" - git_annex env "untrust" ["origin"] @? "untrust of origin repo failed" - git_annex env "untrust" ["."] @? "untrust of current repo failed" - fsck_should_fail "content only available in untrusted (current) repository" - git_annex env "trust" ["."] @? "trust of current repo failed" - git_annex env "fsck" [annexedfile] @? "fsck failed on file present in trusted repo" - withremoteuntrusted = TestCase $ intmpclonerepo env $ do - boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed" - git_annex env "get" [annexedfile] @? "get failed" - git_annex env "get" [sha1annexedfile] @? "get failed" - git_annex env "fsck" [] @? "fsck failed with numcopies=2 and 2 copies" - git_annex env "untrust" ["origin"] @? "untrust of origin failed" - fsck_should_fail "content not replicated to enough non-untrusted repositories" - corrupt f = do git_annex env "get" [f] @? "get of file failed" Utility.FileMode.allowWrite f @@ -497,12 +519,41 @@ test_fsck env = "git-annex fsck" ~: TestList [basicfsck, barefsck, withlocaluntr , not <$> git_annex env "fsck" [] @? "fsck failed to fail with corrupted file content" ) git_annex env "fsck" [] @? "fsck unexpectedly failed again; previous one did not fix problem with " ++ f - fsck_should_fail m = do - not <$> git_annex env "fsck" [] @? "fsck failed to fail with " ++ m -test_migrate :: TestEnv -> Test -test_migrate env = "git-annex migrate" ~: TestList [t False, t True] - where t usegitattributes = TestCase $ intmpclonerepoInDirect env $ do +test_fsck_bare :: TestEnv -> Assertion +test_fsck_bare env = intmpbareclonerepo env $ do + git_annex env "fsck" [] @? "fsck failed" + +test_fsck_localuntrusted :: TestEnv -> Assertion +test_fsck_localuntrusted env = intmpclonerepo env $ do + git_annex env "get" [annexedfile] @? "get failed" + git_annex env "untrust" ["origin"] @? "untrust of origin repo failed" + git_annex env "untrust" ["."] @? "untrust of current repo failed" + fsck_should_fail env "content only available in untrusted (current) repository" + git_annex env "trust" ["."] @? "trust of current repo failed" + git_annex env "fsck" [annexedfile] @? "fsck failed on file present in trusted repo" + +test_fsck_remoteuntrusted :: TestEnv -> Assertion +test_fsck_remoteuntrusted env = intmpclonerepo env $ do + boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed" + git_annex env "get" [annexedfile] @? "get failed" + git_annex env "get" [sha1annexedfile] @? "get failed" + git_annex env "fsck" [] @? "fsck failed with numcopies=2 and 2 copies" + git_annex env "untrust" ["origin"] @? "untrust of origin failed" + fsck_should_fail env "content not replicated to enough non-untrusted repositories" + +fsck_should_fail :: TestEnv -> String -> Assertion +fsck_should_fail env m = not <$> git_annex env "fsck" [] + @? "fsck failed to fail with " ++ m + +test_migrate :: TestEnv -> Assertion +test_migrate = test_migrate' False + +test_migrate_via_gitattributes :: TestEnv -> Assertion +test_migrate_via_gitattributes = test_migrate' True + +test_migrate' :: Bool -> TestEnv -> Assertion +test_migrate' usegitattributes env = intmpclonerepoInDirect env $ do annexed_notpresent annexedfile annexed_notpresent sha1annexedfile git_annex env "migrate" [annexedfile] @? "migrate of not present failed" @@ -539,9 +590,9 @@ test_migrate env = "git-annex migrate" ~: TestList [t False, t True] checkbackend annexedfile backendSHA256 checkbackend sha1annexedfile backendSHA256 -test_unused :: TestEnv -> Test +test_unused :: TestEnv -> Assertion -- This test is broken in direct mode -test_unused env = "git-annex unused/dropunused" ~: intmpclonerepoInDirect env $ do +test_unused env = intmpclonerepoInDirect env $ do -- keys have to be looked up before files are removed annexedfilekey <- annexeval $ findkey annexedfile sha1annexedfilekey <- annexeval $ findkey sha1annexedfile @@ -569,6 +620,37 @@ test_unused env = "git-annex unused/dropunused" ~: intmpclonerepoInDirect env $ checkunused [] "after dropunused" not <$> git_annex env "dropunused" ["--force", "10", "501"] @? "dropunused failed to fail on bogus numbers" + -- unused used to miss symlinks that were not staged and pointed + -- at annexed content, and think that content was unused + writeFile "unusedfile" "unusedcontent" + git_annex env "add" ["unusedfile"] @? "add of unusedfile failed" + unusedfilekey <- annexeval $ findkey "unusedfile" + renameFile "unusedfile" "unusedunstagedfile" + boolSystem "git" [Params "rm -qf", File "unusedfile"] @? "git rm failed" + checkunused [] "with unstaged link" + removeFile "unusedunstagedfile" + checkunused [unusedfilekey] "with unstaged link deleted" + + -- unused used to miss symlinks that were deleted or modified + -- manually, but commited as such. + writeFile "unusedfile" "unusedcontent" + git_annex env "add" ["unusedfile"] @? "add of unusedfile failed" + boolSystem "git" [Param "add", File "unusedfile"] @? "git add failed" + unusedfilekey' <- annexeval $ findkey "unusedfile" + checkunused [] "with staged deleted link" + boolSystem "git" [Params "rm -qf", File "unusedfile"] @? "git rm failed" + checkunused [unusedfilekey'] "with staged link deleted" + + -- unused used to miss symlinks that were deleted or modified + -- manually, but not staged as such. + writeFile "unusedfile" "unusedcontent" + git_annex env "add" ["unusedfile"] @? "add of unusedfile failed" + boolSystem "git" [Param "add", File "unusedfile"] @? "git add failed" + unusedfilekey'' <- annexeval $ findkey "unusedfile" + checkunused [] "with unstaged deleted link" + removeFile "unusedfile" + checkunused [unusedfilekey''] "with unstaged link deleted" + where checkunused expectedkeys desc = do git_annex env "unused" [] @? "unused failed" @@ -580,13 +662,13 @@ test_unused env = "git-annex unused/dropunused" ~: intmpclonerepoInDirect env $ r <- Backend.lookupFile f return $ fst $ fromJust r -test_describe :: TestEnv -> Test -test_describe env = "git-annex describe" ~: intmpclonerepo env $ do +test_describe :: TestEnv -> Assertion +test_describe env = intmpclonerepo env $ do git_annex env "describe" [".", "this repo"] @? "describe 1 failed" git_annex env "describe" ["origin", "origin repo"] @? "describe 2 failed" -test_find :: TestEnv -> Test -test_find env = "git-annex find" ~: intmpclonerepo env $ do +test_find :: TestEnv -> Assertion +test_find env = intmpclonerepo env $ do annexed_notpresent annexedfile git_annex_expectoutput env "find" [] [] git_annex env "get" [annexedfile] @? "get failed" @@ -608,23 +690,23 @@ test_find env = "git-annex find" ~: intmpclonerepo env $ do git_annex_expectoutput env "find" ["--include", "*", "--exclude", annexedfile, "--exclude", sha1annexedfile] ["dir/subfile"] git_annex_expectoutput env "find" ["--exclude", "*"] [] -test_merge :: TestEnv -> Test -test_merge env = "git-annex merge" ~: intmpclonerepo env $ do +test_merge :: TestEnv -> Assertion +test_merge env = intmpclonerepo env $ do git_annex env "merge" [] @? "merge failed" -test_status :: TestEnv -> Test -test_status env = "git-annex status" ~: intmpclonerepo env $ do - json <- git_annex_output env "status" ["--json"] +test_info :: TestEnv -> Assertion +test_info env = intmpclonerepo env $ do + json <- git_annex_output env "info" ["--json"] case Text.JSON.decodeStrict json :: Text.JSON.Result (Text.JSON.JSObject Text.JSON.JSValue) of Text.JSON.Ok _ -> return () Text.JSON.Error e -> assertFailure e -test_version :: TestEnv -> Test -test_version env = "git-annex version" ~: intmpclonerepo env $ do +test_version :: TestEnv -> Assertion +test_version env = intmpclonerepo env $ do git_annex env "version" [] @? "version failed" -test_sync :: TestEnv -> Test -test_sync env = "git-annex sync" ~: intmpclonerepo env $ do +test_sync :: TestEnv -> Assertion +test_sync env = intmpclonerepo env $ do git_annex env "sync" [] @? "sync failed" {- Regression test for bug fixed in - 7b0970b340d7faeb745c666146c7f701ec71808f, where in direct mode @@ -633,8 +715,8 @@ test_sync env = "git-annex sync" ~: intmpclonerepo env $ do {- Regression test for union merge bug fixed in - 0214e0fb175a608a49b812d81b4632c081f63027 -} -test_union_merge_regression :: TestEnv -> Test -test_union_merge_regression env = "union merge regression" ~: +test_union_merge_regression :: TestEnv -> Assertion +test_union_merge_regression env = {- We need 3 repos to see this bug. -} withtmpclonerepo env False $ \r1 -> do withtmpclonerepo env False $ \r2 -> do @@ -662,73 +744,100 @@ test_union_merge_regression env = "union merge regression" ~: {- Regression test for the automatic conflict resolution bug fixed - in f4ba19f2b8a76a1676da7bb5850baa40d9c388e2. -} -test_conflict_resolution :: TestEnv -> Test -test_conflict_resolution env = "automatic conflict resolution" ~: - withtmpclonerepo env False $ \r1 -> do +test_conflict_resolution :: TestEnv -> Assertion +test_conflict_resolution_movein_bug env = withtmpclonerepo env False $ \r1 -> do + withtmpclonerepo env False $ \r2 -> do + let rname r = if r == r1 then "r1" else "r2" + forM_ [r1, r2] $ \r -> indir env r $ do + {- Get all files, see check below. -} + git_annex env "get" [] @? "get failed" + pair env r1 r2 + forM_ [r1, r2] $ \r -> indir env r $ do + {- Set up a conflict. -} + let newcontent = content annexedfile ++ rname r + ifM (annexeval Config.isDirect) + ( writeFile annexedfile newcontent + , do + git_annex env "unlock" [annexedfile] @? "unlock failed" + writeFile annexedfile newcontent + ) + {- Sync twice in r1 so it gets the conflict resolution + - update from r2 -} + forM_ [r1, r2, r1] $ \r -> indir env r $ do + git_annex env "sync" ["--force"] @? "sync failed in " ++ rname r + {- After the sync, it should be possible to get all + - files. This includes both sides of the conflict, + - although the filenames are not easily predictable. + - + - The bug caused, in direct mode, one repo to + - be missing the content of the file that had + - been put in it. -} + forM_ [r1, r2] $ \r -> indir env r $ do + git_annex env "get" [] @? "unable to get all files after merge conflict resolution in " ++ rname r + +{- Check merge conflict resolution when one side is an annexed + - file, and the other is a directory. -} +test_mixed_conflict_resolution :: TestEnv -> Assertion +test_mixed_conflict_resolution env = do + check_mixed_conflict True + check_mixed_conflict False + where + check_mixed_conflict inr1 = withtmpclonerepo env False $ \r1 -> withtmpclonerepo env False $ \r2 -> do - let rname r = if r == r1 then "r1" else "r2" - forM_ [r1, r2] $ \r -> indir env r $ do - {- Get all files, see check below. -} - git_annex env "get" [] @? "get failed" - {- Set up repos as remotes of each other; - - remove origin since we're going to sync - - some changes to a file. -} - when (r /= r1) $ - boolSystem "git" [Params "remote add r1", File ("../../" ++ r1)] @? "remote add" - when (r /= r2) $ - boolSystem "git" [Params "remote add r2", File ("../../" ++ r2)] @? "remote add" - boolSystem "git" [Params "remote rm origin"] @? "remote rm" - - {- Set up a conflict. -} - let newcontent = content annexedfile ++ rname r - ifM (annexeval Config.isDirect) - ( writeFile annexedfile newcontent - , do - git_annex env "unlock" [annexedfile] @? "unlock failed" - writeFile annexedfile newcontent - ) - {- Sync twice in r1 so it gets the conflict resolution - - update from r2 -} - forM_ [r1, r2, r1] $ \r -> indir env r $ do - git_annex env "sync" [] @? "sync failed in " ++ rname r - {- After the sync, it should be possible to get all - - files. This includes both sides of the conflict, - - although the filenames are not easily predictable. - - - - The bug caused, in direct mode, one repo to - - be missing the content of the file that had - - been put in it. -} - forM_ [r1, r2] $ \r -> indir env r $ do - git_annex env "get" [] @? "unable to get all files after merge conflict resolution in " ++ rname r - -test_map :: TestEnv -> Test -test_map env = "git-annex map" ~: intmpclonerepo env $ do + indir env r1 $ do + writeFile conflictor "conflictor" + git_annex env "add" [conflictor] @? "add conflicter failed" + git_annex env "sync" [] @? "sync failed" + indir env r2 $ do + createDirectory conflictor + writeFile (conflictor </> "subfile") "subfile" + git_annex env "add" [conflictor] @? "add conflicter failed" + git_annex env "sync" [] @? "sync failed" + pair env r1 r2 + let r = if inr1 then r1 else r2 + indir env r $ do + git_annex env "sync" [] @? "sync failed in mixed conflict" + where + conflictor = "conflictor" + +{- Set up repos as remotes of each other; + - remove origin since we're going to sync + - some changes to a file. -} +pair :: TestEnv -> FilePath -> FilePath -> Assertion +pair env r1 r2 = forM_ [r1, r2] $ \r -> indir env r $ do + when (r /= r1) $ + boolSystem "git" [Params "remote add r1", File ("../../" ++ r1)] @? "remote add" + when (r /= r2) $ + boolSystem "git" [Params "remote add r2", File ("../../" ++ r2)] @? "remote add" + boolSystem "git" [Params "remote rm origin"] @? "remote rm" + +test_map :: TestEnv -> Assertion +test_map env = intmpclonerepo env $ do -- set descriptions, that will be looked for in the map git_annex env "describe" [".", "this repo"] @? "describe 1 failed" git_annex env "describe" ["origin", "origin repo"] @? "describe 2 failed" -- --fast avoids it running graphviz, not a build dependency git_annex env "map" ["--fast"] @? "map failed" -test_uninit :: TestEnv -> Test -test_uninit env = "git-annex uninit" ~: TestList [inbranch, normal] - where - inbranch = "in branch" ~: intmpclonerepoInDirect env $ do - boolSystem "git" [Params "checkout git-annex"] @? "git checkout git-annex" - not <$> git_annex env "uninit" [] @? "uninit failed to fail when git-annex branch was checked out" - normal = "normal" ~: intmpclonerepo env $ do - git_annex env "get" [] @? "get failed" - annexed_present annexedfile - _ <- git_annex env "uninit" [] -- exit status not checked; does abnormal exit - checkregularfile annexedfile - doesDirectoryExist ".git" @? ".git vanished in uninit" - not <$> doesDirectoryExist ".git/annex" @? ".git/annex still present after uninit" - -test_upgrade :: TestEnv -> Test -test_upgrade env = "git-annex upgrade" ~: intmpclonerepo env $ do +test_uninit :: TestEnv -> Assertion +test_uninit env = intmpclonerepo env $ do + git_annex env "get" [] @? "get failed" + annexed_present annexedfile + _ <- git_annex env "uninit" [] -- exit status not checked; does abnormal exit + checkregularfile annexedfile + doesDirectoryExist ".git" @? ".git vanished in uninit" + +test_uninit_inbranch :: TestEnv -> Assertion +test_uninit_inbranch env = intmpclonerepoInDirect env $ do + boolSystem "git" [Params "checkout git-annex"] @? "git checkout git-annex" + not <$> git_annex env "uninit" [] @? "uninit failed to fail when git-annex branch was checked out" + +test_upgrade :: TestEnv -> Assertion +test_upgrade env = intmpclonerepo env $ do git_annex env "upgrade" [] @? "upgrade from same version failed" -test_whereis :: TestEnv -> Test -test_whereis env = "git-annex whereis" ~: intmpclonerepo env $ do +test_whereis :: TestEnv -> Assertion +test_whereis env = intmpclonerepo env $ do annexed_notpresent annexedfile git_annex env "whereis" [annexedfile] @? "whereis on non-present file failed" git_annex env "untrust" ["origin"] @? "untrust failed" @@ -737,8 +846,8 @@ test_whereis env = "git-annex whereis" ~: intmpclonerepo env $ do annexed_present annexedfile git_annex env "whereis" [annexedfile] @? "whereis on present file failed" -test_hook_remote :: TestEnv -> Test -test_hook_remote env = "git-annex hook remote" ~: intmpclonerepo env $ do +test_hook_remote :: TestEnv -> Assertion +test_hook_remote env = intmpclonerepo env $ do #ifndef mingw32_HOST_OS git_annex env "initremote" (words "foo type=hook encryption=none hooktype=foo") @? "initremote failed" createDirectory dir @@ -770,8 +879,8 @@ test_hook_remote env = "git-annex hook remote" ~: intmpclonerepo env $ do noop #endif -test_directory_remote :: TestEnv -> Test -test_directory_remote env = "git-annex directory remote" ~: intmpclonerepo env $ do +test_directory_remote :: TestEnv -> Assertion +test_directory_remote env = intmpclonerepo env $ do createDirectory "dir" git_annex env "initremote" (words $ "foo type=directory encryption=none directory=dir") @? "initremote failed" git_annex env "get" [annexedfile] @? "get of file failed" @@ -785,8 +894,8 @@ test_directory_remote env = "git-annex directory remote" ~: intmpclonerepo env $ not <$> git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" annexed_present annexedfile -test_rsync_remote :: TestEnv -> Test -test_rsync_remote env = "git-annex rsync remote" ~: intmpclonerepo env $ do +test_rsync_remote :: TestEnv -> Assertion +test_rsync_remote env = intmpclonerepo env $ do #ifndef mingw32_HOST_OS createDirectory "dir" git_annex env "initremote" (words $ "foo type=rsync encryption=none rsyncurl=dir") @? "initremote failed" @@ -805,8 +914,8 @@ test_rsync_remote env = "git-annex rsync remote" ~: intmpclonerepo env $ do noop #endif -test_bup_remote :: TestEnv -> Test -test_bup_remote env = "git-annex bup remote" ~: intmpclonerepo env $ when Build.SysConfig.bup $ do +test_bup_remote :: TestEnv -> Assertion +test_bup_remote env = intmpclonerepo env $ when Build.SysConfig.bup $ do dir <- absPath "dir" -- bup special remote needs an absolute path createDirectory dir git_annex env "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) @? "initremote failed" @@ -822,35 +931,78 @@ test_bup_remote env = "git-annex bup remote" ~: intmpclonerepo env $ when Build. annexed_present annexedfile -- gpg is not a build dependency, so only test when it's available -test_crypto :: TestEnv -> Test -test_crypto env = "git-annex crypto" ~: intmpclonerepo env $ whenM (Utility.Path.inPath Utility.Gpg.gpgcmd) $ do +test_crypto :: TestEnv -> Assertion #ifndef mingw32_HOST_OS - Utility.Gpg.testTestHarness @? "test harness self-test failed" - Utility.Gpg.testHarness $ do - createDirectory "dir" - let a cmd = git_annex env cmd - [ "foo" - , "type=directory" - , "encryption=" ++ Utility.Gpg.testKeyId - , "directory=dir" - , "highRandomQuality=false" - ] - 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 env "get" [annexedfile] @? "get of file failed" - annexed_present annexedfile - git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to encrypted remote failed" - annexed_present annexedfile - git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed" - annexed_notpresent annexedfile - git_annex env "move" [annexedfile, "--from", "foo"] @? "move --from encrypted remote failed" - annexed_present annexedfile - not <$> git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" - annexed_present annexedfile +test_crypto env = do + testscheme "shared" + testscheme "hybrid" + testscheme "pubkey" + where + testscheme scheme = intmpclonerepo env $ whenM (Utility.Path.inPath Utility.Gpg.gpgcmd) $ do + Utility.Gpg.testTestHarness @? "test harness self-test failed" + Utility.Gpg.testHarness $ do + createDirectory "dir" + let a cmd = git_annex env cmd $ + [ "foo" + , "type=directory" + , "encryption=" ++ scheme + , "directory=dir" + , "highRandomQuality=false" + ] ++ 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 env "get" [annexedfile] @? "get of file failed" + annexed_present annexedfile + git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to encrypted remote failed" + (c,k) <- annexeval $ do + uuid <- Remote.nameToUUID "foo" + rs <- Logs.Remote.readRemoteLog + Just (k,_) <- Backend.lookupFile annexedfile + return (fromJust $ M.lookup uuid rs, k) + let key = if scheme `elem` ["hybrid","pubkey"] + then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId] + else Nothing + testEncryptedRemote scheme key c [k] @? "invalid crypto setup" + + annexed_present annexedfile + git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + annexed_notpresent annexedfile + git_annex env "move" [annexedfile, "--from", "foo"] @? "move --from encrypted remote failed" + annexed_present annexedfile + not <$> git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" + annexed_present annexedfile + {- Ensure the configuration complies with the encryption scheme, and + - that all keys are encrypted properly for the given directory remote. -} + testEncryptedRemote scheme ks c keys = case Remote.Helper.Encryptable.extractCipher c of + Just cip@Crypto.SharedCipher{} | scheme == "shared" && isNothing ks -> + checkKeys cip Nothing + Just cip@(Crypto.EncryptedCipher encipher v ks') + | checkScheme v && keysMatch ks' -> + checkKeys cip (Just v) <&&> checkCipher encipher ks' + _ -> return False + where + keysMatch (Utility.Gpg.KeyIds ks') = + maybe False (\(Utility.Gpg.KeyIds ks2) -> + sort (nub ks2) == sort (nub ks')) ks + checkCipher encipher = Utility.Gpg.checkEncryptionStream encipher . Just + checkScheme Types.Crypto.Hybrid = scheme == "hybrid" + checkScheme Types.Crypto.PubKey = scheme == "pubkey" + checkKeys cip mvariant = do + cipher <- Crypto.decryptCipher cip + files <- filterM doesFileExist $ + map ("dir" </>) $ concatMap (key2files cipher) keys + return (not $ null files) <&&> allM (checkFile mvariant) files + checkFile mvariant filename = + Utility.Gpg.checkEncryptionFile filename $ + if mvariant == Just Types.Crypto.PubKey then ks else Nothing + key2files cipher = Locations.keyPaths . + Crypto.encryptKey Types.Crypto.HmacSha1 cipher #else - putStrLn "gpg testing not implemented on Windows" +test_crypto _env = putStrLn "gpg testing not implemented on Windows" #endif -- This is equivilant to running git-annex, but it's all run in-process |