Make test suite work better when the temp directory is on NFS.

Deleting directories is one of the great unsolved problems of CS, thanks to
abominations like NFS lock files and Windows and races with other processes
cleaning up after themselves in the background. The gpg test harness
sometimes failed to delete its temp directory on NFS. Avoid the problem
class by not deleting it at all, and putting it inside the tmp repo being
tested. The test suite's more robust (and/or nonsensical) workarounds for
deleting its test dir will thus be used, hopefully avoiding the problem
until an OS finds a new way to violate POSIX and the laws of nature.

Note that this means that the .gnupg directory will be on whatever
filesystem the test suite is being run on, which may be a lesser quality
filesystem than gpg is really expecting. Gpg does not seem to need to
write sockets etc to there so this seems ok. The only known problem is
that if the filesystem forces a directory mode like 777, gpg will warn
about unsafe home directory perms, but it still works.

CHANGELOG

@@ -4,6 +4,7 @@ git-annex (7.20181212) UNRELEASED; urgency=medium
   * sync --content: Support dropping local content that has reached an
     exporttree remote that is not untrusted (currently only S3 remotes
     with versioning).
+  * Make test suite work better when the temp directory is on NFS.
 
  -- Joey Hess <id@joeyh.name>  Tue, 18 Dec 2018 12:24:52 -0400
 

Test.hs

@@ -60,6 +60,7 @@ import qualified Annex.WorkTree
 import qualified Annex.Init
 import qualified Annex.CatFile
 import qualified Annex.Path
+import qualified Annex.Perms
 import qualified Annex.VectorClock
 import qualified Annex.View
 import qualified Annex.View.ViewedFile
@@ -1620,9 +1621,12 @@ test_crypto = do
   where
 	gpgcmd = Utility.Gpg.mkGpgCmd Nothing
 	testscheme scheme = intmpclonerepo $ whenM (Utility.Path.inPath (Utility.Gpg.unGpgCmd gpgcmd)) $ do
-		Utility.Gpg.testTestHarness gpgcmd 
+		gpgtmpdir <- annexeval $ (</> "gpgtest")
+			<$> Annex.fromRepo Annex.Locations.gitAnnexTmpMiscDir
+		annexeval $ Annex.Perms.createAnnexDirectory gpgtmpdir
+		Utility.Gpg.testTestHarness gpgtmpdir gpgcmd 
 			@? "test harness self-test failed"
-		Utility.Gpg.testHarness gpgcmd $ do
+		Utility.Gpg.testHarness gpgtmpdir gpgcmd $ do
 			createDirectory "dir"
 			let a cmd = git_annex cmd $
 				[ "foo"

Utility/FileMode.hs

@@ -69,6 +69,7 @@ otherGroupModes :: [FileMode]
 otherGroupModes = 
 	[ groupReadMode, otherReadMode
 	, groupWriteMode, otherWriteMode
+	, groupExecuteMode, otherExecuteMode
 	]
 
 {- Removes the write bits from a file. -}

Utility/Gpg.hs

@@ -19,7 +19,7 @@ import Utility.Env.Set
 #else
 import Utility.Tmp
 #endif
-import Utility.Tmp.Dir
+import Utility.FileMode
 import Utility.Format (decode_c)
 
 import Control.Concurrent
@@ -347,37 +347,39 @@ keyBlock public ls = unlines
 
 #ifndef mingw32_HOST_OS
 {- Runs an action using gpg in a test harness, in which gpg does
- - not use ~/.gpg/, but a directory with the test key set up to be used. -}
-testHarness :: GpgCmd -> IO a -> IO a
-testHarness cmd a = withTmpDir "gpgtmpXXXXXX" $ \tmpdir ->
-	bracket (setup tmpdir) (cleanup tmpdir) (const a)
+ - not use ~/.gpg/, but sets up the test key in the passed directory
+ - and uses it. -}
+testHarness :: FilePath -> GpgCmd -> IO a -> IO a
+testHarness tmpdir cmd a = bracket setup cleanup (const a)
   where
 	var = "GNUPGHOME"		
 
-	setup tmpdir = do
+	setup = do
 		orig <- getEnv var
-		setEnv var tmpdir True
+		subdir <- makenewdir (1 :: Integer)
+		-- gpg is picky about permissions on its home dir
+		liftIO $ void $ tryIO $ modifyFileMode subdir $
+			removeModes $ otherGroupModes
+		setEnv var subdir True
 		-- For some reason, recent gpg needs a trustdb to be set up.
 		_ <- pipeStrict cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] []
 		_ <- pipeStrict cmd [Param "--import", Param "-q"] $ unlines
 			[testSecretKey, testKey]
 		return orig
 		
-	cleanup tmpdir orig = do
-		removeDirectoryRecursive tmpdir
-			-- gpg-agent may be shutting down at the same time
-			-- and may delete its socket at the same time as
-			-- we're trying to, causing an exception. Retrying
-			-- will deal with this race.
-			`catchIO` (\_ -> removeDirectoryRecursive tmpdir)
-		reset orig
-	reset (Just v) = setEnv var v True
-	reset _ = unsetEnv var
+	cleanup (Just v) = setEnv var v True
+	cleanup Nothing = unsetEnv var
+
+        makenewdir n = do
+		let subdir = tmpdir </> show n
+		catchIOErrorType AlreadyExists (const $ makenewdir $ n + 1) $ do
+			createDirectory subdir
+			return subdir
 
 {- Tests the test harness. -}
-testTestHarness :: GpgCmd -> IO Bool
-testTestHarness cmd = do
-	keys <- testHarness cmd $ findPubKeys cmd testKeyId
+testTestHarness :: FilePath -> GpgCmd -> IO Bool
+testTestHarness tmpdir cmd = do
+	keys <- testHarness tmpdir cmd $ findPubKeys cmd testKeyId
 	return $ KeyIds [testKeyId] == keys
 #endif