more tests

Makefile

@@ -37,6 +37,7 @@ testcoverage:
 	rm -f test.tix test
 	ghc -odir build/test -hidir build/test $(GHCFLAGS) --make -fhpc test
 	./test
+	@echo ""
 	@hpc report test --exclude=Main --exclude=QC
 	@hpc markup test --exclude=Main --exclude=QC --destdir=.hpc >/dev/null
 

debian/changelog

@@ -8,7 +8,7 @@ git-annex (0.16) UNRELEASED; urgency=low
     significant problem, since the remote *did* record that it had the file.
   * Also, add a general guard to detect attempts to record information
     about repositories with missing UUIDs.
-  * Test suite improvements. Current top-level test coverage: 43%
+  * Test suite improvements. Current top-level test coverage: 53%
 
  -- Joey Hess <joeyh@debian.org>  Tue, 04 Jan 2011 17:33:42 -0400
 

test.hs

@@ -14,6 +14,7 @@ import IO (bracket_, bracket)
 import Control.Monad (unless, when)
 import Data.List
 import System.IO.Error
+import qualified Control.Exception.Extensible as E
 
 import qualified GitRepo as Git
 import qualified Locations
@@ -23,7 +24,10 @@ import qualified GitAnnex
 import qualified CmdLine
 
 main :: IO (Counts, Int)
-main = runVerboseTests $ TestList [quickchecks, toplevels]
+main = do
+	r <- runVerboseTests $ TestList [quickchecks, toplevels]
+	cleanup tmpdir
+	return r
 
 quickchecks :: Test
 quickchecks = TestLabel "quickchecks" $ TestList
@@ -38,12 +42,15 @@ quickchecks = TestLabel "quickchecks" $ TestList
 
 toplevels :: Test
 toplevels = TestLabel "toplevel" $ TestList
+	-- test order matters, later tests may rely on state from earlier
 	[ test_init
 	, test_add
+	, test_unannex
+	, test_drop
 	]
 
 test_init :: Test
-test_init = TestLabel "git-annex init" $ TestCase $ ingitrepo $ do
+test_init = TestLabel "git-annex init" $ TestCase $ innewrepo $ do
 	git_annex "init" ["-q", reponame] @? "init failed"
 	e <- doesFileExist annexlog
 	unless e $
@@ -56,7 +63,7 @@ test_init = TestLabel "git-annex init" $ TestCase $ ingitrepo $ do
 		reponame = "test repo"
 
 test_add :: Test
-test_add = TestLabel "git-annex add" $ TestCase $ inannex $ do
+test_add = TestLabel "git-annex add" $ TestCase $ inoldrepo $ do
 	writeFile file content
 	git_annex "add" ["-q", "foo"] @? "add failed"
 	s <- getSymbolicLinkStatus file
@@ -65,7 +72,7 @@ test_add = TestLabel "git-annex add" $ TestCase $ inannex $ do
 	c <- readFile file
 	unless (c == content) $
 		assertFailure "file content changed during git-annex add"
-	r <- try (writeFile file $ content++"bar")
+	r <- try $ writeFile file $ content++"bar"
 	case r of
 		Left _ -> return () -- expected permission error
 		Right _ -> assertFailure "was able to modify annexed file content"
@@ -73,47 +80,113 @@ test_add = TestLabel "git-annex add" $ TestCase $ inannex $ do
 		file = "foo"
 		content = "foo file content"
 
+test_unannex :: Test
+test_unannex = TestLabel "git-annex unannex" $ TestCase $ intmpcopyrepo $ do
+	git_annex "unannex" ["-q", "foo"] @? "unannex failed"
+	s <- getSymbolicLinkStatus "foo"
+	when (isSymbolicLink s) $
+		assertFailure "git-annex unannex left symlink"
+
+test_drop :: Test
+test_drop = TestLabel "git-annex drop" $ TestCase $ intmpcopyrepo $ do
+	r <- git_annex "drop" ["-q", "foo"]
+	(not r) @? "drop wrongly succeeded with no known copy of file"
+	checklink
+	git_annex "drop" ["-q", "--force", "foo"] @? "drop --force failed"
+	checklink
+	r' <- try $ readFile "foo"
+	case r' of
+		Left _ -> return () -- expected; dangling link
+		Right _ -> assertFailure "drop did not remove file content"
+	where
+		checklink = do
+			s <- getSymbolicLinkStatus "foo"
+			unless (isSymbolicLink s) $
+				assertFailure "git-annex drop killed symlink"
+
+
+
+
 git_annex :: String -> [String] -> IO Bool
 git_annex command params = do
-	gitrepo <- Git.repoFromCwd
-	r <- try $
-		CmdLine.dispatch gitrepo (command:params)
-			GitAnnex.cmds GitAnnex.options GitAnnex.header
+	-- catch all errors, including normally fatal errors
+	r <- E.try (run)::IO (Either E.SomeException ())
 	case r of
 		Right _ -> return True
 		Left _ -> return False
+	where
+		run = do
+			gitrepo <- Git.repoFromCwd
+			CmdLine.dispatch gitrepo (command:params)
+				GitAnnex.cmds GitAnnex.options GitAnnex.header
 
-inannex :: Assertion -> Assertion
-inannex a = ingitrepo $ do
+innewannex :: Assertion -> Assertion
+innewannex a = innewrepo $ do
 	git_annex "init" ["-q", reponame] @? "init failed"
 	a
 	where
 		reponame = "test repo"
 
-ingitrepo :: Assertion -> Assertion
-ingitrepo a = withgitrepo $ \r -> do
+innewrepo :: Assertion -> Assertion
+innewrepo a = withgitrepo $ \r -> indir r a
+
+inoldrepo :: Assertion -> Assertion
+inoldrepo = indir repodir
+
+intmpcopyrepo :: Assertion -> Assertion
+intmpcopyrepo a = withtmpcopyrepo $ \r -> indir r a
+
+withtmpcopyrepo :: (FilePath -> Assertion) -> Assertion
+withtmpcopyrepo = bracket (copyrepo repodir tmprepodir) cleanup
+
+withgitrepo :: (FilePath -> Assertion) -> Assertion
+withgitrepo = bracket (setuprepo repodir) return
+
+indir :: FilePath -> Assertion -> Assertion
+indir dir a = do
 	cwd <- getCurrentDirectory
-	bracket_ (changeWorkingDirectory $ Git.workTree r)
+	bracket_ (changeWorkingDirectory $ dir)
 		(\_ -> changeWorkingDirectory cwd)
 		a
 
-withgitrepo :: (Git.Repo -> Assertion) -> Assertion
-withgitrepo = bracket setup cleanup
-	where
-		tmpdir = ".t"
-		repodir = tmpdir ++ "/repo"
-		setup = do
-			cleanup True
-			createDirectory tmpdir
-			ok <- Utility.boolSystem "git" ["init", "-q", repodir]
+setuprepo :: FilePath -> IO FilePath
+setuprepo dir = do
+	cleanup dir
+	ensuretmpdir
+	ok <- Utility.boolSystem "git" ["init", "-q", dir]
 	unless ok $
 		assertFailure "git init failed"
-			return $ Git.repoFromPath repodir
-		cleanup _ = do
+	return dir
+
+copyrepo :: FilePath -> FilePath -> IO FilePath
+copyrepo old new = do
+	cleanup new
+	ensuretmpdir
+	ok <- Utility.boolSystem "cp" ["-pr", old, new]
+	unless ok $
+		assertFailure "cp -pr failed"
+	return new
+	
+ensuretmpdir :: IO ()
+ensuretmpdir = do
 	e <- doesDirectoryExist tmpdir
+	unless e $
+		createDirectory tmpdir
+
+cleanup :: FilePath -> IO ()
+cleanup dir = do
+	e <- doesDirectoryExist dir
 	when e $ do
-				-- git-annex prevents annexed file content
-				-- from being removed with permissions
-				-- bits; undo
-				_ <- Utility.boolSystem "chmod" ["+rw", "-R", tmpdir]
-				removeDirectoryRecursive tmpdir
+		-- git-annex prevents annexed file content from being
+		-- removed via permissions bits; undo
+		_ <- Utility.boolSystem "chmod" ["+rw", "-R", dir]
+		removeDirectoryRecursive dir
+
+tmpdir :: String	
+tmpdir = ".t"
+
+repodir :: String
+repodir = tmpdir ++ "/repo"
+
+tmprepodir :: String
+tmprepodir = tmpdir ++ "/tmprepo"