Split Test.hs and avoid optimising it much, to need less memory to compile.

The ghc options were found by Sean Whitton; the debian arm autobuilders
need those to build w/o OOM, and it seems to involve llvm using too much
memory to optimize Test.

This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.

4 files changed, 541 insertions, 505 deletions

diff --git a/CHANGELOG b/CHANGELOG
index dba74a8ec..7d75e70d1 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -15,6 +15,8 @@ git-annex (6.20180113) UNRELEASED; urgency=medium
     last line.
   * git-annex.cabal: Once more try to not build the assistant on the hurd,
     hopefully hackage finally recognises that OS.
+  * Split Test.hs and avoid optimising it much, to need less memory to
+    compile.
 
  -- Joey Hess <id@joeyh.name>  Wed, 24 Jan 2018 20:42:55 -0400
 
diff --git a/Test.hs b/Test.hs
index 2f198a165..12999b48f 100644
--- a/Test.hs
+++ b/Test.hs
@@ -6,10 +6,13 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{- Avoid optimising this file much, since it's large and does not need it._-}
+{-# OPTIONS_GHC -O1 -optlo-O2 #-}
 
 module Test where
 
 import Types.Test
+import Test.Framework
 import Options.Applicative.Types
 
 import Test.Tasty
@@ -29,12 +32,8 @@ import CmdLine.GitAnnex.Options
 
 import qualified Utility.SafeCommand
 import qualified Annex
-import qualified Annex.UUID
 import qualified Annex.Version
-import qualified Backend
-import qualified Git.CurrentRepo
 import qualified Git.Filename
-import qualified Git.Construct
 import qualified Git.Types
 import qualified Git.Ref
 import qualified Git.LsTree
@@ -43,8 +42,6 @@ import qualified Annex.Locations
 #ifndef mingw32_HOST_OS
 import qualified Types.GitConfig
 #endif
-import qualified Types.KeySource
-import qualified Types.Backend
 import qualified Types.TrustLevel
 import qualified Types
 import qualified Logs.MapLog
@@ -57,14 +54,11 @@ import qualified Logs.PreferredContent
 import qualified Types.MetaData
 import qualified Remote
 import qualified Key
-import qualified Types.Key
-import qualified Types.Messages
 import qualified Config
 import qualified Config.Cost
 import qualified Crypto
 import qualified Database.Keys
 import qualified Annex.WorkTree
-import qualified Annex.Link
 import qualified Annex.Init
 import qualified Annex.CatFile
 import qualified Annex.Path
@@ -72,7 +66,6 @@ import qualified Annex.AdjustedBranch
 import qualified Annex.VectorClock
 import qualified Annex.View
 import qualified Annex.View.ViewedFile
-import qualified Annex.Action
 import qualified Logs.View
 import qualified Utility.Path
 import qualified Utility.FileMode
@@ -85,17 +78,13 @@ import qualified Utility.InodeCache
 import qualified Utility.Env
 import qualified Utility.Env.Set
 import qualified Utility.Matcher
-import qualified Utility.Exception
 import qualified Utility.Hash
 import qualified Utility.Scheduled
 import qualified Utility.Scheduled.QuickCheck
 import qualified Utility.HumanTime
-import qualified Utility.ThreadScheduler
 import qualified Utility.Base64
 import qualified Utility.Tmp.Dir
 import qualified Utility.FileSystemEncoding
-import qualified Command.Uninit
-import qualified CmdLine.GitAnnex as GitAnnex
 #ifndef mingw32_HOST_OS
 import qualified Remote.Helper.Encryptable
 import qualified Types.Crypto
@@ -158,7 +147,7 @@ ingredients =
 
 tests :: Bool -> TestOptions -> TestTree
 tests crippledfilesystem opts = testGroup "Tests" $ properties :
-	map (\(d, te) -> withTestMode te (unitTests d)) testmodes
+	map (\(d, te) -> withTestMode te initTests (unitTests d)) testmodes
   where
 	testmodes = catMaybes
 		[ Just ("v6 unlocked", (testMode opts "6") { unlockedFiles = True })
@@ -1734,493 +1723,3 @@ test_addurl = intmpclonerepo $ do
 	let dest = "addurlurldest"
 	git_annex "addurl" ["--file", dest, url] @? ("addurl failed on " ++ url ++ "  with --file")
 	doesFileExist dest @? (dest ++ " missing after addurl --file")
-
--- This is equivilant to running git-annex, but it's all run in-process
--- so test coverage collection works.
-git_annex :: String -> [String] -> IO Bool
-git_annex command params = do
-	-- catch all errors, including normally fatal errors
-	r <- try run ::IO (Either SomeException ())
-	case r of
-		Right _ -> return True
-		Left _ -> return False
-  where
-	run = GitAnnex.run optParser Nothing (command:"-q":params)
-
-{- Runs git-annex and returns its output. -}
-git_annex_output :: String -> [String] -> IO String
-git_annex_output command params = do
-	pp <- Annex.Path.programPath
-	got <- Utility.Process.readProcess pp (command:params)
-	-- Since the above is a separate process, code coverage stats are
-	-- not gathered for things run in it.
-	-- Run same command again, to get code coverage.
-	_ <- git_annex command params
-	return got
-
-git_annex_expectoutput :: String -> [String] -> [String] -> IO ()
-git_annex_expectoutput command params expected = do
-	got <- lines <$> git_annex_output command params
-	got == expected @? ("unexpected value running " ++ command ++ " " ++ show params ++ " -- got: " ++ show got ++ " expected: " ++ show expected)
-
--- Runs an action in the current annex. Note that shutdown actions
--- are not run; this should only be used for actions that query state.
-annexeval :: Types.Annex a -> IO a
-annexeval a = do
-	s <- Annex.new =<< Git.CurrentRepo.get
-	Annex.eval s $ do
-		Annex.setOutput Types.Messages.QuietOutput
-		a `finally` Annex.Action.stopCoProcesses
-
-innewrepo :: Assertion -> Assertion
-innewrepo a = withgitrepo $ \r -> indir r a
-
-inmainrepo :: Assertion -> Assertion
-inmainrepo = indir mainrepodir
-
-with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion)
-with_ssh_origin cloner a = cloner $ do
-	origindir <- absPath
-		=<< annexeval (Config.getConfig (Config.ConfigKey config) "/dev/null")
-	let originurl = "localhost:" ++ origindir
-	boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed"
-	a
-  where
-	config = "remote.origin.url"
-
-intmpclonerepo :: Assertion -> Assertion
-intmpclonerepo a = withtmpclonerepo $ \r -> indir r a
-
-intmpclonerepoInDirect :: Assertion -> Assertion
-intmpclonerepoInDirect a = intmpclonerepo $
-	ifM isdirect
-		( putStrLn "not supported in direct mode; skipping"
-		, a
-		)
-  where
-	isdirect = annexeval $ do
-		Annex.Init.initialize (Annex.Init.AutoInit False) Nothing Nothing
-		Config.isDirect
-
-checkRepo :: Types.Annex a -> FilePath -> IO a
-checkRepo getval d = do
-	s <- Annex.new =<< Git.Construct.fromPath d
-	Annex.eval s $
-		getval `finally` Annex.Action.stopCoProcesses
-
-isInDirect :: FilePath -> IO Bool
-isInDirect = checkRepo (not <$> Config.isDirect)
-
-intmpbareclonerepo :: Assertion -> Assertion
-intmpbareclonerepo a = withtmpclonerepo' (newCloneRepoConfig { bareClone = True } ) $
-	\r -> indir r a
-
-intmpsharedclonerepo :: Assertion -> Assertion
-intmpsharedclonerepo a = withtmpclonerepo' (newCloneRepoConfig { sharedClone = True } ) $
-	\r -> indir r a
-
-withtmpclonerepo :: (FilePath -> Assertion) -> Assertion
-withtmpclonerepo = withtmpclonerepo' newCloneRepoConfig
-
-withtmpclonerepo' :: CloneRepoConfig -> (FilePath -> Assertion) -> Assertion
-withtmpclonerepo' cfg a = do
-	dir <- tmprepodir
-	clone <- clonerepo mainrepodir dir cfg
-	r <- tryNonAsync (a clone)
-	case r of
-		Right () -> return ()
-		Left e -> do
-			whenM (keepFailures <$> getTestMode) $
-				putStrLn $ "** Preserving repo for failure analysis in " ++ clone
-			throwM e
-
-disconnectOrigin :: Assertion
-disconnectOrigin = boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "remote rm"
-
-withgitrepo :: (FilePath -> Assertion) -> Assertion
-withgitrepo = bracket (setuprepo mainrepodir) return
-
-indir :: FilePath -> Assertion -> Assertion
-indir dir a = do
-	currdir <- getCurrentDirectory
-	-- Assertion failures throw non-IO errors; catch
-	-- any type of error and change back to currdir before
-	-- rethrowing.
-	r <- bracket_ (changeToTmpDir dir) (setCurrentDirectory currdir)
-		(try a::IO (Either SomeException ()))
-	case r of
-		Right () -> return ()
-		Left e -> throwM e
-
-setuprepo :: FilePath -> IO FilePath
-setuprepo dir = do
-	cleanup dir
-	ensuretmpdir
-	boolSystem "git" [Param "init", Param "-q", File dir] @? "git init failed"
-	configrepo dir
-	return dir
-
-data CloneRepoConfig = CloneRepoConfig
-	{ bareClone :: Bool
-	, sharedClone :: Bool
-	}
-
-newCloneRepoConfig :: CloneRepoConfig
-newCloneRepoConfig = CloneRepoConfig
-	{ bareClone = False
-	, sharedClone = False
-	}
-
--- clones are always done as local clones; we cannot test ssh clones
-clonerepo :: FilePath -> FilePath -> CloneRepoConfig -> IO FilePath
-clonerepo old new cfg = do
-	cleanup new
-	ensuretmpdir
-	let cloneparams = catMaybes
-		[ Just $ Param "clone"
-		, Just $ Param "-q"
-		, if bareClone cfg then Just (Param "--bare") else Nothing
-		, if sharedClone cfg then Just (Param "--shared") else Nothing
-		, Just $ File old
-		, Just $ File new
-		]
-	boolSystem "git" cloneparams @? "git clone failed"
-	configrepo new
-	indir new $ do
-		ver <- annexVersion <$> getTestMode
-		if ver == Annex.Version.defaultVersion
-			then git_annex "init" ["-q", new] @? "git annex init failed"
-			else git_annex "init" ["-q", new, "--version", ver] @? "git annex init failed"
-	unless (bareClone cfg) $
-		indir new $
-			setupTestMode
-	return new
-
-configrepo :: FilePath -> IO ()
-configrepo dir = indir dir $ do
-	-- ensure git is set up to let commits happen
-	boolSystem "git" [Param "config", Param "user.name", Param "Test User"] @? "git config failed"
-	boolSystem "git" [Param "config", Param "user.email", Param "test@example.com"] @? "git config failed"
-	-- avoid signed commits by test suite
-	boolSystem "git" [Param "config", Param "commit.gpgsign", Param "false"] @? "git config failed"
-	-- tell git-annex to not annex the ingitfile
-	boolSystem "git"
-		[ Param "config"
-		, Param "annex.largefiles"
-		, Param ("exclude=" ++ ingitfile)
-		] @? "git config annex.largefiles failed"
-
-ensuretmpdir :: IO ()
-ensuretmpdir = do
-	e <- doesDirectoryExist tmpdir
-	unless e $
-		createDirectory tmpdir
-	
-{- Prevent global git configs from affecting the test suite. -}
-isolateGitConfig :: IO a -> IO a
-isolateGitConfig a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do
-	tmphomeabs <- absPath tmphome
-	Utility.Env.Set.setEnv "HOME" tmphomeabs True
-	Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True
-	Utility.Env.Set.setEnv "GIT_CONFIG_NOSYSTEM" "1" True
-	a
-
-cleanup :: FilePath -> IO ()
-cleanup dir = whenM (doesDirectoryExist dir) $ do
-	Command.Uninit.prepareRemoveAnnexDir' dir
-	-- This can fail if files in the directory are still open by a
-	-- subprocess.
-	void $ tryIO $ removeDirectoryRecursive dir
-
-finalCleanup :: IO ()
-finalCleanup = whenM (doesDirectoryExist tmpdir) $ do
-	Annex.Action.reapZombies
-	Command.Uninit.prepareRemoveAnnexDir' tmpdir
-	catchIO (removeDirectoryRecursive tmpdir) $ \e -> do
-		print e
-		putStrLn "sleeping 10 seconds and will retry directory cleanup"
-		Utility.ThreadScheduler.threadDelaySeconds $
-			Utility.ThreadScheduler.Seconds 10
-		whenM (doesDirectoryExist tmpdir) $ do
-			Annex.Action.reapZombies
-			removeDirectoryRecursive tmpdir
-	
-checklink :: FilePath -> Assertion
-checklink f =
-	-- in direct mode, it may be a symlink, or not, depending
-	-- on whether the content is present.
-	unlessM (annexeval Config.isDirect) $
-		ifM (annexeval Config.crippledFileSystem)
-			( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget f))
-				@? f ++ " is not a (crippled) symlink"
-			, do
-				s <- getSymbolicLinkStatus f
-				isSymbolicLink s @? f ++ " is not a symlink"
-			)
-
-checkregularfile :: FilePath -> Assertion
-checkregularfile f = do
-	s <- getSymbolicLinkStatus f
-	isRegularFile s @? f ++ " is not a normal file"
-	return ()
-
-checkdoesnotexist :: FilePath -> Assertion
-checkdoesnotexist f = 
-	(either (const True) (const False) <$> Utility.Exception.tryIO (getSymbolicLinkStatus f))
-		@? f ++ " exists unexpectedly"
-
-checkexists :: FilePath -> Assertion
-checkexists f = 
-	(either (const False) (const True) <$> Utility.Exception.tryIO (getSymbolicLinkStatus f))
-		@? f ++ " does not exist"
-
-checkcontent :: FilePath -> Assertion
-checkcontent f = do
-	c <- Utility.Exception.catchDefaultIO "could not read file" $ readFile f
-	assertEqual ("checkcontent " ++ f) (content f) c
-
-checkunwritable :: FilePath -> Assertion
-checkunwritable f = unlessM (annexeval Config.isDirect) $ do
-	-- Look at permissions bits rather than trying to write or
-	-- using fileAccess because if run as root, any file can be
-	-- modified despite permissions.
-	s <- getFileStatus f
-	let mode = fileMode s
-	when (mode == mode `unionFileModes` ownerWriteMode) $
-		assertFailure $ "able to modify annexed file's " ++ f ++ " content"
-
-checkwritable :: FilePath -> Assertion
-checkwritable f = do
-	s <- getFileStatus f
-	let mode = fileMode s
-	unless (mode == mode `unionFileModes` ownerWriteMode) $
-		assertFailure $ "unable to modify " ++ f
-
-checkdangling :: FilePath -> Assertion
-checkdangling f = ifM (annexeval Config.crippledFileSystem)
-	( return () -- probably no real symlinks to test
-	, do
-		r <- tryIO $ readFile f
-		case r of
-			Left _ -> return () -- expected; dangling link
-			Right _ -> assertFailure $ f ++ " was not a dangling link as expected"
-	)
-
-checklocationlog :: FilePath -> Bool -> Assertion
-checklocationlog f expected = do
-	thisuuid <- annexeval Annex.UUID.getUUID
-	r <- annexeval $ Annex.WorkTree.lookupFile f
-	case r of
-		Just k -> do
-			uuids <- annexeval $ Remote.keyLocations k
-			assertEqual ("bad content in location log for " ++ f ++ " key " ++ Key.key2file k ++ " uuid " ++ show thisuuid)
-				expected (thisuuid `elem` uuids)
-		_ -> assertFailure $ f ++ " failed to look up key"
-
-checkbackend :: FilePath -> Types.Backend -> Assertion
-checkbackend file expected = do
-	b <- annexeval $ maybe (return Nothing) (Backend.getBackend file) 
-		=<< Annex.WorkTree.lookupFile file
-	assertEqual ("backend for " ++ file) (Just expected) b
-
-checkispointerfile :: FilePath -> Assertion
-checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile f) $
-	assertFailure $ f ++ " is not a pointer file"
-
-inlocationlog :: FilePath -> Assertion
-inlocationlog f = checklocationlog f True
-
-notinlocationlog :: FilePath -> Assertion
-notinlocationlog f = checklocationlog f False
-
-runchecks :: [FilePath -> Assertion] -> FilePath -> Assertion
-runchecks [] _ = return ()
-runchecks (a:as) f = do
-	a f
-	runchecks as f
-
-annexed_notpresent :: FilePath -> Assertion
-annexed_notpresent f = ifM (unlockedFiles <$> getTestMode)
-	( annexed_notpresent_unlocked f
-	, annexed_notpresent_locked f
-	)
-
-annexed_notpresent_locked :: FilePath -> Assertion
-annexed_notpresent_locked = runchecks [checklink, checkdangling, notinlocationlog]
-
-annexed_notpresent_unlocked :: FilePath -> Assertion
-annexed_notpresent_unlocked = runchecks [checkregularfile, checkispointerfile, notinlocationlog]
-
-annexed_present :: FilePath -> Assertion
-annexed_present f = ifM (unlockedFiles <$> getTestMode)
-	( annexed_present_unlocked f
-	, annexed_present_locked f
-	)
-
-annexed_present_locked :: FilePath -> Assertion
-annexed_present_locked f = ifM (annexeval Config.crippledFileSystem)
-	( runchecks [checklink, inlocationlog] f
-	, runchecks [checklink, checkcontent, checkunwritable, inlocationlog] f
-	)
-
-annexed_present_unlocked :: FilePath -> Assertion
-annexed_present_unlocked = runchecks
-	[checkregularfile, checkcontent, checkwritable, inlocationlog]
-
-unannexed :: FilePath -> Assertion
-unannexed = runchecks [checkregularfile, checkcontent, checkwritable]
-
-add_annex :: FilePath -> IO Bool
-add_annex f = ifM (unlockedFiles <$> getTestMode)
-	( boolSystem "git" [Param "add", File f]
-	, git_annex "add" [f]
-	)
-
-data TestMode = TestMode
-	{ forceDirect :: Bool
-	, unlockedFiles :: Bool
-	, annexVersion :: Annex.Version.Version
-	, keepFailures :: Bool
-	} deriving (Read, Show)
-
-testMode :: TestOptions -> Annex.Version.Version -> TestMode
-testMode opts v = TestMode
-	{ forceDirect = False
-	, unlockedFiles = False
-	, annexVersion = v
-	, keepFailures = keepFailuresOption opts
-	}
-
-withTestMode :: TestMode -> TestTree -> TestTree
-withTestMode testmode = withResource prepare release . const
-  where
-	prepare = do
-		setTestMode testmode
-		case tryIngredients [consoleTestReporter] mempty initTests of
-			Nothing -> error "No tests found!?"
-			Just act -> unlessM act $
-				error "init tests failed! cannot continue"
-		return ()
-	release _ = cleanup mainrepodir
-
-setTestMode :: TestMode -> IO ()
-setTestMode testmode = do
-	currdir <- getCurrentDirectory
-	p <- Utility.Env.getEnvDefault "PATH" ""
-
-	mapM_ (\(var, val) -> Utility.Env.Set.setEnv var val True)
-		-- Ensure that the just-built git annex is used.
-		[ ("PATH", currdir ++ [searchPathSeparator] ++ p)
-		, ("TOPDIR", currdir)
-		-- Avoid git complaining if it cannot determine the user's
-		-- email address, or exploding if it doesn't know the user's
-		-- name.
-		, ("GIT_AUTHOR_EMAIL", "test@example.com")
-		, ("GIT_AUTHOR_NAME", "git-annex test")
-		, ("GIT_COMMITTER_EMAIL", "test@example.com")
-		, ("GIT_COMMITTER_NAME", "git-annex test")
-		-- force gpg into batch mode for the tests
-		, ("GPG_BATCH", "1")
-		-- Make git and git-annex access ssh remotes on the local
-		-- filesystem, without using ssh at all.
-		, ("GIT_SSH_COMMAND", "git-annex test --fakessh --")
-		, ("GIT_ANNEX_USE_GIT_SSH", "1")
-		, ("TESTMODE", show testmode)
-		]
-
-runFakeSsh :: [String] -> IO ()
-runFakeSsh ("-n":ps) = runFakeSsh ps
-runFakeSsh (_host:cmd:[]) = do
-	(_, _, _, pid) <- createProcess (shell cmd)
-	exitWith =<< waitForProcess pid
-runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps
-
-getTestMode :: IO TestMode
-getTestMode = Prelude.read <$> Utility.Env.getEnvDefault "TESTMODE" ""
-
-setupTestMode :: IO ()
-setupTestMode = do
-	testmode <- getTestMode
-	when (forceDirect testmode) $
-		git_annex "direct" ["-q"] @? "git annex direct failed"
-
-changeToTmpDir :: FilePath -> IO ()
-changeToTmpDir t = do
-	topdir <- Utility.Env.getEnvDefault "TOPDIR" (error "TOPDIR not set")
-	setCurrentDirectory $ topdir ++ "/" ++ t
-
-tmpdir :: String
-tmpdir = ".t"
-
-mainrepodir :: FilePath
-mainrepodir = tmpdir </> "repo"
-
-tmprepodir :: IO FilePath
-tmprepodir = go (0 :: Int)
-  where
-	go n = do
-		let d = tmpdir </> "tmprepo" ++ show n
-		ifM (doesDirectoryExist d)
-			( go $ n + 1
-			, return d
-			)
-
-annexedfile :: String
-annexedfile = "foo"
-
-annexedfiledup :: String
-annexedfiledup = "foodup"
-
-wormannexedfile :: String
-wormannexedfile = "apple"
-
-sha1annexedfile :: String
-sha1annexedfile = "sha1foo"
-
-sha1annexedfiledup :: String
-sha1annexedfiledup = "sha1foodup"
-
-ingitfile :: String
-ingitfile = "bar.c"
-
-content :: FilePath -> String		
-content f
-	| f == annexedfile = "annexed file content"
-	| f == ingitfile = "normal file content"
-	| f == sha1annexedfile ="sha1 annexed file content"
-	| f == annexedfiledup = content annexedfile
-	| f == sha1annexedfiledup = content sha1annexedfile
-	| f == wormannexedfile = "worm annexed file content"
-	| "import" `isPrefixOf` f = "imported content"
-	| otherwise = "unknown file " ++ f
-
-changecontent :: FilePath -> IO ()
-changecontent f = writeFile f $ changedcontent f
-
-changedcontent :: FilePath -> String
-changedcontent f = content f ++ " (modified)"
-
-backendSHA1 :: Types.Backend
-backendSHA1 = backend_ "SHA1"
-
-backendSHA256 :: Types.Backend
-backendSHA256 = backend_ "SHA256"
-
-backendSHA256E :: Types.Backend
-backendSHA256E = backend_ "SHA256E"
-
-backendWORM :: Types.Backend
-backendWORM = backend_ "WORM"
-
-backend_ :: String -> Types.Backend
-backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety
-
-getKey :: Types.Backend -> FilePath -> IO Types.Key
-getKey b f = fromJust <$> annexeval go
-  where
-	go = Types.Backend.getKey b
-		Types.KeySource.KeySource
-			{ Types.KeySource.keyFilename = f
-			, Types.KeySource.contentLocation = f
-			, Types.KeySource.inodeCache = Nothing
-			}
diff --git a/Test/Framework.hs b/Test/Framework.hs
new file mode 100644
index 000000000..c5908faf9
--- /dev/null
+++ b/Test/Framework.hs
@@ -0,0 +1,534 @@
+{- git-annex test suite framework
+ -
+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Test.Framework where
+
+import Test.Tasty
+import Test.Tasty.Runners
+import Test.Tasty.HUnit
+
+import Common
+import Types.Test
+
+import qualified Annex
+import qualified Annex.UUID
+import qualified Annex.Version
+import qualified Backend
+import qualified Git.CurrentRepo
+import qualified Git.Construct
+import qualified Types.KeySource
+import qualified Types.Backend
+import qualified Types
+import qualified Remote
+import qualified Key
+import qualified Types.Key
+import qualified Types.Messages
+import qualified Config
+import qualified Annex.WorkTree
+import qualified Annex.Link
+import qualified Annex.Init
+import qualified Annex.Path
+import qualified Annex.Action
+import qualified Utility.Process
+import qualified Utility.Env
+import qualified Utility.Env.Set
+import qualified Utility.Exception
+import qualified Utility.ThreadScheduler
+import qualified Utility.Tmp.Dir
+import qualified Command.Uninit
+import qualified CmdLine.GitAnnex as GitAnnex
+
+-- This is equivilant to running git-annex, but it's all run in-process
+-- so test coverage collection works.
+git_annex :: String -> [String] -> IO Bool
+git_annex command params = do
+	-- catch all errors, including normally fatal errors
+	r <- try run ::IO (Either SomeException ())
+	case r of
+		Right _ -> return True
+		Left _ -> return False
+  where
+	run = GitAnnex.run dummyTestOptParser Nothing (command:"-q":params)
+	dummyTestOptParser = pure mempty
+
+{- Runs git-annex and returns its output. -}
+git_annex_output :: String -> [String] -> IO String
+git_annex_output command params = do
+	pp <- Annex.Path.programPath
+	got <- Utility.Process.readProcess pp (command:params)
+	-- Since the above is a separate process, code coverage stats are
+	-- not gathered for things run in it.
+	-- Run same command again, to get code coverage.
+	_ <- git_annex command params
+	return got
+
+git_annex_expectoutput :: String -> [String] -> [String] -> IO ()
+git_annex_expectoutput command params expected = do
+	got <- lines <$> git_annex_output command params
+	got == expected @? ("unexpected value running " ++ command ++ " " ++ show params ++ " -- got: " ++ show got ++ " expected: " ++ show expected)
+
+-- Runs an action in the current annex. Note that shutdown actions
+-- are not run; this should only be used for actions that query state.
+annexeval :: Types.Annex a -> IO a
+annexeval a = do
+	s <- Annex.new =<< Git.CurrentRepo.get
+	Annex.eval s $ do
+		Annex.setOutput Types.Messages.QuietOutput
+		a `finally` Annex.Action.stopCoProcesses
+
+innewrepo :: Assertion -> Assertion
+innewrepo a = withgitrepo $ \r -> indir r a
+
+inmainrepo :: Assertion -> Assertion
+inmainrepo = indir mainrepodir
+
+with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion)
+with_ssh_origin cloner a = cloner $ do
+	origindir <- absPath
+		=<< annexeval (Config.getConfig (Config.ConfigKey config) "/dev/null")
+	let originurl = "localhost:" ++ origindir
+	boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed"
+	a
+  where
+	config = "remote.origin.url"
+
+intmpclonerepo :: Assertion -> Assertion
+intmpclonerepo a = withtmpclonerepo $ \r -> indir r a
+
+intmpclonerepoInDirect :: Assertion -> Assertion
+intmpclonerepoInDirect a = intmpclonerepo $
+	ifM isdirect
+		( putStrLn "not supported in direct mode; skipping"
+		, a
+		)
+  where
+	isdirect = annexeval $ do
+		Annex.Init.initialize (Annex.Init.AutoInit False) Nothing Nothing
+		Config.isDirect
+
+checkRepo :: Types.Annex a -> FilePath -> IO a
+checkRepo getval d = do
+	s <- Annex.new =<< Git.Construct.fromPath d
+	Annex.eval s $
+		getval `finally` Annex.Action.stopCoProcesses
+
+isInDirect :: FilePath -> IO Bool
+isInDirect = checkRepo (not <$> Config.isDirect)
+
+intmpbareclonerepo :: Assertion -> Assertion
+intmpbareclonerepo a = withtmpclonerepo' (newCloneRepoConfig { bareClone = True } ) $
+	\r -> indir r a
+
+intmpsharedclonerepo :: Assertion -> Assertion
+intmpsharedclonerepo a = withtmpclonerepo' (newCloneRepoConfig { sharedClone = True } ) $
+	\r -> indir r a
+
+withtmpclonerepo :: (FilePath -> Assertion) -> Assertion
+withtmpclonerepo = withtmpclonerepo' newCloneRepoConfig
+
+withtmpclonerepo' :: CloneRepoConfig -> (FilePath -> Assertion) -> Assertion
+withtmpclonerepo' cfg a = do
+	dir <- tmprepodir
+	clone <- clonerepo mainrepodir dir cfg
+	r <- tryNonAsync (a clone)
+	case r of
+		Right () -> return ()
+		Left e -> do
+			whenM (keepFailures <$> getTestMode) $
+				putStrLn $ "** Preserving repo for failure analysis in " ++ clone
+			throwM e
+
+disconnectOrigin :: Assertion
+disconnectOrigin = boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "remote rm"
+
+withgitrepo :: (FilePath -> Assertion) -> Assertion
+withgitrepo = bracket (setuprepo mainrepodir) return
+
+indir :: FilePath -> Assertion -> Assertion
+indir dir a = do
+	currdir <- getCurrentDirectory
+	-- Assertion failures throw non-IO errors; catch
+	-- any type of error and change back to currdir before
+	-- rethrowing.
+	r <- bracket_ (changeToTmpDir dir) (setCurrentDirectory currdir)
+		(try a::IO (Either SomeException ()))
+	case r of
+		Right () -> return ()
+		Left e -> throwM e
+
+setuprepo :: FilePath -> IO FilePath
+setuprepo dir = do
+	cleanup dir
+	ensuretmpdir
+	boolSystem "git" [Param "init", Param "-q", File dir] @? "git init failed"
+	configrepo dir
+	return dir
+
+data CloneRepoConfig = CloneRepoConfig
+	{ bareClone :: Bool
+	, sharedClone :: Bool
+	}
+
+newCloneRepoConfig :: CloneRepoConfig
+newCloneRepoConfig = CloneRepoConfig
+	{ bareClone = False
+	, sharedClone = False
+	}
+
+-- clones are always done as local clones; we cannot test ssh clones
+clonerepo :: FilePath -> FilePath -> CloneRepoConfig -> IO FilePath
+clonerepo old new cfg = do
+	cleanup new
+	ensuretmpdir
+	let cloneparams = catMaybes
+		[ Just $ Param "clone"
+		, Just $ Param "-q"
+		, if bareClone cfg then Just (Param "--bare") else Nothing
+		, if sharedClone cfg then Just (Param "--shared") else Nothing
+		, Just $ File old
+		, Just $ File new
+		]
+	boolSystem "git" cloneparams @? "git clone failed"
+	configrepo new
+	indir new $ do
+		ver <- annexVersion <$> getTestMode
+		if ver == Annex.Version.defaultVersion
+			then git_annex "init" ["-q", new] @? "git annex init failed"
+			else git_annex "init" ["-q", new, "--version", ver] @? "git annex init failed"
+	unless (bareClone cfg) $
+		indir new $
+			setupTestMode
+	return new
+
+configrepo :: FilePath -> IO ()
+configrepo dir = indir dir $ do
+	-- ensure git is set up to let commits happen
+	boolSystem "git" [Param "config", Param "user.name", Param "Test User"] @? "git config failed"
+	boolSystem "git" [Param "config", Param "user.email", Param "test@example.com"] @? "git config failed"
+	-- avoid signed commits by test suite
+	boolSystem "git" [Param "config", Param "commit.gpgsign", Param "false"] @? "git config failed"
+	-- tell git-annex to not annex the ingitfile
+	boolSystem "git"
+		[ Param "config"
+		, Param "annex.largefiles"
+		, Param ("exclude=" ++ ingitfile)
+		] @? "git config annex.largefiles failed"
+
+ensuretmpdir :: IO ()
+ensuretmpdir = do
+	e <- doesDirectoryExist tmpdir
+	unless e $
+		createDirectory tmpdir
+	
+{- Prevent global git configs from affecting the test suite. -}
+isolateGitConfig :: IO a -> IO a
+isolateGitConfig a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do
+	tmphomeabs <- absPath tmphome
+	Utility.Env.Set.setEnv "HOME" tmphomeabs True
+	Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True
+	Utility.Env.Set.setEnv "GIT_CONFIG_NOSYSTEM" "1" True
+	a
+
+cleanup :: FilePath -> IO ()
+cleanup dir = whenM (doesDirectoryExist dir) $ do
+	Command.Uninit.prepareRemoveAnnexDir' dir
+	-- This can fail if files in the directory are still open by a
+	-- subprocess.
+	void $ tryIO $ removeDirectoryRecursive dir
+
+finalCleanup :: IO ()
+finalCleanup = whenM (doesDirectoryExist tmpdir) $ do
+	Annex.Action.reapZombies
+	Command.Uninit.prepareRemoveAnnexDir' tmpdir
+	catchIO (removeDirectoryRecursive tmpdir) $ \e -> do
+		print e
+		putStrLn "sleeping 10 seconds and will retry directory cleanup"
+		Utility.ThreadScheduler.threadDelaySeconds $
+			Utility.ThreadScheduler.Seconds 10
+		whenM (doesDirectoryExist tmpdir) $ do
+			Annex.Action.reapZombies
+			removeDirectoryRecursive tmpdir
+	
+checklink :: FilePath -> Assertion
+checklink f =
+	-- in direct mode, it may be a symlink, or not, depending
+	-- on whether the content is present.
+	unlessM (annexeval Config.isDirect) $
+		ifM (annexeval Config.crippledFileSystem)
+			( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget f))
+				@? f ++ " is not a (crippled) symlink"
+			, do
+				s <- getSymbolicLinkStatus f
+				isSymbolicLink s @? f ++ " is not a symlink"
+			)
+
+checkregularfile :: FilePath -> Assertion
+checkregularfile f = do
+	s <- getSymbolicLinkStatus f
+	isRegularFile s @? f ++ " is not a normal file"
+	return ()
+
+checkdoesnotexist :: FilePath -> Assertion
+checkdoesnotexist f = 
+	(either (const True) (const False) <$> Utility.Exception.tryIO (getSymbolicLinkStatus f))
+		@? f ++ " exists unexpectedly"
+
+checkexists :: FilePath -> Assertion
+checkexists f = 
+	(either (const False) (const True) <$> Utility.Exception.tryIO (getSymbolicLinkStatus f))
+		@? f ++ " does not exist"
+
+checkcontent :: FilePath -> Assertion
+checkcontent f = do
+	c <- Utility.Exception.catchDefaultIO "could not read file" $ readFile f
+	assertEqual ("checkcontent " ++ f) (content f) c
+
+checkunwritable :: FilePath -> Assertion
+checkunwritable f = unlessM (annexeval Config.isDirect) $ do
+	-- Look at permissions bits rather than trying to write or
+	-- using fileAccess because if run as root, any file can be
+	-- modified despite permissions.
+	s <- getFileStatus f
+	let mode = fileMode s
+	when (mode == mode `unionFileModes` ownerWriteMode) $
+		assertFailure $ "able to modify annexed file's " ++ f ++ " content"
+
+checkwritable :: FilePath -> Assertion
+checkwritable f = do
+	s <- getFileStatus f
+	let mode = fileMode s
+	unless (mode == mode `unionFileModes` ownerWriteMode) $
+		assertFailure $ "unable to modify " ++ f
+
+checkdangling :: FilePath -> Assertion
+checkdangling f = ifM (annexeval Config.crippledFileSystem)
+	( return () -- probably no real symlinks to test
+	, do
+		r <- tryIO $ readFile f
+		case r of
+			Left _ -> return () -- expected; dangling link
+			Right _ -> assertFailure $ f ++ " was not a dangling link as expected"
+	)
+
+checklocationlog :: FilePath -> Bool -> Assertion
+checklocationlog f expected = do
+	thisuuid <- annexeval Annex.UUID.getUUID
+	r <- annexeval $ Annex.WorkTree.lookupFile f
+	case r of
+		Just k -> do
+			uuids <- annexeval $ Remote.keyLocations k
+			assertEqual ("bad content in location log for " ++ f ++ " key " ++ Key.key2file k ++ " uuid " ++ show thisuuid)
+				expected (thisuuid `elem` uuids)
+		_ -> assertFailure $ f ++ " failed to look up key"
+
+checkbackend :: FilePath -> Types.Backend -> Assertion
+checkbackend file expected = do
+	b <- annexeval $ maybe (return Nothing) (Backend.getBackend file) 
+		=<< Annex.WorkTree.lookupFile file
+	assertEqual ("backend for " ++ file) (Just expected) b
+
+checkispointerfile :: FilePath -> Assertion
+checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile f) $
+	assertFailure $ f ++ " is not a pointer file"
+
+inlocationlog :: FilePath -> Assertion
+inlocationlog f = checklocationlog f True
+
+notinlocationlog :: FilePath -> Assertion
+notinlocationlog f = checklocationlog f False
+
+runchecks :: [FilePath -> Assertion] -> FilePath -> Assertion
+runchecks [] _ = return ()
+runchecks (a:as) f = do
+	a f
+	runchecks as f
+
+annexed_notpresent :: FilePath -> Assertion
+annexed_notpresent f = ifM (unlockedFiles <$> getTestMode)
+	( annexed_notpresent_unlocked f
+	, annexed_notpresent_locked f
+	)
+
+annexed_notpresent_locked :: FilePath -> Assertion
+annexed_notpresent_locked = runchecks [checklink, checkdangling, notinlocationlog]
+
+annexed_notpresent_unlocked :: FilePath -> Assertion
+annexed_notpresent_unlocked = runchecks [checkregularfile, checkispointerfile, notinlocationlog]
+
+annexed_present :: FilePath -> Assertion
+annexed_present f = ifM (unlockedFiles <$> getTestMode)
+	( annexed_present_unlocked f
+	, annexed_present_locked f
+	)
+
+annexed_present_locked :: FilePath -> Assertion
+annexed_present_locked f = ifM (annexeval Config.crippledFileSystem)
+	( runchecks [checklink, inlocationlog] f
+	, runchecks [checklink, checkcontent, checkunwritable, inlocationlog] f
+	)
+
+annexed_present_unlocked :: FilePath -> Assertion
+annexed_present_unlocked = runchecks
+	[checkregularfile, checkcontent, checkwritable, inlocationlog]
+
+unannexed :: FilePath -> Assertion
+unannexed = runchecks [checkregularfile, checkcontent, checkwritable]
+
+add_annex :: FilePath -> IO Bool
+add_annex f = ifM (unlockedFiles <$> getTestMode)
+	( boolSystem "git" [Param "add", File f]
+	, git_annex "add" [f]
+	)
+
+data TestMode = TestMode
+	{ forceDirect :: Bool
+	, unlockedFiles :: Bool
+	, annexVersion :: Annex.Version.Version
+	, keepFailures :: Bool
+	} deriving (Read, Show)
+
+testMode :: TestOptions -> Annex.Version.Version -> TestMode
+testMode opts v = TestMode
+	{ forceDirect = False
+	, unlockedFiles = False
+	, annexVersion = v
+	, keepFailures = keepFailuresOption opts
+	}
+
+withTestMode :: TestMode -> TestTree -> TestTree -> TestTree
+withTestMode testmode inittests = withResource prepare release . const
+  where
+	prepare = do
+		setTestMode testmode
+		case tryIngredients [consoleTestReporter] mempty inittests of
+			Nothing -> error "No tests found!?"
+			Just act -> unlessM act $
+				error "init tests failed! cannot continue"
+		return ()
+	release _ = cleanup mainrepodir
+
+setTestMode :: TestMode -> IO ()
+setTestMode testmode = do
+	currdir <- getCurrentDirectory
+	p <- Utility.Env.getEnvDefault "PATH" ""
+
+	mapM_ (\(var, val) -> Utility.Env.Set.setEnv var val True)
+		-- Ensure that the just-built git annex is used.
+		[ ("PATH", currdir ++ [searchPathSeparator] ++ p)
+		, ("TOPDIR", currdir)
+		-- Avoid git complaining if it cannot determine the user's
+		-- email address, or exploding if it doesn't know the user's
+		-- name.
+		, ("GIT_AUTHOR_EMAIL", "test@example.com")
+		, ("GIT_AUTHOR_NAME", "git-annex test")
+		, ("GIT_COMMITTER_EMAIL", "test@example.com")
+		, ("GIT_COMMITTER_NAME", "git-annex test")
+		-- force gpg into batch mode for the tests
+		, ("GPG_BATCH", "1")
+		-- Make git and git-annex access ssh remotes on the local
+		-- filesystem, without using ssh at all.
+		, ("GIT_SSH_COMMAND", "git-annex test --fakessh --")
+		, ("GIT_ANNEX_USE_GIT_SSH", "1")
+		, ("TESTMODE", show testmode)
+		]
+
+runFakeSsh :: [String] -> IO ()
+runFakeSsh ("-n":ps) = runFakeSsh ps
+runFakeSsh (_host:cmd:[]) = do
+	(_, _, _, pid) <- createProcess (shell cmd)
+	exitWith =<< waitForProcess pid
+runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps
+
+getTestMode :: IO TestMode
+getTestMode = Prelude.read <$> Utility.Env.getEnvDefault "TESTMODE" ""
+
+setupTestMode :: IO ()
+setupTestMode = do
+	testmode <- getTestMode
+	when (forceDirect testmode) $
+		git_annex "direct" ["-q"] @? "git annex direct failed"
+
+changeToTmpDir :: FilePath -> IO ()
+changeToTmpDir t = do
+	topdir <- Utility.Env.getEnvDefault "TOPDIR" (error "TOPDIR not set")
+	setCurrentDirectory $ topdir ++ "/" ++ t
+
+tmpdir :: String
+tmpdir = ".t"
+
+mainrepodir :: FilePath
+mainrepodir = tmpdir </> "repo"
+
+tmprepodir :: IO FilePath
+tmprepodir = go (0 :: Int)
+  where
+	go n = do
+		let d = tmpdir </> "tmprepo" ++ show n
+		ifM (doesDirectoryExist d)
+			( go $ n + 1
+			, return d
+			)
+
+annexedfile :: String
+annexedfile = "foo"
+
+annexedfiledup :: String
+annexedfiledup = "foodup"
+
+wormannexedfile :: String
+wormannexedfile = "apple"
+
+sha1annexedfile :: String
+sha1annexedfile = "sha1foo"
+
+sha1annexedfiledup :: String
+sha1annexedfiledup = "sha1foodup"
+
+ingitfile :: String
+ingitfile = "bar.c"
+
+content :: FilePath -> String		
+content f
+	| f == annexedfile = "annexed file content"
+	| f == ingitfile = "normal file content"
+	| f == sha1annexedfile ="sha1 annexed file content"
+	| f == annexedfiledup = content annexedfile
+	| f == sha1annexedfiledup = content sha1annexedfile
+	| f == wormannexedfile = "worm annexed file content"
+	| "import" `isPrefixOf` f = "imported content"
+	| otherwise = "unknown file " ++ f
+
+changecontent :: FilePath -> IO ()
+changecontent f = writeFile f $ changedcontent f
+
+changedcontent :: FilePath -> String
+changedcontent f = content f ++ " (modified)"
+
+backendSHA1 :: Types.Backend
+backendSHA1 = backend_ "SHA1"
+
+backendSHA256 :: Types.Backend
+backendSHA256 = backend_ "SHA256"
+
+backendSHA256E :: Types.Backend
+backendSHA256E = backend_ "SHA256E"
+
+backendWORM :: Types.Backend
+backendWORM = backend_ "WORM"
+
+backend_ :: String -> Types.Backend
+backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety
+
+getKey :: Types.Backend -> FilePath -> IO Types.Key
+getKey b f = fromJust <$> annexeval go
+  where
+	go = Types.Backend.getKey b
+		Types.KeySource.KeySource
+			{ Types.KeySource.keyFilename = f
+			, Types.KeySource.contentLocation = f
+			, Types.KeySource.inodeCache = Nothing
+			}
diff --git a/git-annex.cabal b/git-annex.cabal
index 446695fc8..b02ea2e14 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -943,6 +943,7 @@ Executable git-annex
     RemoteDaemon.Transport.Ssh.Types
     RemoteDaemon.Types
     Test
+    Test.Framework
     Types
     Types.ActionItem
     Types.Availability