packages feed

git-repair 1.20140115 → 1.20140227

raw patch · 30 files changed

+404/−197 lines, 30 files

Files

Git.hs view
@@ -13,6 +13,7 @@ module Git ( 	Repo(..), 	Ref(..),+	fromRef, 	Branch, 	Sha, 	Tag,
Git/Branch.hs view
@@ -28,7 +28,7 @@ 	case v of 		Nothing -> return Nothing 		Just branch -> -			ifM (null <$> pipeReadStrict [Param "show-ref", Param $ show branch] r)+			ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r) 				( return Nothing 				, return v 				)@@ -36,7 +36,7 @@ {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Git.Ref) currentUnsafe r = parse . firstLine-	<$> pipeReadStrict [Param "symbolic-ref", Param $ show Git.Ref.headRef] r+	<$> pipeReadStrict [Param "symbolic-ref", Param $ fromRef Git.Ref.headRef] r   where 	parse l 		| null l = Nothing@@ -51,7 +51,7 @@   where 	diffs = pipeReadStrict 		[ Param "log"-		, Param (show origbranch ++ ".." ++ show newbranch)+		, Param (fromRef origbranch ++ ".." ++ fromRef newbranch) 		, Params "--oneline -n1" 		] repo @@ -74,7 +74,7 @@   where 	no_ff = return False 	do_ff to = do-		run [Param "update-ref", Param $ show branch, Param $ show to] repo+		run [Param "update-ref", Param $ fromRef branch, Param $ fromRef to] repo 		return True 	findbest c [] = return $ Just c 	findbest c (r:rs)@@ -104,14 +104,14 @@ 	ifM (cancommit tree) 		( do 			sha <- getSha "commit-tree" $ pipeWriteRead-				(map Param $ ["commit-tree", show tree] ++ ps)+				(map Param $ ["commit-tree", fromRef tree] ++ ps) 				(Just $ flip hPutStr message) repo 			update branch sha repo 			return $ Just sha 		, return Nothing 		)   where-	ps = concatMap (\r -> ["-p", show r]) parentrefs+	ps = concatMap (\r -> ["-p", fromRef r]) parentrefs 	cancommit tree 		| allowempty = return True 		| otherwise = case parentrefs of@@ -130,8 +130,8 @@ update :: Branch -> Sha -> Repo -> IO () update branch sha = run  	[ Param "update-ref"-	, Param $ show branch-	, Param $ show sha+	, Param $ fromRef branch+	, Param $ fromRef sha 	]  {- Checks out a branch, creating it if necessary. -}@@ -140,7 +140,7 @@ 	[ Param "checkout" 	, Param "-q" 	, Param "-B"-	, Param $ show $ Git.Ref.base branch+	, Param $ fromRef $ Git.Ref.base branch 	]  {- Removes a branch. -}@@ -149,5 +149,5 @@ 	[ Param "branch" 	, Param "-q" 	, Param "-D"-	, Param $ show $ Git.Ref.base branch+	, Param $ fromRef $ Git.Ref.base branch 	]
Git/CatFile.hs view
@@ -50,7 +50,7 @@ {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString catFile h branch file = catObject h $ Ref $-	show branch ++ ":" ++ toInternalGitPath file+	fromRef branch ++ ":" ++ toInternalGitPath file  {- Uses a running git cat-file read the content of an object.  - Objects that do not exist will have "" returned. -}@@ -60,7 +60,7 @@ catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType)) catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive   where-	query = show object+	query = fromRef object 	send to = hPutStrLn to query 	receive from = do 		header <- hGetLine from@@ -72,8 +72,8 @@ 						_ -> dne 				| otherwise -> dne 			_-				| header == show object ++ " missing" -> dne-				| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)+				| header == fromRef object ++ " missing" -> dne+				| otherwise -> error $ "unknown response from git cat-file " ++ show (header, query) 	readcontent objtype bytes from sha = do 		content <- S.hGet from bytes 		eatchar '\n' from
Git/Command.hs view
@@ -18,32 +18,29 @@ #ifdef mingw32_HOST_OS import Git.FilePath #endif+import Utility.Batch  {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] gitCommandLine params r@(Repo { location = l@(Local _ _ ) }) = 	setdir : settree ++ gitGlobalOpts r ++ params   where-	setdir = Param $ "--git-dir=" ++ gitpath (gitdir l)+	setdir = Param $ "--git-dir=" ++ gitdir l 	settree = case worktree l of 		Nothing -> []-		Just t -> [Param $ "--work-tree=" ++ gitpath t]-#ifdef mingw32_HOST_OS-	-- despite running on windows, msysgit wants a unix-formatted path-	gitpath s-		| isAbsolute s = "/" ++ dropDrive (toInternalGitPath s)-		| otherwise = s-#else-	gitpath = id-#endif+		Just t -> [Param $ "--work-tree=" ++ t] gitCommandLine _ repo = assertLocal repo $ error "internal"  {- Runs git in the specified repo. -} runBool :: [CommandParam] -> Repo -> IO Bool runBool params repo = assertLocal repo $-	boolSystemEnv "git"-		(gitCommandLine params repo)-		(gitEnv repo)+	boolSystemEnv "git" (gitCommandLine params repo) (gitEnv repo)++{- Runs git in batch mode. -}+runBatch :: BatchCommandMaker -> [CommandParam] -> Repo -> IO Bool+runBatch batchmaker params repo = assertLocal repo $ do+	let (cmd, params') = batchmaker ("git", gitCommandLine params repo)+	boolSystemEnv cmd params' (gitEnv repo)  {- Runs git in the specified repo, throwing an error if it fails. -} run :: [CommandParam] -> Repo -> IO ()
Git/Construct.hs view
@@ -33,6 +33,7 @@ import Git.Types import Git import Git.Remote+import Git.FilePath import qualified Git.Url as Url import Utility.UserInfo @@ -57,7 +58,7 @@  - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir-	| isAbsolute dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt )+	| absoluteGitPath dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt ) 	| otherwise = 		error $ "internal error, " ++ dir ++ " is not absolute"   where
Git/Destroyer.hs view
@@ -2,7 +2,7 @@  -  - Use with caution!  -- - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013, 2014 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -17,39 +17,41 @@ import Git import Utility.QuickCheck import Utility.FileMode+import Utility.Tmp  import qualified Data.ByteString as B import Data.Word import System.PosixCompat.Types  {- Ways to damange a git repository. -}-data Damage = Damage DamageAction FileSelector+data Damage+	= Empty FileSelector+	| Delete FileSelector+	| Reverse FileSelector+	| AppendGarbage FileSelector B.ByteString+	| PrependGarbage FileSelector B.ByteString+	| CorruptByte FileSelector Int Word8+	| ScrambleFileMode FileSelector FileMode+	| SwapFiles FileSelector 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+		[ Empty <$> arbitrary+		, Delete <$> arbitrary+		, Reverse <$> arbitrary+		, AppendGarbage <$> arbitrary <*> garbage+		, PrependGarbage <$> arbitrary <*> garbage 		, CorruptByte-			<$> nonNegative arbitraryBoundedIntegral+			<$> arbitrary+			<*> nonNegative arbitraryBoundedIntegral 			<*> arbitrary-		, ScrambleFileMode <$> nonNegative arbitrarySizedIntegral+		, ScrambleFileMode+			<$> arbitrary+			<*> nonNegative arbitrarySizedIntegral+		, SwapFiles+			<$> arbitrary+			<*> arbitrary 		] 	  where 		garbage = B.pack <$> arbitrary `suchThat` (not . null)@@ -58,7 +60,7 @@  - 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)+	deriving (Read, Show, Eq)  instance Arbitrary FileSelector where 	arbitrary = FileSelector <$> oneof@@ -80,47 +82,68 @@ {- 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)+applyDamage ds r = do+	contents <- sort . filter (not . skipped) 		<$> 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 ++ ")")+	forM_ ds $ \d -> do+		let withfile s a = do+			let f = selectFile contents s+			-- Symlinks might be dangling, so are skipped.+			-- If the file was already removed by a previous Damage,+			-- it's skipped.+			whenM (doesFileExist f) $+				a f `catchIO` \e -> error ("Failed to apply damage " ++ show d ++ " to " ++ show f ++ ": " ++ show e ++ "(total damage: " ++ show ds ++ ")")+		case d of+			Empty s -> withfile s $ \f ->+				withSaneMode f $ do+					nukeFile f+					writeFile f ""+			Reverse s -> withfile s $ \f ->+				withSaneMode f $+					B.writeFile f =<< B.reverse <$> B.readFile f+			Delete s -> withfile s $ nukeFile+			AppendGarbage s garbage ->+				withfile s $ \f ->+					withSaneMode f $+					B.appendFile f garbage+			PrependGarbage s garbage ->+				withfile s $ \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.+			CorruptByte s n garbage ->+				withfile s $ \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+								]+			ScrambleFileMode s mode ->+				withfile s $ \f ->+					setFileMode f mode+			SwapFiles a b ->+				withfile a $ \fa ->+					withfile b $ \fb -> +						unless (fa == fb) $+							withTmpFile "swap" $ \tmp _ -> do+								moveFile fa tmp+								moveFile fb fa+								moveFile tmp fa   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+ 	-- A broken .git/config is not recoverable.+	-- Don't damage hook scripts, to avoid running arbitrary code. ;)+	skipped f = or+		[ takeFileName f == "config"+		, "hooks" `isPrefixOf` f+		]  withSaneMode :: FilePath -> IO () -> IO () withSaneMode f = withModifiedFileMode f (addModes [ownerWriteMode, ownerReadMode])
Git/FilePath.hs view
@@ -20,12 +20,15 @@ 	asTopFilePath, 	InternalGitPath, 	toInternalGitPath,-	fromInternalGitPath+	fromInternalGitPath,+	absoluteGitPath ) where  import Common import Git +import qualified System.FilePath.Posix+ {- A FilePath, relative to the top of the git repository. -} newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } 	deriving (Show)@@ -48,8 +51,7 @@  - it internally.   -  - On Windows, git uses '/' to separate paths stored in the repository,- - despite Windows using '\'. Also, git on windows dislikes paths starting- - with "./" or ".\".+ - despite Windows using '\'.  -  -} type InternalGitPath = String@@ -58,11 +60,7 @@ #ifndef mingw32_HOST_OS toInternalGitPath = id #else-toInternalGitPath p =-	let p' = replace "\\" "/" p-	in if "./" `isPrefixOf` p'-		then dropWhile (== '/') (drop 1 p')-		else p'+toInternalGitPath = replace "\\" "/" #endif  fromInternalGitPath :: InternalGitPath -> FilePath@@ -71,3 +69,10 @@ #else fromInternalGitPath = replace "/" "\\" #endif++{- isAbsolute on Windows does not think "/foo" or "\foo" is absolute,+ - so try posix paths.+ -}+absoluteGitPath :: FilePath -> Bool+absoluteGitPath p = isAbsolute p ||+	System.FilePath.Posix.isAbsolute (toInternalGitPath p)
Git/Fsck.hs view
@@ -20,7 +20,7 @@ import Git.Command import Git.Sha import Utility.Batch-import qualified Git.BuildVersion+import qualified Git.Version  import qualified Data.Set as S @@ -40,12 +40,14 @@  -} findBroken :: Bool -> Repo -> IO FsckResults findBroken batchmode r = do-	let (command, params) = ("git", fsckParams r)+	supportsNoDangling <- (>= Git.Version.normalize "1.7.10")+		<$> Git.Version.installed+	let (command, params) = ("git", fsckParams supportsNoDangling r) 	(command', params') <- if batchmode 		then toBatchCommand (command, params) 		else return (command, params) 	(output, fsckok) <- processTranscript command' (toCommand params') Nothing-	let objs = findShas output+	let objs = findShas supportsNoDangling output 	badobjs <- findMissing objs r 	if S.null badobjs && not fsckok 		then return FsckFailed@@ -72,24 +74,21 @@   where 	dump = runQuiet 		[ Param "show"-		, Param (show s)+		, Param (fromRef s) 		] r -findShas :: String -> [Sha]-findShas = catMaybes . map extractSha . concat . map words . filter wanted . lines+findShas :: Bool -> String -> [Sha]+findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted . lines   where 	wanted l 		| supportsNoDangling = True 		| otherwise = not ("dangling " `isPrefixOf` l) -fsckParams :: Repo -> [CommandParam]-fsckParams = gitCommandLine $ map Param $ catMaybes+fsckParams :: Bool -> Repo -> [CommandParam]+fsckParams supportsNoDangling = gitCommandLine $ map Param $ catMaybes 	[ Just "fsck" 	, if supportsNoDangling 		then Just "--no-dangling" 		else Nothing 	, Just "--no-reflogs" 	]--supportsNoDangling :: Bool-supportsNoDangling = not $ Git.BuildVersion.older "1.7.10"
Git/LsTree.hs view
@@ -38,13 +38,13 @@ 	<$> pipeNullSplitZombie (lsTreeParams t) repo  lsTreeParams :: Ref -> [CommandParam]-lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ show t ]+lsTreeParams t = [ Params "ls-tree --full-tree -z -r --", File $ fromRef t ]  {- Lists specified files in a tree. -} lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem] lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo   where-  	ps = [Params "ls-tree --full-tree -z --", File $ show t] ++ map File fs+  	ps = [Params "ls-tree --full-tree -z --", File $ fromRef t] ++ map File fs  {- Parses a line of ls-tree output.  - (The --long format is not currently supported.) -}
Git/Objects.hs view
@@ -32,4 +32,4 @@ looseObjectFile :: Repo -> Sha -> FilePath looseObjectFile r sha = objectsDir r </> prefix </> rest   where-	(prefix, rest) = splitAt 2 (show sha)+	(prefix, rest) = splitAt 2 (fromRef sha)
Git/Ref.hs view
@@ -11,6 +11,7 @@ import Git import Git.Command import Git.Sha+import Git.Types  import Data.Char (chr) @@ -19,12 +20,12 @@  {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String-describe = show . base+describe = fromRef . base  {- Often git refs are fully qualified (eg: refs/heads/master).  - Converts such a fully qualified ref into a base ref (eg: master). -} base :: Ref -> Ref-base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show+base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef   where 	remove prefix s 		| prefix `isPrefixOf` s = drop (length prefix) s@@ -34,13 +35,13 @@  - it under the directory. -} under :: String -> Ref -> Ref under dir r = Ref $ dir ++ "/" ++-	(reverse $ takeWhile (/= '/') $ reverse $ show r)+	(reverse $ takeWhile (/= '/') $ reverse $ fromRef r)  {- Given a directory such as "refs/remotes/origin", and a ref such as  - refs/heads/master, yields a version of that ref under the directory,  - such as refs/remotes/origin/master. -} underBase :: String -> Ref -> Ref-underBase dir r = Ref $ dir ++ "/" ++ show (base r)+underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r)  {- A Ref that can be used to refer to a file in the repository, as staged  - in the index.@@ -51,6 +52,10 @@ fileRef :: FilePath -> Ref fileRef f = Ref $ ":./" ++ f +{- Converts a Ref to refer to the content of the Ref on a given date. -}+dateRef :: Ref -> RefDate -> Ref+dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d+ {- A Ref that can be used to refer to a file in the repository as it  - appears in a given Ref. -} fileFromRef :: Ref -> FilePath -> Ref@@ -59,12 +64,12 @@ {- Checks if a ref exists. -} exists :: Ref -> Repo -> IO Bool exists ref = runBool-	[Param "show-ref", Param "--verify", Param "-q", Param $ show ref]+	[Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref]  {- The file used to record a ref. (Git also stores some refs in a  - packed-refs file.) -} file :: Ref -> Repo -> FilePath-file ref repo = localGitDir repo </> show ref+file ref repo = localGitDir repo </> fromRef ref  {- Checks if HEAD exists. It generally will, except for in a repository  - that was just created. -}@@ -79,17 +84,17 @@   where 	showref = pipeReadStrict [Param "show-ref", 		Param "--hash", -- get the hash-		Param $ show branch]+		Param $ fromRef branch] 	process [] = Nothing 	process s = Just $ Ref $ firstLine s  {- List of (shas, branches) matching a given ref or refs. -} matching :: [Ref] -> Repo -> IO [(Sha, Branch)]-matching refs repo =  matching' (map show refs) repo+matching refs repo =  matching' (map fromRef refs) repo  {- Includes HEAD in the output, if asked for it. -} matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)]-matchingWithHEAD refs repo = matching' ("--head" : map show refs) repo+matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo  {- List of (shas, branches) matching a given ref or refs. -} matching' :: [String] -> Repo -> IO [(Sha, Branch)]@@ -109,7 +114,7 @@ {- Gets the sha of the tree a ref uses. -} tree :: Ref -> Repo -> IO (Maybe Sha) tree ref = extractSha <$$> pipeReadStrict-	[ Param "rev-parse", Param (show ref ++ ":") ]+	[ Param "rev-parse", Param (fromRef ref ++ ":") ]  {- Checks if a String is a legal git ref name.  -
Git/RefLog.hs view
@@ -18,5 +18,5 @@ 	[ Param "log" 	, Param "-g" 	, Param "--format=%H"-	, Param (show b)+	, Param (fromRef b) 	]
Git/Repair.hs view
@@ -75,24 +75,35 @@ 			return True 		else return False +{- Explodes all pack files, and deletes them.+ -+ - First moves all pack files to a temp dir, before unpacking them each in+ - turn.+ -+ - 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+ - pack files to see if they contain an object, while unpacking a+ - non-corrupt pack file.+ -} explodePacks :: Repo -> IO Bool-explodePacks r = do-	packs <- listPackFiles r-	if null packs-		then return False-		else do-			putStrLn "Unpacking all pack files."-			mapM_ go packs-			return True+explodePacks r = go =<< listPackFiles r   where-	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", Param "-r"] r $ \h ->+	go [] = return False+	go packs = withTmpDir "packs" $ \tmpdir -> do+		putStrLn "Unpacking all pack files."+		forM_ packs $ \packfile -> do+			moveFile packfile (tmpdir </> takeFileName packfile)+			nukeFile $ packIdxFile packfile+		forM_ packs $ \packfile -> do+			let tmp = tmpdir </> takeFileName packfile+			allowRead tmp+			-- May fail, if pack file is corrupt.+			void $ tryIO $+				pipeWrite [Param "unpack-objects", Param "-r"] r $ \h -> 				L.hPut h =<< L.readFile tmp+		return True  {- Try to retrieve a set of missing objects, from the remotes of a  - repository. Returns any that could not be retreived.@@ -168,7 +179,7 @@ resetLocalBranches missing goodcommits r = 	go [] [] goodcommits =<< filter islocalbranch <$> getAllRefs r   where-	islocalbranch b = "refs/heads/" `isPrefixOf` show b+	islocalbranch b = "refs/heads/" `isPrefixOf` fromRef b 	go changed deleted gcs [] = return (changed, deleted, gcs) 	go changed deleted gcs (b:bs) = do 		(mc, gcs') <- findUncorruptedCommit missing gcs b r@@ -185,12 +196,12 @@ 		nukeBranchRef b	r 		void $ runBool 			[ Param "branch"-			, Param (show $ Ref.base b)-			, Param (show c)+			, Param (fromRef $ Ref.base b)+			, Param (fromRef c) 			] r  isTrackingBranch :: Ref -> Bool-isTrackingBranch b = "refs/remotes/" `isPrefixOf` show b+isTrackingBranch b = "refs/remotes/" `isPrefixOf` fromRef b  {- To deal with missing objects that cannot be recovered, removes  - any branches (filtered by a predicate) that reference them@@ -231,10 +242,10 @@ 		nukeFile f   where 	makeref (sha, ref) = do-		let dest = localGitDir r </> show ref+		let dest = localGitDir r </> fromRef ref 		createDirectoryIfMissing True (parentDir dest) 		unlessM (doesFileExist dest) $-			writeFile dest (show sha)+			writeFile dest (fromRef sha)  packedRefsFile :: Repo -> FilePath packedRefsFile r = localGitDir r </> "packed-refs"@@ -249,7 +260,7 @@ {- git-branch -d cannot be used to remove a branch that is directly  - pointing to a corrupt commit. -} nukeBranchRef :: Branch -> Repo -> IO ()-nukeBranchRef b r = nukeFile $ localGitDir r </> show b+nukeBranchRef b r = nukeFile $ localGitDir r </> fromRef 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.@@ -268,7 +279,7 @@ 				[ Param "log" 				, Param "-z" 				, Param "--format=%H"-				, Param (show branch)+				, Param (fromRef branch) 				] r 			let branchshas = catMaybes $ map extractSha ls 			reflogshas <- RefLog.get branch r@@ -297,7 +308,7 @@ 			[ Param "log" 			, Param "-z" 			, Param "--format=%H %T"-			, Param (show commit)+			, Param (fromRef commit) 			] r 		let committrees = map parse ls 		if any isNothing committrees || null committrees@@ -501,9 +512,9 @@ 				, "remote tracking branches that referred to missing objects." 				] 		(resetbranches, deletedbranches, _) <- resetLocalBranches stillmissing goodcommits g-		displayList (map show resetbranches)+		displayList (map fromRef resetbranches) 			"Reset these local branches to old versions before the missing objects were committed:"-		displayList (map show deletedbranches)+		displayList (map fromRef deletedbranches) 			"Deleted these local branches, which could not be recovered due to missing objects:" 		deindexedfiles <- rewriteIndex g 		displayList deindexedfiles@@ -519,7 +530,7 @@ 						Just curr -> when (any (== curr) modifiedbranches) $ do 							putStrLn $ unwords 								[ "You currently have"-								, show curr+								, fromRef curr 								, "checked out. You may have staged changes in the index that can be committed to recover the lost state of this branch!" 								] 				putStrLn "Successfully recovered repository!"
Git/Sha.hs view
@@ -37,3 +37,7 @@  nullSha :: Ref		 nullSha = Ref $ replicate shaSize '0'++{- Git's magic empty tree. -}+emptyTree :: Ref+emptyTree = Ref "4b825dc642cb6eb9a060e54bf8d69288fbee4904"
Git/Types.hs view
@@ -47,15 +47,19 @@  {- A git ref. Can be a sha1, or a branch or tag name. -} newtype Ref = Ref String-	deriving (Eq, Ord)+	deriving (Eq, Ord, Read, Show) -instance Show Ref where-	show (Ref v) = v+fromRef :: Ref -> String+fromRef (Ref s) = s  {- Aliases for Ref. -} type Branch = Ref type Sha = Ref type Tag = Ref++{- A date in the format described in gitrevisions. Includes the+ - braces, eg, "{yesterday}" -}+newtype RefDate = RefDate String  {- Types of objects that can be stored in git. -} data ObjectType = BlobObject | CommitObject | TreeObject
Git/UpdateIndex.hs view
@@ -11,6 +11,9 @@ 	Streamer, 	pureStreamer, 	streamUpdateIndex,+	streamUpdateIndex',+	startUpdateIndex,+	stopUpdateIndex, 	lsTree, 	updateIndexLine, 	stageFile,@@ -25,6 +28,9 @@ import Git.FilePath import Git.Sha +import Control.Exception (bracket)+import System.Process (std_in)+ {- Streamers are passed a callback and should feed it lines in the form  - read by update-index, and generated by ls-tree. -} type Streamer = (String -> IO ()) -> IO ()@@ -35,17 +41,30 @@  {- Streams content into update-index from a list of Streamers. -} streamUpdateIndex :: Repo -> [Streamer] -> IO ()-streamUpdateIndex repo as = pipeWrite params repo $ \h -> do+streamUpdateIndex repo as = bracket (startUpdateIndex repo) stopUpdateIndex $+	(\h -> forM_ as $ streamUpdateIndex' h)++data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle++streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()+streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do+	hPutStr h s+	hPutStr h "\0"++startUpdateIndex :: Repo -> IO UpdateIndexHandle+startUpdateIndex repo = do+	(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)+		{ std_in = CreatePipe } 	fileEncoding h-	forM_ as (stream h)-	hClose h+	return $ UpdateIndexHandle p h   where 	params = map Param ["update-index", "-z", "--index-info"]-	stream h a = a (streamer h)-	streamer h s = do-		hPutStr h s-		hPutStr h "\0" +stopUpdateIndex :: UpdateIndexHandle -> IO Bool+stopUpdateIndex (UpdateIndexHandle p h) = do+	hClose h+	checkSuccessProcess p+ {- A streamer that adds the current tree for a ref. Useful for eg, copying  - and modifying branches. -} lsTree :: Ref -> Repo -> Streamer@@ -60,7 +79,7 @@  - a given file with a given sha. -} updateIndexLine :: Sha -> BlobType -> TopFilePath -> String updateIndexLine sha filetype file =-	show filetype ++ " blob " ++ show sha ++ "\t" ++ indexPath file+	show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file  stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer stageFile sha filetype file repo = do@@ -71,7 +90,7 @@ unstageFile :: FilePath -> Repo -> IO Streamer unstageFile file repo = do 	p <- toTopFilePath file repo-	return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ indexPath p+	return $ pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p  {- A streamer that adds a symlink to the index. -} stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
Utility/Directory.hs view
@@ -1,6 +1,6 @@ {- directory manipulation  -- - Copyright 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -10,7 +10,6 @@ module Utility.Directory where  import System.IO.Error-import System.PosixCompat.Files import System.Directory import Control.Exception (throw) import Control.Monad@@ -19,10 +18,12 @@ import Control.Applicative import System.IO.Unsafe (unsafeInterleaveIO) +import Utility.PosixFiles import Utility.SafeCommand import Utility.Tmp import Utility.Exception import Utility.Monad+import Utility.Applicative  dirCruft :: FilePath -> Bool dirCruft "." = True@@ -72,6 +73,21 @@ 							, skip 							) 				_ -> skip++{- Gets the directory tree from a point, recursively and lazily,+ - with leaf directories **first**, skipping any whose basenames+ - match the skipdir. Does not follow symlinks. -}+dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]+  where+  	go c [] = return c+	go c (dir:dirs)+		| skipdir (takeFileName dir) = go c dirs+		| otherwise = unsafeInterleaveIO $ do+			subdirs <- go c+				=<< filterM (isDirectory <$$> getSymbolicLinkStatus)+				=<< catchDefaultIO [] (dirContents dir)+			go (subdirs++[dir]) dirs  {- Moves one filename to another.  - First tries a rename, but falls back to moving across devices if needed. -}
Utility/Env.hs view
@@ -61,3 +61,21 @@ #else unsetEnv _ = return False #endif++{- Adds the environment variable to the input environment. If already+ - present in the list, removes the old value.+ -+ - This does not really belong here, but Data.AssocList is for some reason+ - buried inside hxt.+ -}+addEntry :: Eq k => k -> v -> [(k, v)] -> [(k, v)]+addEntry k v l = ( (k,v) : ) $! delEntry k l++addEntries :: Eq k => [(k, v)] -> [(k, v)] -> [(k, v)]+addEntries = foldr (.) id . map (uncurry addEntry) . reverse++delEntry :: Eq k => k -> [(k, v)] -> [(k, v)]+delEntry _ []   = []+delEntry k (x@(k1,_) : rest)+	| k == k1 = rest+	| otherwise = ( x : ) $! delEntry k rest
Utility/FileMode.hs view
@@ -133,10 +133,8 @@  - as writeFile.  -} writeFileProtected :: FilePath -> String -> IO ()-writeFileProtected file content = do-	h <- openFile file WriteMode+writeFileProtected file content = withFile file WriteMode $ \h -> do 	void $ tryIO $ 		modifyFileMode file $ 			removeModes [groupReadMode, otherReadMode] 	hPutStr h content-	hClose h
Utility/Misc.hs view
@@ -33,12 +33,19 @@ readFileStrict :: FilePath -> IO String readFileStrict = readFile >=> \s -> length s `seq` return s -{-  Reads a file strictly, and using the FileSystemEncofing, so it will+{-  Reads a file strictly, and using the FileSystemEncoding, 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++{- Writes a file, using the FileSystemEncoding so it will never crash+ - on a badly encoded content string. -}+writeFileAnyEncoding :: FilePath -> String -> IO ()+writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do+	fileEncoding h+	hPutStr h content  {- Like break, but the item matching the condition is not included  - in the second result list.
Utility/Path.hs view
@@ -1,6 +1,6 @@ {- path manipulation  -- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -21,28 +21,60 @@ import Data.Char import qualified System.FilePath.Posix as Posix #else-import qualified "MissingH" System.Path as MissingH import System.Posix.Files #endif +import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo -{- Makes a path absolute if it's not already.+{- Simplifies a path, removing any ".." or ".", and removing the trailing+ - path separator.+ -+ - On Windows, preserves whichever style of path separator might be used in+ - the input FilePaths. This is done because some programs in Windows+ - demand a particular path separator -- and which one actually varies!+ -+ - This does not guarantee that two paths that refer to the same location,+ - and are both relative to the same location (or both absolute) will+ - yeild the same result. Run both through normalise from System.FilePath+ - to ensure that.+ -}+simplifyPath :: FilePath -> FilePath+simplifyPath path = dropTrailingPathSeparator $ +	joinDrive drive $ joinPath $ norm [] $ splitPath path'+  where+	(drive, path') = splitDrive path++	norm c [] = reverse c+	norm c (p:ps)+		| p' == ".." = norm (drop 1 c) ps+		| p' == "." = norm c ps+		| otherwise = norm (p:c) ps+	  where+		p' = dropTrailingPathSeparator p++{- Makes a path absolute.+ -  - The first parameter is a base directory (ie, the cwd) to use if the path  - is not already absolute.  -- - On Unix, collapses and normalizes ".." etc in the path. May return Nothing- - if the path cannot be normalized.- -- - MissingH's absNormPath does not work on Windows, so on Windows- - no normalization is done.+ - Does not attempt to deal with edge cases or ensure security with+ - untrusted inputs.  -}-absNormPath :: FilePath -> FilePath -> Maybe FilePath+absPathFrom :: FilePath -> FilePath -> FilePath+absPathFrom dir path = simplifyPath (combine dir path)++{- On Windows, this converts the paths to unix-style, in order to run+ - MissingH's absNormPath on them. Resulting path will use / separators. -}+absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath #ifndef mingw32_HOST_OS-absNormPath dir path = MissingH.absNormPath dir path+absNormPathUnix dir path = MissingH.absNormPath dir path #else-absNormPath dir path = Just $ combine dir path+absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path)+  where+	fromdos = replace "\\" "/"+	todos = replace "/" "\\" #endif  {- Returns the parent directory of a path.@@ -72,13 +104,13 @@  - are all equivilant.  -} dirContains :: FilePath -> FilePath -> Bool-dirContains a b = a == b || a' == b' || (a'++[pathSeparator]) `isPrefixOf` b'+dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'   where-	norm p = fromMaybe "" $ absNormPath p "." 	a' = norm a 	b' = norm b+	norm = normalise . simplifyPath -{- Converts a filename into a normalized, absolute path.+{- Converts a filename into an absolute path.  -  - Unlike Directory.canonicalizePath, this does not require the path  - already exists. -}@@ -87,13 +119,6 @@ 	cwd <- getCurrentDirectory 	return $ absPathFrom cwd file -{- Converts a filename into a normalized, absolute path- - from the specified cwd. -}-absPathFrom :: FilePath -> FilePath -> FilePath-absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file-  where-	bad = error $ "unable to normalize " ++ file- {- Constructs a relative path from the CWD to a file.  -  - For example, assuming CWD is /tmp/foo/bar:@@ -105,7 +130,7 @@  {- Constructs a relative path from a directory to a file.  -- - Both must be absolute, and normalized (eg with absNormpath).+ - Both must be absolute, and cannot contain .. etc. (eg use absPath first).  -} relPathDirToFile :: FilePath -> FilePath -> FilePath relPathDirToFile from to = join s $ dotdots ++ uncommon@@ -252,3 +277,18 @@ 		| c == '.' = c 		| isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' 		| otherwise = c++{- Similar to splitExtensions, but knows that some things in FilePaths+ - after a dot are too long to be extensions. -}+splitShortExtensions :: FilePath -> (FilePath, [String])+splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"+splitShortExtensions' :: Int -> FilePath -> (FilePath, [String])+splitShortExtensions' maxextension = go []+  where+	go c f+		| len > 0 && len <= maxextension && not (null base) = +			go (ext:c) base+		| otherwise = (f, c)+	  where+		(base, ext) = splitExtension f+		len = length ext
+ Utility/PosixFiles.hs view
@@ -0,0 +1,33 @@+{- POSIX files (and compatablity wrappers).+ -+ - This is like System.PosixCompat.Files, except with a fixed rename.+ -+ - Copyright 2014 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.PosixFiles (+	module X,+	rename+) where++import System.PosixCompat.Files as X hiding (rename)++#ifndef mingw32_HOST_OS+import System.Posix.Files (rename)+#else+import qualified System.Win32.File as Win32+#endif++{- System.PosixCompat.Files.rename on Windows calls renameFile,+ - so cannot rename directories. + -+ - Instead, use Win32 moveFile, which can. It needs to be told to overwrite+ - any existing file. -}+#ifdef mingw32_HOST_OS+rename :: FilePath -> FilePath -> IO ()+rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING+#endif
Utility/QuickCheck.hs view
@@ -1,6 +1,6 @@ {- QuickCheck with additional instances  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -17,10 +17,14 @@ import Data.Time.Clock.POSIX import System.Posix.Types import qualified Data.Map as M+import qualified Data.Set as S import Control.Applicative  instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where 	arbitrary = M.fromList <$> arbitrary++instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where+	arbitrary = S.fromList <$> arbitrary  {- Times before the epoch are excluded. -} instance Arbitrary POSIXTime where
Utility/Tmp.hs view
@@ -13,10 +13,11 @@ import System.IO import System.Directory import Control.Monad.IfElse+import System.FilePath  import Utility.Exception-import System.FilePath import Utility.FileSystemEncoding+import Utility.PosixFiles  type Template = String @@ -30,7 +31,7 @@ 	(tmpfile, handle) <- openTempFile dir (base ++ ".tmp") 	hClose handle 	a tmpfile content-	renameFile tmpfile file+	rename tmpfile file  {- Runs an action with a tmp file located in the system's tmp directory  - (or in "." if there is none) then removes the file. -}
debian/changelog view
@@ -1,9 +1,18 @@+git-repair (1.20140227) unstable; urgency=medium++  * Optimise unpacking of pack files, and avoid repeated error+    messages about corrupt pack files.+  * Add swapping 2 files test case.++ -- Joey Hess <joeyh@debian.org>  Thu, 27 Feb 2014 11:56:27 -0400+ git-repair (1.20140115) unstable; urgency=medium    * Support old git versions from before git fsck --no-dangling was     implemented.   * Fix bug in packed refs file exploding code that caused a .gitrefs     directory to be created instead of .git/refs+  * Check git version at run time.   -- Joey Hess <joeyh@debian.org>  Wed, 15 Jan 2014 16:53:30 -0400
debian/control view
@@ -17,7 +17,7 @@ 	libghc-async-dev, 	libghc-optparse-applicative-dev Maintainer: Joey Hess <joeyh@debian.org>-Standards-Version: 3.9.4+Standards-Version: 3.9.5 Vcs-Git: git://git-repair.branchable.com/ Homepage: http://git-repair.branchable.com/
doc/index.mdwn view
@@ -44,7 +44,7 @@ try to clean up either the reflog or the stash.   Also note that the `--force` option never touches tags, even if they are no-longer usable due to missing data, so fack may also find problems with+longer usable due to missing data, so fsck may also find problems with tags.  Since this command unpacks all packs in the repository, you may want to
git-repair.1 view
@@ -28,6 +28,18 @@ .PP Since this command unpacks all packs in the repository, you may want to run \fBgit gc\fP afterwards.+.SH TESTING+git-repair is able to test itself, by making a temporary copy+of the git reposiory it's run in, damaging it in random ways, and checking+that it can repair it so that git fsck reports no problems.+.PP+This is done using the --test parameter and associated --numtests and+--retry parameters.+.PP+Note that the testing will sometimes find repositories that can only be+repaired when --force is used; this is expected. On the other hand,+if it fails to recover a repository with --force, then the testing has+found a bug! .PP .SH AUTHOR Joey Hess <joey@kitenet.net>
git-repair.cabal view
@@ -1,5 +1,5 @@ Name: git-repair-Version: 1.20140115+Version: 1.20140227 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess <joey@kitenet.net>
git-repair.hs view
@@ -52,8 +52,8 @@ 	desc = fullDesc 		<> header "git-repair - repair a damanged git repository"  	go settings-		| testMode settings = test settings 		| retryTestMode settings = retryTest settings+		| testMode settings = test settings 		| otherwise = repair settings  repair :: Settings -> IO ()