finished converting test suite for tasty

Also merged in Test.hs from master.
This commit is contained in:
Joey Hess 2013-11-14 17:03:49 -04:00
parent 8189738b13
commit cf93636df8

620
Test.hs
View file

@ -36,6 +36,7 @@ import qualified Types.KeySource
import qualified Types.Backend import qualified Types.Backend
import qualified Types.TrustLevel import qualified Types.TrustLevel
import qualified Types import qualified Types
import qualified Logs
import qualified Logs.UUIDBased import qualified Logs.UUIDBased
import qualified Logs.Trust import qualified Logs.Trust
import qualified Logs.Remote import qualified Logs.Remote
@ -58,11 +59,16 @@ import qualified Utility.Process
import qualified Utility.Misc import qualified Utility.Misc
import qualified Utility.InodeCache import qualified Utility.InodeCache
import qualified Utility.Env import qualified Utility.Env
import qualified Utility.Gpg
import qualified Utility.Matcher import qualified Utility.Matcher
import qualified Utility.Exception import qualified Utility.Exception
import qualified Utility.Hash
import qualified Utility.Scheduled
import qualified Utility.HumanTime
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import qualified GitAnnex import qualified GitAnnex
import qualified Remote.Helper.Encryptable
import qualified Types.Crypto
import qualified Utility.Gpg
#endif #endif
type TestEnv = M.Map String String 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_deencode" Utility.Format.prop_idempotent_deencode
, testProperty "prop_idempotent_fileKey" Locations.prop_idempotent_fileKey , testProperty "prop_idempotent_fileKey" Locations.prop_idempotent_fileKey
, testProperty "prop_idempotent_key_encode" Types.Key.prop_idempotent_key_encode , 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" Utility.SafeCommand.prop_idempotent_shellEscape
, testProperty "prop_idempotent_shellEscape_multiword" Utility.SafeCommand.prop_idempotent_shellEscape_multiword , 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_idempotent_configEscape" Logs.Remote.prop_idempotent_configEscape
, testProperty "prop_parse_show_Config" Logs.Remote.prop_parse_show_Config , testProperty "prop_parse_show_Config" Logs.Remote.prop_parse_show_Config
, testProperty "prop_parentDir_basics" Utility.Path.prop_parentDir_basics , 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_parse_show_log" Logs.Presence.prop_parse_show_log
, testProperty "prop_read_show_TrustLevel" Types.TrustLevel.prop_read_show_TrustLevel , testProperty "prop_read_show_TrustLevel" Types.TrustLevel.prop_read_show_TrustLevel
, testProperty "prop_parse_show_TrustLog" Logs.Trust.prop_parse_show_TrustLog , 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 unitTests :: TestEnv -> String -> TestTree
@ -119,30 +130,39 @@ unitTests env note = testGroup ("Unit Tests " ++ note)
, check "add" test_add , check "add" test_add
, check "add sha1dup" test_add_sha1dup , check "add sha1dup" test_add_sha1dup
, check "add subdirs" test_add_subdirs , check "add subdirs" test_add_subdirs
{-
, check "reinject" test_reinject , check "reinject" test_reinject
, check "unannex" test_unannex , check "unannex (no copy)" test_unannex_nocopy
, check "drop" test_drop , 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 "get" test_get
, check "move" test_move , check "move" test_move
, check "copy" test_copy , check "copy" test_copy
, check "lock" test_lock , 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 "fix" test_fix
, check "trust" test_trust , 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" test_migrate
, check "migrate (via gitattributes)" test_migrate_via_gitattributes
, check" unused" test_unused , check" unused" test_unused
, check "describe" test_describe , check "describe" test_describe
, check "find" test_find , check "find" test_find
, check "merge" test_merge , check "merge" test_merge
, check "status" test_status , check "info" test_info
, check "version" test_version , check "version" test_version
, check "sync" test_sync , check "sync" test_sync
, check "union merge regression" test_union_merge_regression , check "union merge regression" test_union_merge_regression
, check "conflict resolution" test_conflict_resolution , check "conflict resolution" test_conflict_resolution
, check "conflict_resolution (mixed directory and file)" test_mixed_conflict_resolution
, check "map" test_map , check "map" test_map
, check "uninit" test_uninit , check "uninit" test_uninit
, check "uninit (in git-annex branch)" test_uninit_inbranch
, check "upgrade" test_upgrade , check "upgrade" test_upgrade
, check "whereis" test_whereis , check "whereis" test_whereis
, check "hook remote" test_hook_remote , check "hook remote" test_hook_remote
@ -151,7 +171,6 @@ unitTests env note = testGroup ("Unit Tests " ++ note)
, check "bup remote" test_bup_remote , check "bup remote" test_bup_remote
, check "crypto" test_crypto , check "crypto" test_crypto
, check "preferred content" test_preferred_content , check "preferred content" test_preferred_content
-}
, check "global cleanup" test_global_cleanup , check "global cleanup" test_global_cleanup
] ]
where where
@ -182,12 +201,21 @@ test_add env = inmainrepo env $ do
git_annex env "add" [wormannexedfile, "--backend=WORM"] @? "add with WORM failed" git_annex env "add" [wormannexedfile, "--backend=WORM"] @? "add with WORM failed"
annexed_present wormannexedfile annexed_present wormannexedfile
checkbackend wormannexedfile backendWORM checkbackend wormannexedfile backendWORM
boolSystem "git" [Params "rm --force -q", File wormannexedfile] @? "git rm failed" ifM (annexeval Config.isDirect)
writeFile ingitfile $ content ingitfile ( do
boolSystem "git" [Param "add", File ingitfile] @? "git add failed" boolSystem "rm" [Params "-f", File wormannexedfile] @? "rm failed"
boolSystem "git" [Params "commit -q -m commit"] @? "git commit failed" writeFile ingitfile $ content ingitfile
git_annex env "add" [ingitfile] @? "add ingitfile should be no-op" not <$> boolSystem "git" [Param "add", File ingitfile] @? "git add failed to fail in direct mode"
unannexed ingitfile 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 :: TestEnv -> Assertion
test_add_sha1dup env = intmpclonerepo env $ do 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" git_annex env "add" [".." </> "dir2"] @? "add of ../subdir failed"
#endif #endif
test_reinject :: TestEnv -> Test test_reinject :: TestEnv -> Assertion
test_reinject env = "git-annex reinject/fromkey" ~: TestCase $ intmpclonerepoInDirect env $ do test_reinject env = intmpclonerepoInDirect env $ do
git_annex env "drop" ["--force", sha1annexedfile] @? "drop failed" git_annex env "drop" ["--force", sha1annexedfile] @? "drop failed"
writeFile tmp $ content sha1annexedfile writeFile tmp $ content sha1annexedfile
r <- annexeval $ Types.Backend.getKey backendSHA1 $ r <- annexeval $ Types.Backend.getKey backendSHA1 $
@ -222,53 +250,57 @@ test_reinject env = "git-annex reinject/fromkey" ~: TestCase $ intmpclonerepoInD
where where
tmp = "tmpfile" tmp = "tmpfile"
test_unannex :: TestEnv -> Test test_unannex_nocopy :: TestEnv -> Assertion
test_unannex env = "git-annex unannex" ~: TestList [nocopy, withcopy] test_unannex_nocopy env = intmpclonerepo env $ do
where annexed_notpresent annexedfile
nocopy = "no content" ~: intmpclonerepo env $ do git_annex env "unannex" [annexedfile] @? "unannex failed with no copy"
annexed_notpresent annexedfile annexed_notpresent annexedfile
git_annex env "unannex" [annexedfile] @? "unannex failed with no copy"
annexed_notpresent annexedfile test_unannex_withcopy :: TestEnv -> Assertion
withcopy = "with content" ~: intmpclonerepo env $ do test_unannex_withcopy env = intmpclonerepo env $ do
git_annex env "get" [annexedfile] @? "get failed" git_annex env "get" [annexedfile] @? "get failed"
annexed_present annexedfile annexed_present annexedfile
git_annex env "unannex" [annexedfile, sha1annexedfile] @? "unannex failed" git_annex env "unannex" [annexedfile, sha1annexedfile] @? "unannex failed"
unannexed annexedfile unannexed annexedfile
git_annex env "unannex" [annexedfile] @? "unannex failed on non-annexed file" git_annex env "unannex" [annexedfile] @? "unannex failed on non-annexed file"
unannexed annexedfile unannexed annexedfile
unlessM (annexeval Config.isDirect) $ do
git_annex env "unannex" [ingitfile] @? "unannex ingitfile should be no-op" git_annex env "unannex" [ingitfile] @? "unannex ingitfile should be no-op"
unannexed ingitfile unannexed ingitfile
test_drop :: TestEnv -> Test test_drop_noremote :: TestEnv -> Assertion
test_drop env = "git-annex drop" ~: TestList [noremote, withremote, untrustedremote] test_drop_noremote env = intmpclonerepo env $ do
where git_annex env "get" [annexedfile] @? "get failed"
noremote = "no remotes" ~: TestCase $ intmpclonerepo env $ do boolSystem "git" [Params "remote rm origin"]
git_annex env "get" [annexedfile] @? "get failed" @? "git remote rm origin failed"
boolSystem "git" [Params "remote rm origin"] not <$> git_annex env "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file"
@? "git remote rm origin failed" annexed_present annexedfile
not <$> git_annex env "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file" git_annex env "drop" ["--force", annexedfile] @? "drop --force failed"
annexed_present annexedfile annexed_notpresent annexedfile
git_annex env "drop" ["--force", annexedfile] @? "drop --force failed" git_annex env "drop" [annexedfile] @? "drop of dropped file failed"
annexed_notpresent annexedfile unlessM (annexeval Config.isDirect) $ do
git_annex env "drop" [annexedfile] @? "drop of dropped file failed"
git_annex env "drop" [ingitfile] @? "drop ingitfile should be no-op" git_annex env "drop" [ingitfile] @? "drop ingitfile should be no-op"
unannexed ingitfile 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_drop_withremote :: TestEnv -> Assertion
test_get env = "git-annex get" ~: TestCase $ intmpclonerepo env $ do 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 inmainrepo env $ annexed_present annexedfile
annexed_notpresent annexedfile annexed_notpresent annexedfile
git_annex env "get" [annexedfile] @? "get of file failed" 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" git_annex env "get" [annexedfile] @? "get of file already here failed"
inmainrepo env $ annexed_present annexedfile inmainrepo env $ annexed_present annexedfile
annexed_present annexedfile annexed_present annexedfile
inmainrepo env $ unannexed ingitfile unlessM (annexeval Config.isDirect) $ do
unannexed ingitfile inmainrepo env $ unannexed ingitfile
git_annex env "get" [ingitfile] @? "get ingitfile should be no-op" unannexed ingitfile
inmainrepo env $ unannexed ingitfile git_annex env "get" [ingitfile] @? "get ingitfile should be no-op"
unannexed ingitfile inmainrepo env $ unannexed ingitfile
unannexed ingitfile
test_move :: TestEnv -> Test test_move :: TestEnv -> Assertion
test_move env = "git-annex move" ~: TestCase $ intmpclonerepo env $ do test_move env = intmpclonerepo env $ do
annexed_notpresent annexedfile annexed_notpresent annexedfile
inmainrepo env $ annexed_present annexedfile inmainrepo env $ annexed_present annexedfile
git_annex env "move" ["--from", "origin", annexedfile] @? "move --from of file failed" 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" git_annex env "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed"
inmainrepo env $ annexed_present annexedfile inmainrepo env $ annexed_present annexedfile
annexed_notpresent annexedfile annexed_notpresent annexedfile
unannexed ingitfile unlessM (annexeval Config.isDirect) $ do
inmainrepo env $ unannexed ingitfile unannexed ingitfile
git_annex env "move" ["--to", "origin", ingitfile] @? "move of ingitfile should be no-op" inmainrepo env $ unannexed ingitfile
unannexed ingitfile git_annex env "move" ["--to", "origin", ingitfile] @? "move of ingitfile should be no-op"
inmainrepo env $ unannexed ingitfile unannexed ingitfile
git_annex env "move" ["--from", "origin", ingitfile] @? "move of ingitfile should be no-op" inmainrepo env $ unannexed ingitfile
unannexed ingitfile git_annex env "move" ["--from", "origin", ingitfile] @? "move of ingitfile should be no-op"
inmainrepo env $ unannexed ingitfile unannexed ingitfile
inmainrepo env $ unannexed ingitfile
test_copy :: TestEnv -> Test test_copy :: TestEnv -> Assertion
test_copy env = "git-annex copy" ~: TestCase $ intmpclonerepo env $ do test_copy env = intmpclonerepo env $ do
annexed_notpresent annexedfile annexed_notpresent annexedfile
inmainrepo env $ annexed_present annexedfile inmainrepo env $ annexed_present annexedfile
git_annex env "copy" ["--from", "origin", annexedfile] @? "copy --from of file failed" 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" git_annex env "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed"
annexed_notpresent annexedfile annexed_notpresent annexedfile
inmainrepo env $ annexed_present annexedfile inmainrepo env $ annexed_present annexedfile
unannexed ingitfile unlessM (annexeval Config.isDirect) $ do
inmainrepo env $ unannexed ingitfile unannexed ingitfile
git_annex env "copy" ["--to", "origin", ingitfile] @? "copy of ingitfile should be no-op" inmainrepo env $ unannexed ingitfile
unannexed ingitfile git_annex env "copy" ["--to", "origin", ingitfile] @? "copy of ingitfile should be no-op"
inmainrepo env $ unannexed ingitfile unannexed ingitfile
git_annex env "copy" ["--from", "origin", ingitfile] @? "copy of ingitfile should be no-op" inmainrepo env $ unannexed ingitfile
checkregularfile ingitfile git_annex env "copy" ["--from", "origin", ingitfile] @? "copy of ingitfile should be no-op"
checkcontent ingitfile checkregularfile ingitfile
checkcontent ingitfile
test_preferred_content :: TestEnv -> Test test_preferred_content :: TestEnv -> Assertion
test_preferred_content env = "git-annex preferred-content" ~: TestCase $ intmpclonerepo env $ do test_preferred_content env = intmpclonerepo env $ do
annexed_notpresent annexedfile annexed_notpresent annexedfile
-- get --auto only looks at numcopies when preferred content is not -- get --auto only looks at numcopies when preferred content is not
-- set, and with 1 copy existing, does not get the file. -- 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" git_annex env "get" ["--auto", annexedfile] @? "get --auto of file failed with default preferred content"
annexed_notpresent annexedfile 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 "group" [".", "client"] @? "set group to standard failed"
git_annex env "get" ["--auto", annexedfile] @? "get --auto of file failed for client" git_annex env "get" ["--auto", annexedfile] @? "get --auto of file failed for client"
annexed_present annexedfile annexed_present annexedfile
git_annex env "ungroup" [".", "client"] @? "ungroup failed" 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" git_annex env "group" [".", "manual"] @? "set group to manual failed"
-- drop --auto with manual leaves the file where it is -- 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" 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 annexed_notpresent annexedfile
git_annex env "ungroup" [".", "client"] @? "ungroup failed" 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" git_annex env "get" [annexedfile] @? "get of file failed"
annexed_present annexedfile annexed_present annexedfile
git_annex env "drop" ["--auto", annexedfile] @? "drop --auto of file failed with exclude=*" 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=*" git_annex env "get" ["--auto", annexedfile] @? "get --auto of file failed with exclude=*"
annexed_notpresent annexedfile annexed_notpresent annexedfile
test_lock :: TestEnv -> Test test_lock :: TestEnv -> Assertion
test_lock env = "git-annex unlock/lock" ~: intmpclonerepoInDirect env $ do test_lock env = intmpclonerepoInDirect env $ do
-- regression test: unlock of not present file should skip it -- regression test: unlock of not present file should skip it
annexed_notpresent annexedfile annexed_notpresent annexedfile
not <$> git_annex env "unlock" [annexedfile] @? "unlock failed to fail with not present file" 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] r' <- git_annex env "drop" [annexedfile]
not r' @? "drop wrongly succeeded with no known copy of modified file" not r' @? "drop wrongly succeeded with no known copy of modified file"
test_edit :: TestEnv -> Test test_edit :: TestEnv -> Assertion
test_edit env = "git-annex edit/commit" ~: TestList [t False, t True] test_edit = test_edit' False
where t precommit = TestCase $ intmpclonerepoInDirect env $ do
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" git_annex env "get" [annexedfile] @? "get of file failed"
annexed_present annexedfile annexed_present annexedfile
git_annex env "edit" [annexedfile] @? "edit failed" 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) assertEqual "content of modified file" c (changedcontent annexedfile)
not <$> git_annex env "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of modified file" not <$> git_annex env "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of modified file"
test_fix :: TestEnv -> Test test_fix :: TestEnv -> Assertion
test_fix env = "git-annex fix" ~: intmpclonerepoInDirect env $ do test_fix env = intmpclonerepoInDirect env $ do
annexed_notpresent annexedfile annexed_notpresent annexedfile
git_annex env "fix" [annexedfile] @? "fix of not present failed" git_annex env "fix" [annexedfile] @? "fix of not present failed"
annexed_notpresent annexedfile annexed_notpresent annexedfile
@ -434,8 +474,8 @@ test_fix env = "git-annex fix" ~: intmpclonerepoInDirect env $ do
subdir = "s" subdir = "s"
newfile = subdir ++ "/" ++ annexedfile newfile = subdir ++ "/" ++ annexedfile
test_trust :: TestEnv -> Test test_trust :: TestEnv -> Assertion
test_trust env = "git-annex trust/untrust/semitrust/dead" ~: intmpclonerepo env $ do test_trust env = intmpclonerepo env $ do
git_annex env "trust" [repo] @? "trust failed" git_annex env "trust" [repo] @? "trust failed"
trustcheck Logs.Trust.Trusted "trusted 1" trustcheck Logs.Trust.Trusted "trusted 1"
git_annex env "trust" [repo] @? "trust of trusted failed" 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 return $ u `elem` l
assertBool msg present assertBool msg present
test_fsck :: TestEnv -> Test test_fsck_basic :: TestEnv -> Assertion
test_fsck env = "git-annex fsck" ~: TestList [basicfsck, barefsck, withlocaluntrusted, withremoteuntrusted] 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 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 corrupt f = do
git_annex env "get" [f] @? "get of file failed" git_annex env "get" [f] @? "get of file failed"
Utility.FileMode.allowWrite f 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" , 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 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_fsck_bare :: TestEnv -> Assertion
test_migrate env = "git-annex migrate" ~: TestList [t False, t True] test_fsck_bare env = intmpbareclonerepo env $ do
where t usegitattributes = TestCase $ intmpclonerepoInDirect 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 annexedfile
annexed_notpresent sha1annexedfile annexed_notpresent sha1annexedfile
git_annex env "migrate" [annexedfile] @? "migrate of not present failed" 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 annexedfile backendSHA256
checkbackend sha1annexedfile backendSHA256 checkbackend sha1annexedfile backendSHA256
test_unused :: TestEnv -> Test test_unused :: TestEnv -> Assertion
-- This test is broken in direct mode -- 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 -- keys have to be looked up before files are removed
annexedfilekey <- annexeval $ findkey annexedfile annexedfilekey <- annexeval $ findkey annexedfile
sha1annexedfilekey <- annexeval $ findkey sha1annexedfile sha1annexedfilekey <- annexeval $ findkey sha1annexedfile
@ -569,6 +620,37 @@ test_unused env = "git-annex unused/dropunused" ~: intmpclonerepoInDirect env $
checkunused [] "after dropunused" checkunused [] "after dropunused"
not <$> git_annex env "dropunused" ["--force", "10", "501"] @? "dropunused failed to fail on bogus numbers" 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 where
checkunused expectedkeys desc = do checkunused expectedkeys desc = do
git_annex env "unused" [] @? "unused failed" git_annex env "unused" [] @? "unused failed"
@ -580,13 +662,13 @@ test_unused env = "git-annex unused/dropunused" ~: intmpclonerepoInDirect env $
r <- Backend.lookupFile f r <- Backend.lookupFile f
return $ fst $ fromJust r return $ fst $ fromJust r
test_describe :: TestEnv -> Test test_describe :: TestEnv -> Assertion
test_describe env = "git-annex describe" ~: intmpclonerepo env $ do test_describe env = intmpclonerepo env $ do
git_annex env "describe" [".", "this repo"] @? "describe 1 failed" git_annex env "describe" [".", "this repo"] @? "describe 1 failed"
git_annex env "describe" ["origin", "origin repo"] @? "describe 2 failed" git_annex env "describe" ["origin", "origin repo"] @? "describe 2 failed"
test_find :: TestEnv -> Test test_find :: TestEnv -> Assertion
test_find env = "git-annex find" ~: intmpclonerepo env $ do test_find env = intmpclonerepo env $ do
annexed_notpresent annexedfile annexed_notpresent annexedfile
git_annex_expectoutput env "find" [] [] git_annex_expectoutput env "find" [] []
git_annex env "get" [annexedfile] @? "get failed" 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" ["--include", "*", "--exclude", annexedfile, "--exclude", sha1annexedfile] ["dir/subfile"]
git_annex_expectoutput env "find" ["--exclude", "*"] [] git_annex_expectoutput env "find" ["--exclude", "*"] []
test_merge :: TestEnv -> Test test_merge :: TestEnv -> Assertion
test_merge env = "git-annex merge" ~: intmpclonerepo env $ do test_merge env = intmpclonerepo env $ do
git_annex env "merge" [] @? "merge failed" git_annex env "merge" [] @? "merge failed"
test_status :: TestEnv -> Test test_info :: TestEnv -> Assertion
test_status env = "git-annex status" ~: intmpclonerepo env $ do test_info env = intmpclonerepo env $ do
json <- git_annex_output env "status" ["--json"] json <- git_annex_output env "info" ["--json"]
case Text.JSON.decodeStrict json :: Text.JSON.Result (Text.JSON.JSObject Text.JSON.JSValue) of case Text.JSON.decodeStrict json :: Text.JSON.Result (Text.JSON.JSObject Text.JSON.JSValue) of
Text.JSON.Ok _ -> return () Text.JSON.Ok _ -> return ()
Text.JSON.Error e -> assertFailure e Text.JSON.Error e -> assertFailure e
test_version :: TestEnv -> Test test_version :: TestEnv -> Assertion
test_version env = "git-annex version" ~: intmpclonerepo env $ do test_version env = intmpclonerepo env $ do
git_annex env "version" [] @? "version failed" git_annex env "version" [] @? "version failed"
test_sync :: TestEnv -> Test test_sync :: TestEnv -> Assertion
test_sync env = "git-annex sync" ~: intmpclonerepo env $ do test_sync env = intmpclonerepo env $ do
git_annex env "sync" [] @? "sync failed" git_annex env "sync" [] @? "sync failed"
{- Regression test for bug fixed in {- Regression test for bug fixed in
- 7b0970b340d7faeb745c666146c7f701ec71808f, where in direct mode - 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 {- Regression test for union merge bug fixed in
- 0214e0fb175a608a49b812d81b4632c081f63027 -} - 0214e0fb175a608a49b812d81b4632c081f63027 -}
test_union_merge_regression :: TestEnv -> Test test_union_merge_regression :: TestEnv -> Assertion
test_union_merge_regression env = "union merge regression" ~: test_union_merge_regression env =
{- We need 3 repos to see this bug. -} {- We need 3 repos to see this bug. -}
withtmpclonerepo env False $ \r1 -> do withtmpclonerepo env False $ \r1 -> do
withtmpclonerepo env False $ \r2 -> 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 {- Regression test for the automatic conflict resolution bug fixed
- in f4ba19f2b8a76a1676da7bb5850baa40d9c388e2. -} - in f4ba19f2b8a76a1676da7bb5850baa40d9c388e2. -}
test_conflict_resolution :: TestEnv -> Test test_conflict_resolution :: TestEnv -> Assertion
test_conflict_resolution env = "automatic conflict resolution" ~: test_conflict_resolution_movein_bug env = withtmpclonerepo env False $ \r1 -> do
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 withtmpclonerepo env False $ \r2 -> do
let rname r = if r == r1 then "r1" else "r2" indir env r1 $ do
forM_ [r1, r2] $ \r -> indir env r $ do writeFile conflictor "conflictor"
{- Get all files, see check below. -} git_annex env "add" [conflictor] @? "add conflicter failed"
git_annex env "get" [] @? "get failed" git_annex env "sync" [] @? "sync failed"
{- Set up repos as remotes of each other; indir env r2 $ do
- remove origin since we're going to sync createDirectory conflictor
- some changes to a file. -} writeFile (conflictor </> "subfile") "subfile"
when (r /= r1) $ git_annex env "add" [conflictor] @? "add conflicter failed"
boolSystem "git" [Params "remote add r1", File ("../../" ++ r1)] @? "remote add" git_annex env "sync" [] @? "sync failed"
when (r /= r2) $ pair env r1 r2
boolSystem "git" [Params "remote add r2", File ("../../" ++ r2)] @? "remote add" let r = if inr1 then r1 else r2
boolSystem "git" [Params "remote rm origin"] @? "remote rm" indir env r $ do
git_annex env "sync" [] @? "sync failed in mixed conflict"
where
conflictor = "conflictor"
{- Set up a conflict. -} {- Set up repos as remotes of each other;
let newcontent = content annexedfile ++ rname r - remove origin since we're going to sync
ifM (annexeval Config.isDirect) - some changes to a file. -}
( writeFile annexedfile newcontent pair :: TestEnv -> FilePath -> FilePath -> Assertion
, do pair env r1 r2 = forM_ [r1, r2] $ \r -> indir env r $ do
git_annex env "unlock" [annexedfile] @? "unlock failed" when (r /= r1) $
writeFile annexedfile newcontent boolSystem "git" [Params "remote add r1", File ("../../" ++ r1)] @? "remote add"
) when (r /= r2) $
{- Sync twice in r1 so it gets the conflict resolution boolSystem "git" [Params "remote add r2", File ("../../" ++ r2)] @? "remote add"
- update from r2 -} boolSystem "git" [Params "remote rm origin"] @? "remote rm"
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 :: TestEnv -> Assertion
test_map env = "git-annex map" ~: intmpclonerepo env $ do test_map env = intmpclonerepo env $ do
-- set descriptions, that will be looked for in the map -- set descriptions, that will be looked for in the map
git_annex env "describe" [".", "this repo"] @? "describe 1 failed" git_annex env "describe" [".", "this repo"] @? "describe 1 failed"
git_annex env "describe" ["origin", "origin repo"] @? "describe 2 failed" git_annex env "describe" ["origin", "origin repo"] @? "describe 2 failed"
-- --fast avoids it running graphviz, not a build dependency -- --fast avoids it running graphviz, not a build dependency
git_annex env "map" ["--fast"] @? "map failed" git_annex env "map" ["--fast"] @? "map failed"
test_uninit :: TestEnv -> Test test_uninit :: TestEnv -> Assertion
test_uninit env = "git-annex uninit" ~: TestList [inbranch, normal] test_uninit env = intmpclonerepo env $ do
where git_annex env "get" [] @? "get failed"
inbranch = "in branch" ~: intmpclonerepoInDirect env $ do annexed_present annexedfile
boolSystem "git" [Params "checkout git-annex"] @? "git checkout git-annex" _ <- git_annex env "uninit" [] -- exit status not checked; does abnormal exit
not <$> git_annex env "uninit" [] @? "uninit failed to fail when git-annex branch was checked out" checkregularfile annexedfile
normal = "normal" ~: intmpclonerepo env $ do doesDirectoryExist ".git" @? ".git vanished in uninit"
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_uninit_inbranch :: TestEnv -> Assertion
test_upgrade env = "git-annex upgrade" ~: intmpclonerepo env $ do 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" git_annex env "upgrade" [] @? "upgrade from same version failed"
test_whereis :: TestEnv -> Test test_whereis :: TestEnv -> Assertion
test_whereis env = "git-annex whereis" ~: intmpclonerepo env $ do test_whereis env = intmpclonerepo env $ do
annexed_notpresent annexedfile annexed_notpresent annexedfile
git_annex env "whereis" [annexedfile] @? "whereis on non-present file failed" git_annex env "whereis" [annexedfile] @? "whereis on non-present file failed"
git_annex env "untrust" ["origin"] @? "untrust failed" git_annex env "untrust" ["origin"] @? "untrust failed"
@ -737,8 +846,8 @@ test_whereis env = "git-annex whereis" ~: intmpclonerepo env $ do
annexed_present annexedfile annexed_present annexedfile
git_annex env "whereis" [annexedfile] @? "whereis on present file failed" git_annex env "whereis" [annexedfile] @? "whereis on present file failed"
test_hook_remote :: TestEnv -> Test test_hook_remote :: TestEnv -> Assertion
test_hook_remote env = "git-annex hook remote" ~: intmpclonerepo env $ do test_hook_remote env = intmpclonerepo env $ do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
git_annex env "initremote" (words "foo type=hook encryption=none hooktype=foo") @? "initremote failed" git_annex env "initremote" (words "foo type=hook encryption=none hooktype=foo") @? "initremote failed"
createDirectory dir createDirectory dir
@ -770,8 +879,8 @@ test_hook_remote env = "git-annex hook remote" ~: intmpclonerepo env $ do
noop noop
#endif #endif
test_directory_remote :: TestEnv -> Test test_directory_remote :: TestEnv -> Assertion
test_directory_remote env = "git-annex directory remote" ~: intmpclonerepo env $ do test_directory_remote env = intmpclonerepo env $ do
createDirectory "dir" createDirectory "dir"
git_annex env "initremote" (words $ "foo type=directory encryption=none directory=dir") @? "initremote failed" git_annex env "initremote" (words $ "foo type=directory encryption=none directory=dir") @? "initremote failed"
git_annex env "get" [annexedfile] @? "get of file 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" not <$> git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail"
annexed_present annexedfile annexed_present annexedfile
test_rsync_remote :: TestEnv -> Test test_rsync_remote :: TestEnv -> Assertion
test_rsync_remote env = "git-annex rsync remote" ~: intmpclonerepo env $ do test_rsync_remote env = intmpclonerepo env $ do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
createDirectory "dir" createDirectory "dir"
git_annex env "initremote" (words $ "foo type=rsync encryption=none rsyncurl=dir") @? "initremote failed" 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 noop
#endif #endif
test_bup_remote :: TestEnv -> Test test_bup_remote :: TestEnv -> Assertion
test_bup_remote env = "git-annex bup remote" ~: intmpclonerepo env $ when Build.SysConfig.bup $ do test_bup_remote env = intmpclonerepo env $ when Build.SysConfig.bup $ do
dir <- absPath "dir" -- bup special remote needs an absolute path dir <- absPath "dir" -- bup special remote needs an absolute path
createDirectory dir createDirectory dir
git_annex env "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) @? "initremote failed" 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 annexed_present annexedfile
-- gpg is not a build dependency, so only test when it's available -- gpg is not a build dependency, so only test when it's available
test_crypto :: TestEnv -> Test test_crypto :: TestEnv -> Assertion
test_crypto env = "git-annex crypto" ~: intmpclonerepo env $ whenM (Utility.Path.inPath Utility.Gpg.gpgcmd) $ do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
Utility.Gpg.testTestHarness @? "test harness self-test failed" test_crypto env = do
Utility.Gpg.testHarness $ do testscheme "shared"
createDirectory "dir" testscheme "hybrid"
let a cmd = git_annex env cmd testscheme "pubkey"
[ "foo" where
, "type=directory" testscheme scheme = intmpclonerepo env $ whenM (Utility.Path.inPath Utility.Gpg.gpgcmd) $ do
, "encryption=" ++ Utility.Gpg.testKeyId Utility.Gpg.testTestHarness @? "test harness self-test failed"
, "directory=dir" Utility.Gpg.testHarness $ do
, "highRandomQuality=false" createDirectory "dir"
] let a cmd = git_annex env cmd $
a "initremote" @? "initremote failed" [ "foo"
not <$> a "initremote" @? "initremote failed to fail when run twice in a row" , "type=directory"
a "enableremote" @? "enableremote failed" , "encryption=" ++ scheme
a "enableremote" @? "enableremote failed when run twice in a row" , "directory=dir"
git_annex env "get" [annexedfile] @? "get of file failed" , "highRandomQuality=false"
annexed_present annexedfile ] ++ if scheme `elem` ["hybrid","pubkey"]
git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to encrypted remote failed" then ["keyid=" ++ Utility.Gpg.testKeyId]
annexed_present annexedfile else []
git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed" a "initremote" @? "initremote failed"
annexed_notpresent annexedfile not <$> a "initremote" @? "initremote failed to fail when run twice in a row"
git_annex env "move" [annexedfile, "--from", "foo"] @? "move --from encrypted remote failed" a "enableremote" @? "enableremote failed"
annexed_present annexedfile a "enableremote" @? "enableremote failed when run twice in a row"
not <$> git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" git_annex env "get" [annexedfile] @? "get of file failed"
annexed_present annexedfile 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 #else
putStrLn "gpg testing not implemented on Windows" test_crypto _env = putStrLn "gpg testing not implemented on Windows"
#endif #endif
-- This is equivilant to running git-annex, but it's all run in-process -- This is equivilant to running git-annex, but it's all run in-process