merge from git-annex

Fixes 2 bugs, one a data loss bug. It is possible to get those fixes
without merging all the other changes, if a backport is wanted.

1 files changed, 33 insertions, 19 deletions

diff --git a/Git/Repair.hs b/Git/Repair.hs
index 034d7e9..144c96f 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -1,6 +1,6 @@
 {- git repository recovery
  -
- - Copyright 2013-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -29,6 +29,7 @@ import Git.Sha
 import Git.Types
 import Git.Fsck
 import Git.Index
+import Git.Env
 import qualified Git.Config as Config
 import qualified Git.Construct as Construct
 import qualified Git.LsTree as LsTree
@@ -61,15 +62,14 @@ cleanCorruptObjects fsckresults r = do
 		whenM (isMissing s r) $
 			removeLoose s
 
-{- Explodes all pack files, and deletes them.
+{- Explodes all pack files to loose objects, and deletes the pack files.
  -
- - First moves all pack files to a temp dir, before unpacking them each in
- - turn.
+ - git unpack-objects will not unpack objects from a pack file that are
+ - in the git repo. So, GIT_OBJECT_DIRECTORY is pointed to a temporary
+ - directory, and the loose objects then are moved into place, before
+ - deleting the pack files.
  -
- - This is because unpack-objects will not unpack a pack file if it's in the
- - git repo.
- -
- - Also, this prevents unpack-objects from possibly looking at corrupt
+ - Also, that prevents unpack-objects from possibly looking at corrupt
  - pack files to see if they contain an object, while unpacking a
  - non-corrupt pack file.
  -}
@@ -78,18 +78,28 @@ explodePacks r = go =<< listPackFiles r
   where
 	go [] = return False
 	go packs = withTmpDir "packs" $ \tmpdir -> do
+		r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" tmpdir
 		putStrLn "Unpacking all pack files."
 		forM_ packs $ \packfile -> do
-			moveFile packfile (tmpdir </> takeFileName packfile)
-			removeWhenExistsWith R.removeLink
-				(packIdxFile (toRawFilePath packfile))
-		forM_ packs $ \packfile -> do
-			let tmp = tmpdir </> takeFileName packfile
-			allowRead (toRawFilePath tmp)
+			-- Just in case permissions are messed up.
+			allowRead (toRawFilePath packfile)
 			-- May fail, if pack file is corrupt.
 			void $ tryIO $
-				pipeWrite [Param "unpack-objects", Param "-r"] r $ \h ->
-				L.hPut h =<< L.readFile tmp
+				pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h ->
+				L.hPut h =<< L.readFile packfile
+		objs <- dirContentsRecursive tmpdir
+		forM_ objs $ \objfile -> do
+			f <- relPathDirToFile
+				(toRawFilePath tmpdir)
+				(toRawFilePath objfile)
+			let dest = objectsDir r P.</> f
+			createDirectoryIfMissing True
+				(fromRawFilePath (parentDir dest))
+			moveFile objfile (fromRawFilePath dest)
+		forM_ packs $ \packfile -> do
+			let f = toRawFilePath packfile
+			removeWhenExistsWith R.removeLink f
+			removeWhenExistsWith R.removeLink (packIdxFile f)
 		return True
 
 {- Try to retrieve a set of missing objects, from the remotes of a
@@ -105,7 +115,10 @@ retrieveMissingObjects missing referencerepo r
 	| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do
 		unlessM (boolSystem "git" [Param "init", File tmpdir]) $
 			error $ "failed to create temp repository in " ++ tmpdir
-		tmpr <- Config.read =<< Construct.fromAbsPath (toRawFilePath tmpdir)
+		tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir)
+		let repoconfig r' = fromRawFilePath (localGitDir r' P.</> "config")
+		whenM (doesFileExist (repoconfig r)) $
+			L.readFile (repoconfig r) >>= L.writeFile (repoconfig tmpr)
 		rs <- Construct.fromRemotes r
 		stillmissing <- pullremotes tmpr rs fetchrefstags missing
 		if S.null (knownMissing stillmissing)
@@ -351,8 +364,9 @@ verifyTree :: MissingObjects -> Sha -> Repo -> IO Bool
 verifyTree missing treesha r
 	| S.member treesha missing = return False
 	| otherwise = do
-		(ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive treesha []) r
-		let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree) ls
+		let nolong = LsTree.LsTreeLong False
+		(ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive nolong treesha []) r
+		let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree nolong) ls
 		if any (`S.member` missing) objshas
 			then do
 				void cleanup