git-repair 1.20131118 → 1.20131122

raw patch · 20 files changed

+704/−188 lines, 20 filesdep +QuickCheckdep +SHAdep +optparse-applicativedep −pretty-show

Dependencies added: QuickCheck, SHA, optparse-applicative, time

Dependencies removed: pretty-show

Files

• Build/Configure.hs +5/−1
• Build/Version.hs +69/−0
• Git/Destroyer.hs +126/−0
• Git/Fsck.hs +12/−20
• Git/Objects.hs +8/−2
• Git/Repair.hs +157/−137
• Makefile +6/−3
• Utility/FileMode.hs +9/−2
• Utility/Misc.hs +15/−0
• Utility/QuickCheck.hs +48/−0
• Utility/ThreadScheduler.hs +69/−0
• debian/changelog +22/−0
• debian/compat +1/−0
• debian/control +29/−0
• debian/copyright +9/−0
• debian/manpages +1/−0
• debian/rules +10/−0
• doc/index.mdwn +2/−1
• git-repair.cabal +8/−5
• git-repair.hs +98/−17

@@ -7,11 +7,13 @@ import Control.Monad.IfElse  import Build.TestConfig+import Build.Version import Git.Version  tests :: [TestCase] tests =-	[ TestCase "git" $ requireCmd "git" "git --version >/dev/null"+	[ TestCase "version" getVersion+	, TestCase "git" $ requireCmd "git" "git --version >/dev/null" 	, TestCase "git version" getGitVersion 	, TestCase "nice" $ testCmd "nice" "nice true >/dev/null" 	]@@ -25,3 +27,5 @@ 	args <- getArgs 	config <- runTests ts 	writeSysConfig config+	whenM (isReleaseBuild) $+		cabalSetup "git-repair.cabal"

@@ -0,0 +1,69 @@+{- Package version determination, for configure script. -}++module Build.Version where++import Data.Maybe+import Control.Applicative+import Data.List+import System.Environment+import System.Directory+import Data.Char+import System.Process++import Build.TestConfig+import Utility.Monad+import Utility.Exception++{- Set when making an official release. (Distribution vendors should set+ - this too.) -}+isReleaseBuild :: IO Bool+isReleaseBuild = isJust <$> catchMaybeIO (getEnv "RELEASE_BUILD")++{- Version is usually based on the major version from the changelog, + - plus the date of the last commit, plus the git rev of that commit.+ - This works for autobuilds, ad-hoc builds, etc.+ -+ - If git or a git repo is not available, or something goes wrong,+ - or this is a release build, just use the version from the changelog. -}+getVersion :: Test+getVersion = do+	changelogversion <- getChangelogVersion+	version <- ifM (isReleaseBuild)+		( return changelogversion+		, catchDefaultIO changelogversion $ do+			let major = takeWhile (/= '.') changelogversion+			autoversion <- readProcess "sh"+				[ "-c"+				, "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'"+				] ""+			if null autoversion+				then return changelogversion+				else return $ concat [ major, ".", autoversion ]+		)+	return $ Config "packageversion" (StringConfig version)+	+getChangelogVersion :: IO String+getChangelogVersion = do+	changelog <- readFile "debian/changelog"+	let verline = takeWhile (/= '\n') changelog+	return $ middle (words verline !! 1)+  where+	middle = drop 1 . init++{- Set up cabal file with version. -}+cabalSetup :: FilePath -> IO ()+cabalSetup cabalfile = do+	version <- takeWhile (\c -> isDigit c || c == '.')+		<$> getChangelogVersion+	cabal <- readFile cabalfile+	writeFile tmpcabalfile $ unlines $ +		map (setfield "Version" version) $+		lines cabal+	renameFile tmpcabalfile cabalfile+  where+	tmpcabalfile = cabalfile++".tmp"+	setfield field value s+		| fullfield `isPrefixOf` s = fullfield ++ value+		| otherwise = s+	  where+		fullfield = field ++ ": "

@@ -0,0 +1,126 @@+{- git repository destroyer+ -+ - Use with caution!+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.Destroyer (+	Damage(..),+	generateDamage,+	applyDamage+) where++import Common+import Git+import Utility.QuickCheck+import Utility.FileMode++import qualified Data.ByteString as B+import Data.Word+import System.PosixCompat.Types++{- Ways to damange a git repository. -}+data Damage = Damage DamageAction FileSelector+	deriving (Read, Show)++instance Arbitrary Damage where+	arbitrary = Damage <$> arbitrary <*> arbitrary++data DamageAction+	= Empty+	| Delete+	| Reverse+	| AppendGarbage B.ByteString+	| PrependGarbage B.ByteString+	| CorruptByte Int Word8+	| ScrambleFileMode FileMode+	deriving (Read, Show)++instance Arbitrary DamageAction where+	arbitrary = oneof+		[ pure Empty+		, pure Delete+		, pure Reverse+		, AppendGarbage <$> garbage+		, PrependGarbage <$> garbage+		, CorruptByte+			<$> nonNegative arbitraryBoundedIntegral+			<*> arbitrary+		, ScrambleFileMode <$> nonNegative arbitrarySizedIntegral+		]+	  where+		garbage = B.pack <$> arbitrary `suchThat` (not . null)++{- To select a given file in a git repository, all files in the repository+ - are enumerated, sorted, and this is used as an index+ - into the list. (Wrapping around if higher than the length.) -}+data FileSelector = FileSelector Int+	deriving (Read, Show)++instance Arbitrary FileSelector where+	arbitrary = FileSelector <$> oneof+		-- An early file in the git tree, tends to be the most+		-- interesting when there are lots of files.+		[ nonNegative arbitrarySizedIntegral+		-- Totally random choice from any of the files in+		-- the git tree, to ensure good coverage.+		, nonNegative arbitraryBoundedIntegral+		]++selectFile :: [FilePath] -> FileSelector -> FilePath+selectFile sortedfs (FileSelector n) = sortedfs !! (n `mod` length sortedfs)++{- Generates random Damage. -}+generateDamage :: IO [Damage]+generateDamage = sample' (arbitrary :: Gen Damage)++{- Applies Damage to a Repo, in a reproducible fashion+ - (as long as the Repo contains the same files each time). -}+applyDamage :: [Damage] -> Repo -> IO ()+applyDamage l r = do+	contents <- sort . filter (not . skipped . takeFileName)+		<$> dirContentsRecursive (localGitDir r)+	forM_ l $ \(Damage action fileselector) -> do+		let f = selectFile contents fileselector+		-- Symlinks might be dangling, so are skipped.+		-- If the file was already removed by a previous Damage,+		-- it's skipped.+		whenM (doesFileExist f) $+			applyDamageAction action f+				`catchIO` \e -> error ("Failed to apply " ++ show action ++ " " ++ show f ++ ": " ++ show e ++ "(total damage: " ++ show l ++ ")")+  where+  	-- A broken .git/config is not recoverable.+	skipped f = f `elem` [ "config" ]++applyDamageAction :: DamageAction -> FilePath -> IO ()+applyDamageAction Empty f = withSaneMode f $ do+	nukeFile f+	writeFile f ""+applyDamageAction Reverse f = withSaneMode f $+	B.writeFile f =<< B.reverse <$> B.readFile f+applyDamageAction Delete f = nukeFile f+applyDamageAction (AppendGarbage garbage) f = withSaneMode f $+	B.appendFile f garbage+applyDamageAction (PrependGarbage garbage) f = withSaneMode f $ do+	b <- B.readFile f+	B.writeFile f $ B.concat [garbage, b]+-- When the byte is past the end of the file, wrap around.+-- Does nothing to empty file.+applyDamageAction (CorruptByte n garbage) f = withSaneMode f $ do+	b <- B.readFile f+	let len = B.length b+	unless (len == 0) $ do+		let n' = n `mod` len+		let (prefix, rest) = B.splitAt n' b+		B.writeFile f $ B.concat+			[prefix+			, B.singleton garbage+			, B.drop 1 rest+			]+applyDamageAction (ScrambleFileMode mode) f = setFileMode f mode++withSaneMode :: FilePath -> IO () -> IO ()+withSaneMode f = withModifiedFileMode f (addModes [ownerWriteMode, ownerReadMode])

@@ -17,7 +17,6 @@ import Git import Git.Command import Git.Sha-import Git.CatFile import Utility.Batch  import qualified Data.Set as S@@ -40,7 +39,7 @@ findBroken :: Bool -> Repo -> IO FsckResults findBroken batchmode r = do 	(output, fsckok) <- processTranscript command' (toCommand params') Nothing-	let objs = parseFsckOutput output+	let objs = findShas output 	badobjs <- findMissing objs r 	if S.null badobjs && not fsckok 		then return Nothing@@ -57,30 +56,23 @@  {- Finds objects that are missing from the git repsitory, or are corrupt.  -- - Note that catting a corrupt object will cause cat-file to crash;- - this is detected and it's restarted.+ - This does not use git cat-file --batch, because catting a corrupt+ - object can cause it to crash, or to report incorrect size information.a  -} findMissing :: [Sha] -> Repo -> IO MissingObjects-findMissing objs r = go objs [] =<< start+findMissing objs r = S.fromList <$> filterM (not <$$> present) objs   where-	start = catFileStart' False r-	go [] c h = do-		catFileStop h-		return $ S.fromList c-	go (o:os) c h = do-		v <- tryIO $ isNothing <$> catObjectDetails h o-		case v of-			Left _ -> do-				void $ tryIO $ catFileStop h-				go os (o:c) =<< start-			Right True -> go os (o:c) h-			Right False -> go os c h+	present o = either (const False) (const True) <$> tryIO (dump o)+	dump o = runQuiet+		[ Param "show"+		, Param (show o)+		] r -parseFsckOutput :: String -> [Sha]-parseFsckOutput = catMaybes . map extractSha . concat . map words . lines+findShas :: String -> [Sha]+findShas = catMaybes . map extractSha . concat . map words . lines  fsckParams :: Repo -> [CommandParam]-fsckParams = gitCommandLine+fsckParams = gitCommandLine $ 	[ Param "fsck" 	, Param "--no-dangling" 	, Param "--no-reflogs"

@@ -9,6 +9,7 @@  import Common import Git+import Git.Sha  objectsDir :: Repo -> FilePath objectsDir r = localGitDir r </> "objects"@@ -16,12 +17,17 @@ packDir :: Repo -> FilePath packDir r = objectsDir r </> "pack" +packIdxFile :: FilePath -> FilePath+packIdxFile = flip replaceExtension "idx"+ listPackFiles :: Repo -> IO [FilePath] listPackFiles r = filter (".pack" `isSuffixOf`)  	<$> catchDefaultIO [] (dirContents $ packDir r) -packIdxFile :: FilePath -> FilePath-packIdxFile = flip replaceExtension "idx"+listLooseObjectShas :: Repo -> IO [Sha]+listLooseObjectShas r = catchDefaultIO [] $+	mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories)+		<$> dirContentsRecursiveSkipping (== "pack") (objectsDir r)  looseObjectFile :: Repo -> Sha -> FilePath looseObjectFile r sha = objectsDir r </> prefix </> rest

@@ -8,13 +8,13 @@ module Git.Repair ( 	runRepair, 	runRepairOf,+	successfulRepair, 	cleanCorruptObjects, 	retrieveMissingObjects, 	resetLocalBranches, 	removeTrackingBranches, 	checkIndex, 	missingIndex,-	nukeIndex, 	emptyGoodCommits, ) where @@ -35,71 +35,39 @@ import qualified Git.Branch as Branch import Utility.Tmp import Utility.Rsync+import Utility.FileMode  import qualified Data.Set as S import qualified Data.ByteString.Lazy as L import Data.Tuple.Utils -{- Given a set of bad objects found by git fsck, removes all- - corrupt objects, and returns a list of missing objects,- - which need to be found elsewhere to finish recovery.- -- - Since git fsck may crash on corrupt objects, and so not- - report the full set of corrupt or missing objects,- - this removes corrupt objects, and re-runs fsck, until it- - stabalizes.- -- - To remove corrupt objects, unpack all packs, and remove the packs- - (to handle corrupt packs), and remove loose object files.+{- Given a set of bad objects found by git fsck, which may not+ - be complete, finds and removes all corrupt objects, and+ - returns a list of missing objects, which need to be+ - found elsewhere to finish recovery.  -}-cleanCorruptObjects :: FsckResults -> Repo -> IO MissingObjects-cleanCorruptObjects mmissing r = check mmissing-  where-	check Nothing = do-		putStrLn "git fsck found a problem but no specific broken objects. Perhaps a corrupt pack file?"-		ifM (explodePacks r)-			( retry S.empty-			, return S.empty-			)-	check (Just bad)-		| S.null bad = return S.empty-		| otherwise = do-			putStrLn $ unwords -				[ "git fsck found"-				, show (S.size bad)-				, "broken objects."-				]-			exploded <- explodePacks r-			removed <- removeLoose r bad-			if exploded || removed-				then retry bad-				else return bad-	retry oldbad = do-		putStrLn "Re-running git fsck to see if it finds more problems."-		v <- findBroken False r-		case v of-			Nothing -> error $ unwords-				[ "git fsck found a problem, which was not corrected after removing"-				, show (S.size oldbad)-				, "corrupt objects."-				]-			Just newbad -> do-				removed <- removeLoose r newbad-				let s = S.union oldbad newbad-				if not removed || s == oldbad-					then return s-					else retry s+cleanCorruptObjects :: FsckResults -> Repo -> IO (Maybe MissingObjects)+cleanCorruptObjects fsckresults r = do+	void $ explodePacks r+	objs <- listLooseObjectShas r+	mapM_ (tryIO . allowRead . looseObjectFile r) objs+	bad <- findMissing objs r+	void $ removeLoose r $ S.union bad (fromMaybe S.empty fsckresults)+	-- Rather than returning the loose objects that were removed, re-run+	-- fsck. Other missing objects may have been in the packs,+	-- and this way fsck will find them.+	findBroken False r  removeLoose :: Repo -> MissingObjects -> IO Bool removeLoose r s = do-	let fs = map (looseObjectFile r) (S.toList s)-	count <- length <$> filterM doesFileExist fs-	if (count > 0)+	fs <- filterM doesFileExist (map (looseObjectFile r) (S.toList s))+	let count = length fs+	if count > 0 		then do 			putStrLn $ unwords-				[ "removing"+				[ "Removing" 				, show count-				, "corrupt loose objects"+				, "corrupt loose objects." 				] 			mapM_ nukeFile fs 			return True@@ -115,57 +83,62 @@ 			mapM_ go packs 			return True   where-	go packfile = do+	go packfile = withTmpFileIn (localGitDir r) "pack" $ \tmp _ -> do+		moveFile packfile tmp+		nukeFile $ packIdxFile packfile+		allowRead tmp 		-- May fail, if pack file is corrupt. 		void $ tryIO $-			pipeWrite [Param "unpack-objects"] r $ \h ->-				L.hPut h =<< L.readFile packfile-		nukeFile packfile-		nukeFile $ packIdxFile packfile+			pipeWrite [Param "unpack-objects", Param "-r"] r $ \h ->+				L.hPut h =<< L.readFile tmp  {- Try to retrieve a set of missing objects, from the remotes of a  - repository. Returns any that could not be retreived.- - + -  - If another clone of the repository exists locally, which might not be a  - remote of the repo being repaired, its path can be passed as a reference  - repository.+ + - Can also be run with Nothing, if it's not known which objects are+ - missing, just that some are. (Ie, fsck failed badly.)  -}-retrieveMissingObjects :: MissingObjects -> Maybe FilePath -> Repo -> IO MissingObjects+retrieveMissingObjects :: Maybe MissingObjects -> Maybe FilePath -> Repo -> IO (Maybe MissingObjects) retrieveMissingObjects missing referencerepo r-	| S.null missing = return missing+	| missing == Just S.empty = return $ Just S.empty 	| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do 		unlessM (boolSystem "git" [Params "init", File tmpdir]) $ 			error $ "failed to create temp repository in " ++ tmpdir 		tmpr <- Config.read =<< Construct.fromAbsPath tmpdir 		stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing-		if S.null stillmissing-			then return stillmissing+		if stillmissing == Just S.empty+			then return $ Just S.empty 			else pullremotes tmpr (remotes r) fetchallrefs stillmissing   where 	pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of 		Nothing -> return stillmissing 		Just p -> ifM (fetchfrom p fetchrefs tmpr) 			( do+				void $ explodePacks tmpr 				void $ copyObjects tmpr r-				findMissing (S.toList stillmissing) r+				case stillmissing of+					Nothing -> return $ Just S.empty+					Just s -> Just <$> findMissing (S.toList s) r 			, return stillmissing 			)-	pullremotes tmpr (rmt:rmts) fetchrefs s-		| S.null s = return s+	pullremotes tmpr (rmt:rmts) fetchrefs ms+		| ms == Just S.empty = return $ Just S.empty 		| otherwise = do-			putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt+			putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt ++ "." 			ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr) 				( do+					void $ explodePacks tmpr 					void $ copyObjects tmpr r-					stillmissing <- findMissing (S.toList s) r-					pullremotes tmpr rmts fetchrefs stillmissing-				, do-					putStrLn $ unwords-						[ "failed to fetch from remote"-						, repoDescribe rmt-						, "(will continue without it, but making this remote available may improve recovery)"-						]-					pullremotes tmpr rmts fetchrefs s+					case ms of+						Nothing -> pullremotes tmpr rmts fetchrefs ms+						Just s -> do+							stillmissing <- findMissing (S.toList s) r+							pullremotes tmpr rmts fetchrefs (Just stillmissing)+				, pullremotes tmpr rmts fetchrefs ms 				) 	fetchfrom fetchurl ps = runBool $ 		[ Param "fetch"@@ -179,7 +152,7 @@ 	fetchallrefs = [ Param "+*:*" ]  {- Copies all objects from the src repository to the dest repository.- - This is done using rsync, so it copies all missing object, and all+ - This is done using rsync, so it copies all missing objects, and all  - objects they rely on. -} copyObjects :: Repo -> Repo -> IO Bool copyObjects srcr destr = rsync@@ -238,51 +211,44 @@ {- Gets all refs, including ones that are corrupt.  - git show-ref does not output refs to commits that are directly  - corrupted, so it is not used.+ -+ - Relies on packed refs being exploded before it's called.  -} getAllRefs :: Repo -> IO [Ref]-getAllRefs r = do-	packedrs <- mapMaybe parsePacked . lines-		<$> catchDefaultIO "" (readFile $ packedRefsFile r)-	loosers <- map toref <$> dirContentsRecursive refdir-	return $ packedrs ++ loosers+getAllRefs r = map toref <$> dirContentsRecursive refdir   where   	refdir = localGitDir r </> "refs" 	toref = Ref . relPathDirToFile (localGitDir r) +explodePackedRefsFile :: Repo -> IO ()+explodePackedRefsFile r = do+	let f = packedRefsFile r+	whenM (doesFileExist f) $ do+		rs <- mapMaybe parsePacked . lines+			<$> catchDefaultIO "" (safeReadFile f)+		forM_ rs makeref+		nukeFile f+  where+	makeref (sha, ref) = do+		let dest = localGitDir r ++ show ref+		createDirectoryIfMissing True (parentDir dest)+		unlessM (doesFileExist dest) $+			writeFile dest (show sha)+ packedRefsFile :: Repo -> FilePath packedRefsFile r = localGitDir r </> "packed-refs" -parsePacked :: String -> Maybe Ref+parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of 	(sha:ref:[])-		| isJust (extractSha sha) -> Just $ Ref ref+		| isJust (extractSha sha) && Ref.legal True ref ->+			Just (Ref sha, Ref ref) 	_ -> Nothing  {- git-branch -d cannot be used to remove a branch that is directly- - pointing to a corrupt commit. However, it's tried first. -}+ - pointing to a corrupt commit. -} nukeBranchRef :: Branch -> Repo -> IO ()-nukeBranchRef b r = void $ usegit <||> byhand-  where-	usegit = runBool-		[ Param "branch"-		, Params "-r -d"-		, Param $ show $ Ref.base b-		] r-	byhand = do-		nukeFile $ localGitDir r </> show b-		whenM (doesFileExist packedrefs) $-			withTmpFile "packed-refs" $ \tmp h -> do-				ls <- lines <$> readFile packedrefs-				hPutStr h $ unlines $-					filter (not . skiprefline) ls-				hClose h-				renameFile tmp packedrefs-		return True-	skiprefline l = case parsePacked l of-		Just packedref-			| packedref == b -> True-		_ -> False-	packedrefs = packedRefsFile r+nukeBranchRef b r = nukeFile $ localGitDir r </> show b  {- Finds the most recent commit to a branch that does not need any  - of the missing objects. If the input branch is good as-is, returns it.@@ -402,7 +368,7 @@ 	| otherwise = do 		(bad, good, cleanup) <- partitionIndex missing r 		unless (null bad) $ do-			nukeIndex r+			nukeFile (indexFile r) 			UpdateIndex.streamUpdateIndex r 				=<< (catMaybes <$> mapM reinject good) 		void cleanup@@ -414,8 +380,8 @@ 			UpdateIndex.stageFile sha blobtype file r 	reinject _ = return Nothing -nukeIndex :: Repo -> IO ()-nukeIndex r = nukeFile (localGitDir r </> "index")+indexFile :: Repo -> FilePath+indexFile r = localGitDir r </> "index"  newtype GoodCommits = GoodCommits (S.Set Sha) @@ -441,48 +407,91 @@ 		| numitems > 10 = take 10 items ++ ["(and " ++ show (numitems - 10) ++ " more)"] 		| otherwise = items +{- Fix problems that would prevent repair from working at all+ -+ - A missing or corrupt .git/HEAD makes git not treat the repository as a+ - git repo. If there is a git repo in a parent directory, it may move up+ - the tree and use that one instead. So, cannot use `git show-ref HEAD` to+ - test it.+ -+ - Explode the packed refs file, to simplify dealing with refs, and because+ - fsck can complain about bad refs in it.+ -}+preRepair :: Repo -> IO ()+preRepair g = do+	unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do+		nukeFile headfile+		writeFile headfile "ref: refs/heads/master"+	explodePackedRefsFile g+	unless (repoIsLocalBare g) $ do+		let f = indexFile g+		void $ tryIO $ allowWrite f+  where+	headfile = localGitDir g </> "HEAD"+	validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s)+ {- Put it all together. -} runRepair :: Bool -> Repo -> IO (Bool, MissingObjects, [Branch]) runRepair forced g = do+	preRepair g 	putStrLn "Running git fsck ..." 	fsckresult <- findBroken False g 	if foundBroken fsckresult-		then runRepairOf fsckresult forced Nothing g+		then runRepair' fsckresult forced Nothing g 		else do 			putStrLn "No problems found." 			return (True, S.empty, [])  runRepairOf :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch]) runRepairOf fsckresult forced referencerepo g = do+	preRepair g+	runRepair' fsckresult forced referencerepo g++runRepair' :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch])+runRepair' fsckresult forced referencerepo g = do 	missing <- cleanCorruptObjects fsckresult g 	stillmissing <- retrieveMissingObjects missing referencerepo g-	if S.null stillmissing-		then if repoIsLocalBare g-			then successfulfinish stillmissing []-			else ifM (checkIndex stillmissing g)-				( successfulfinish stillmissing []-				, do-					putStrLn "No missing objects found, but the index file is corrupt!"-					if forced-						then corruptedindex-						else needforce stillmissing-				)		-		else do-			putStrLn $ unwords-				[ show (S.size stillmissing)-				, "missing objects could not be recovered!"-				]-			if forced-				then continuerepairs stillmissing-				else unsuccessfulfinish stillmissing+	case stillmissing of+		Just s+			| S.null s -> if repoIsLocalBare g+				then successfulfinish S.empty []+				else ifM (checkIndex S.empty g)+					( successfulfinish s []+					, do+						putStrLn "No missing objects found, but the index file is corrupt!"+						if forced+							then corruptedindex+							else needforce S.empty+					)+			| otherwise -> if forced+				then ifM (checkIndex s g)+					( continuerepairs s+					, corruptedindex+					)+				else do+					putStrLn $ unwords+						[ show (S.size s)+						, "missing objects could not be recovered!"+						]+					unsuccessfulfinish s+		Nothing+			| forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex S.empty g)+				( do+					missing' <- cleanCorruptObjects Nothing g+					case missing' of+						Nothing -> return (False, S.empty, [])+						Just stillmissing' -> continuerepairs stillmissing'+				, corruptedindex+				)+			| otherwise -> unsuccessfulfinish S.empty   where 	continuerepairs stillmissing = do 		(remotebranches, goodcommits) <- removeTrackingBranches stillmissing emptyGoodCommits g 		unless (null remotebranches) $ 			putStrLn $ unwords-				[ "removed"+				[ "Removed" 				, show (length remotebranches)-				, "remote tracking branches that referred to missing objects"+				, "remote tracking branches that referred to missing objects." 				] 		(resetbranches, deletedbranches, _) <- resetLocalBranches stillmissing goodcommits g 		displayList (map show resetbranches)@@ -511,15 +520,18 @@ 				return (True, stillmissing, modifiedbranches) 	 	corruptedindex = do-		nukeIndex g+		nukeFile (indexFile g)+		-- The corrupted index can prevent fsck from finding other+		-- problems, so re-run repair.+		fsckresult' <- findBroken False g+		result <- runRepairOf fsckresult' forced referencerepo g 		putStrLn "Removed the corrupted index file. You should look at what files are present in your working tree and git add them back to the index when appropriate."-		return (True, S.empty, [])+		return result  	successfulfinish stillmissing modifiedbranches = do 		mapM_ putStrLn 			[ "Successfully recovered repository!"-			, "You should run \"git fsck\" to make sure, but it looks like"-			, "everything was recovered ok."+			, "You should run \"git fsck\" to make sure, but it looks like everything was recovered ok." 			] 		return (True, stillmissing, modifiedbranches) 	unsuccessfulfinish stillmissing = do@@ -532,3 +544,11 @@ 	needforce stillmissing = do 		putStrLn "To force a recovery to a usable state, retry with the --force parameter." 		return (False, stillmissing, [])++successfulRepair :: (Bool, MissingObjects, [Branch]) -> Bool+successfulRepair = fst3++safeReadFile :: FilePath -> IO String+safeReadFile f = do+	allowRead f+	readFileStrictAnyEncoding f

@@ -17,9 +17,10 @@ 	install -m 0644 git-repair.1 $(DESTDIR)$(PREFIX)/share/man/man1  clean:-	rm -rf git-repair dist configure Build/SysConfig.hs Setup tags-	find -name \*.o -exec rm {} \;-	find -name \*.hi -exec rm {} \;+	rm -rf git-repair git-repair-test.log \+		dist configure Build/SysConfig.hs Setup tags+	find . -name \*.o -exec rm {} \;+	find . -name \*.hi -exec rm {} \;  # Upload to hackage. hackage: clean@@ -29,3 +30,5 @@ # hothasktags chokes on some template haskell etc, so ignore errors tags: 	find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags > tags 2>/dev/null++.PHONY: tags

@@ -64,12 +64,19 @@ allowWrite :: FilePath -> IO () allowWrite f = modifyFileMode f $ addModes [ownerWriteMode] +{- Turns a file's owner read bit back on. -}+allowRead :: FilePath -> IO ()+allowRead f = modifyFileMode f $ addModes [ownerReadMode]+ {- Allows owner and group to read and write to a file. -}-groupWriteRead :: FilePath -> IO ()-groupWriteRead f = modifyFileMode f $ addModes+groupSharedModes :: [FileMode]+groupSharedModes = 	[ ownerWriteMode, groupWriteMode 	, ownerReadMode, groupReadMode 	]++groupWriteRead :: FilePath -> IO ()+groupWriteRead f = modifyFileMode f $ addModes groupSharedModes  checkMode :: FileMode -> FileMode -> Bool checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor

@@ -15,11 +15,15 @@ import Data.Char import Data.List import Control.Applicative+import System.Exit #ifndef mingw32_HOST_OS import System.Posix.Process (getAnyProcessStatus) import Utility.Exception #endif +import Utility.FileSystemEncoding+import Utility.Monad+ {- A version of hgetContents that is not lazy. Ensures file is   - all read before it gets closed. -} hGetContentsStrict :: Handle -> IO String@@ -29,6 +33,13 @@ readFileStrict :: FilePath -> IO String readFileStrict = readFile >=> \s -> length s `seq` return s +{-  Reads a file strictly, and using the FileSystemEncofing, so it will+ -  never crash on a badly encoded file. -}+readFileStrictAnyEncoding :: FilePath -> IO String+readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do+	fileEncoding h+	hClose h `after` hGetContentsStrict h+ {- Like break, but the item matching the condition is not included  - in the second result list.  -@@ -136,3 +147,7 @@ #else reapZombies = return () #endif++exitBool :: Bool -> IO a+exitBool False = exitFailure+exitBool True = exitSuccess

@@ -0,0 +1,48 @@+{- QuickCheck with additional instances+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Utility.QuickCheck+	( module X+	, module Utility.QuickCheck+	) where++import Test.QuickCheck as X+import Data.Time.Clock.POSIX+import System.Posix.Types+import qualified Data.Map as M+import Control.Applicative++instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where+	arbitrary = M.fromList <$> arbitrary++{- Times before the epoch are excluded. -}+instance Arbitrary POSIXTime where+	arbitrary = nonNegative arbitrarySizedIntegral++instance Arbitrary EpochTime where+	arbitrary = nonNegative arbitrarySizedIntegral++{- Pids are never negative, or 0. -}+instance Arbitrary ProcessID where+	arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)++{- Inodes are never negative. -}+instance Arbitrary FileID where+	arbitrary = nonNegative arbitrarySizedIntegral++{- File sizes are never negative. -}+instance Arbitrary FileOffset where+	arbitrary = nonNegative arbitrarySizedIntegral++nonNegative :: (Num a, Ord a) => Gen a -> Gen a+nonNegative g = g `suchThat` (>= 0)++positive :: (Num a, Ord a) => Gen a -> Gen a+positive g = g `suchThat` (> 0)

@@ -0,0 +1,69 @@+{- thread scheduling+ -+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2011 Bas van Dijk & Roel van Dijk+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.ThreadScheduler where++import Common++import Control.Concurrent+#ifndef mingw32_HOST_OS+import System.Posix.Signals+#ifndef __ANDROID__+import System.Posix.Terminal+#endif+#endif++newtype Seconds = Seconds { fromSeconds :: Int }+	deriving (Eq, Ord, Show)++type Microseconds = Integer++{- Runs an action repeatedly forever, sleeping at least the specified number+ - of seconds in between. -}+runEvery :: Seconds -> IO a -> IO a+runEvery n a = forever $ do+	threadDelaySeconds n+	a++threadDelaySeconds :: Seconds -> IO ()+threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)++{- Like threadDelay, but not bounded by an Int.+ -+ - There is no guarantee that the thread will be rescheduled promptly when the+ - delay has expired, but the thread will never continue to run earlier than+ - specified.+ - + - Taken from the unbounded-delay package to avoid a dependency for 4 lines+ - of code.+ -}+unboundDelay :: Microseconds -> IO ()+unboundDelay time = do+	let maxWait = min time $ toInteger (maxBound :: Int)+	threadDelay $ fromInteger maxWait+	when (maxWait /= time) $ unboundDelay (time - maxWait)++{- Pauses the main thread, letting children run until program termination. -}+waitForTermination :: IO ()+waitForTermination = do+	lock <- newEmptyMVar+#ifndef mingw32_HOST_OS+	let check sig = void $+		installHandler sig (CatchOnce $ putMVar lock ()) Nothing+	check softwareTermination+#ifndef __ANDROID__+	whenM (queryTerminal stdInput) $+		check keyboardSignal+#endif+#endif+	takeMVar lock++oneSecond :: Microseconds+oneSecond = 1000000

@@ -0,0 +1,22 @@+git-repair (1.20131122) unstable; urgency=low++  * Added test mode, which can be used to randomly corrupt test +    repositories, in reproducible ways, which allows easy+    corruption-driven-development.+  * Improve repair code in the case where the index file is corrupt,+    and this hides other problems.+  * Write a dummy .git/HEAD if the file is missing or corrupt, as+    git otherwise will not treat the repository as a git repo.+  * Improve fsck code to find badly corrupted objects that crash git fsck+    before it can complain about them.+  * Fixed crashes on bad file encodings.+  * Can now run 10000 tests (git-repair --test -n 10000 --force)+    with 0 failures.++ -- Joey Hess <joeyh@debian.org>  Fri, 22 Nov 2013 11:16:03 -0400++git-repair (1.20131118) unstable; urgency=low++  * First release++ -- Joey Hess <joeyh@debian.org>  Mon, 18 Nov 2013 13:38:12 -0400

@@ -0,0 +1,1 @@+9

@@ -0,0 +1,29 @@+Source: git-repair+Section: utils+Priority: optional+Build-Depends: +	debhelper (>= 9),+	ghc,+	git,+	libghc-missingh-dev,+	libghc-hslogger-dev,+	libghc-network-dev,+	libghc-ifelse-dev,+	libghc-extensible-exceptions-dev,+	libghc-unix-compat-dev,+	libghc-utf8-string-dev,+	libghc-async-dev,+	libghc-optparse-applicative-dev+Maintainer: Joey Hess <joeyh@debian.org>+Standards-Version: 3.9.4+Vcs-Git: git://git-repair.branchable.com/+Homepage: http://git-repair.branchable.com/++Package: git-repair+Architecture: any+Section: utils+Depends: ${misc:Depends}, ${shlibs:Depends}, git, rsync+Description: repair various forms of damage to git repositorie+ git-repair can repair various forms of damage to git repositories.+ .+ It is a complement to git fsck, which finds problems, but does not fix them.

@@ -0,0 +1,9 @@+Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/+Source: native package++Files: *+Copyright: © 2013 Joey Hess <joey@kitenet.net>+License: GPL-3++ The full text of version 3 of the GPL is distributed as doc/GPL in+ this package's source, or in /usr/share/common-licenses/GPL-3 on+ Debian systems.

@@ -0,0 +1,1 @@+git-repair.1

@@ -0,0 +1,10 @@+#!/usr/bin/make -f++# Avoid using cabal, as it writes to $HOME+export CABAL=./Setup++# Do use the changelog's version number, rather than making one up.+export RELEASE_BUILD=1++%:+	dh $@

@@ -5,7 +5,8 @@  ## download -	git clone git://git-repair.branchable.com/ git-repair+* `git clone git://git-repair.branchable.com/ git-repair`+* from [Hackage](http://hackage.haskell.org/package/git-repair)  ## install 

@@ -1,5 +1,5 @@ Name: git-repair-Version: 1.20131118+Version: 1.20131122 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -8,19 +8,22 @@ Copyright: 2013 Joey Hess License-File: GPL Build-Type: Custom-Homepage: http://git-reair.branchable.com/+Homepage: http://git-repair.branchable.com/ Category: Utility Synopsis: repairs a damanged git repisitory Description:  git-repair can repair various forms of damage to git repositories.+ .+ It is a complement to git fsck, which finds problems, but does not fix+ them.  Executable git-repair   Main-Is: git-repair.hs-  GHC-Options: -Wall+  GHC-Options: -Wall -threaded   Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl,    network, extensible-exceptions, unix-compat, bytestring,-   base >= 4.5, base < 5, IfElse, pretty-show, text, process,-   utf8-string, async+   base >= 4.5, base < 5, IfElse, text, process, time, QuickCheck,+   utf8-string, async, optparse-applicative, SHA    if (! os(windows))     Build-Depends: unix

@@ -5,34 +5,115 @@  - Licensed under the GNU GPL version 3 or higher.  -} -import System.Environment-import Data.Tuple.Utils+import Options.Applicative  import Common import qualified Git.CurrentRepo import qualified Git.Repair import qualified Git.Config+import qualified Git.Construct+import qualified Git.Destroyer+import qualified Git.Fsck+import Utility.Tmp -header :: String-header = "Usage: git-repair"+data Settings = Settings+	{ forced :: Bool+	, testMode :: Bool+	, retryTestMode :: Bool+	, numTests :: Int+	} -usage :: a-usage = error $ "bad parameters\n\n" ++ header+parseSettings :: Parser Settings+parseSettings = Settings+	<$> switch+		( long "force"+		<> help "Force repair, even if data is lost"+		)+	<*> switch+		( long "test"+		<> help "Clone local repo, damage the clone, and test repair"+		)+	<*> switch+		( long "retry"+		<> help "Retry tests in git-repair-test.log"+		)+	<*> option+		( long "numtests"+		<> short 'n'+		<> metavar "N"+		<> help "Run N tests"+		<> value 1+		) -parseArgs :: IO Bool-parseArgs = do-	args <- getArgs-	return $ or $ map parse args+main :: IO ()+main = execParser opts >>= go   where-	parse "--force" = True-	parse _ = usage+  	opts = info (helper <*> parseSettings) desc+	desc = fullDesc+		<> header "git-repair - repair a damanged git repository" +	go settings+		| testMode settings = test settings+		| retryTestMode settings = retryTest settings+		| otherwise = repair settings -main :: IO ()-main = do-	forced <- parseArgs-	+repair :: Settings -> IO ()+repair settings = do 	g <- Git.Config.read =<< Git.CurrentRepo.get-	ifM (fst3 <$> Git.Repair.runRepair forced g)+	ifM (Git.Repair.successfulRepair <$> Git.Repair.runRepair (forced settings) g) 		( exitSuccess 		, exitFailure 		)++test :: Settings -> IO ()+test settings = do+	forM_ [1 .. numTests settings] $ \n -> do+		putStrLn $ "** Test " ++ show n ++ "/" ++ show (numTests settings)+		damage <- Git.Destroyer.generateDamage+		logDamage damage+		runTest settings damage+	allOk++retryTest :: Settings -> IO ()+retryTest settings = do+	l <- map Prelude.read . lines <$> readFile logFile+	forM_ l $ \damage -> +		runTest settings damage+	allOk++runTest :: Settings -> [Git.Destroyer.Damage] -> IO ()+runTest settings damage = withTmpDir "tmprepo" $ \tmpdir -> do+	let cloneloc = tmpdir </> "clone"+	cloned <- boolSystem "git"+		[ Param "clone"+		, Param "--no-hardlinks"+		, File "."+		, File cloneloc+		]+	unless cloned $+		error $ "failed to clone this repo"+	g <- Git.Config.read =<< Git.Construct.fromPath cloneloc+	Git.Destroyer.applyDamage damage g+	repairstatus <- catchMaybeIO $ Git.Repair.successfulRepair+		<$> Git.Repair.runRepair (forced settings) g+	case repairstatus of+		Just True -> testResult repairstatus +			. Just . not . Git.Fsck.foundBroken+			=<< Git.Fsck.findBroken False g+		_ -> testResult repairstatus Nothing++-- Pass test result and fsck result+testResult :: (Maybe Bool) -> (Maybe Bool) -> IO ()+testResult (Just True) (Just True) = putStrLn "** repair succeeded"+testResult (Just True) (Just False) = error "** repair succeeded, but final fsck failed"+testResult _ _ = error "** repair failed"++allOk :: IO ()+allOk = do+	putStrLn ""+	putStrLn "All tests ok!"++logDamage :: [Git.Destroyer.Damage] -> IO ()+logDamage damage = appendFile logFile $ show damage ++ "\n"++logFile :: FilePath+logFile = "git-repair-test.log"