git-annex 6.20161027 → 6.20161031

raw patch · 4 files changed

+73/−31 lines, 4 files

Files

CHANGELOG +10/−0
Git/CatFile.hs +12/−11
Git/Fsck.hs +50/−19
git-annex.cabal +1/−1

CHANGELOG view

@@ -1,3 +1,13 @@+git-annex (6.20161031) unstable; urgency=medium++  * Assistant, repair: Fix ignoring of git fsck errors due to+    duplicate file entries in tree objects.+  * Linux standalone: Fix location of locale files in the bundle.+  * Fix reversion in 6.20161012 that prevented adding files with a space+    in their name.++ -- Joey Hess <id@joeyh.name>  Mon, 31 Oct 2016 18:55:59 -0400+ git-annex (6.20161027) unstable; urgency=medium    * lock, smudge: Fix edge cases where data loss could occur in v6 mode

Git/CatFile.hs view

@@ -109,17 +109,18 @@ 	send to = hPutStrLn to (fromRef object)  parseResp :: Ref -> String -> Maybe ParsedResp-parseResp object l = case words l of-	[sha, objtype, size]-		| length sha == shaSize ->-			case (readObjectType objtype, reads size) of-				(Just t, [(bytes, "")]) -> -					Just $ ParsedResp (Ref sha) bytes t-				_ -> Nothing-		| otherwise -> Nothing-	_-		| l == fromRef object ++ " missing" -> Just DNE-		| otherwise -> Nothing+parseResp object l +	| " missing" `isSuffixOf` l -- less expensive than full check+		&& l == fromRef object ++ " missing" = Just DNE+	| otherwise = case words l of+		[sha, objtype, size]+			| length sha == shaSize ->+				case (readObjectType objtype, reads size) of+					(Just t, [(bytes, "")]) -> +						Just $ ParsedResp (Ref sha) bytes t+					_ -> Nothing+			| otherwise -> Nothing+		_ -> Nothing  {- Gets a list of files and directories in a tree. (Not recursive.) -} catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)]

Git/Fsck.hs view

@@ -5,6 +5,8 @@  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE BangPatterns #-}+ module Git.Fsck ( 	FsckResults(..), 	MissingObjects,@@ -25,8 +27,6 @@ import qualified Data.Set as S import Control.Concurrent.Async -type MissingObjects = S.Set Sha- data FsckResults  	= FsckFoundMissing 		{ missingObjects :: MissingObjects@@ -35,6 +35,25 @@ 	| FsckFailed 	deriving (Show) +data FsckOutput +	= FsckOutput MissingObjects Truncated+	| NoFsckOutput+	| AllDuplicateEntriesWarning++type MissingObjects = S.Set Sha++type Truncated = Bool++instance Monoid FsckOutput where+	mempty = NoFsckOutput+	mappend (FsckOutput s1 t1) (FsckOutput s2 t2) = FsckOutput (S.union s1 s2) (t1 || t2)+	mappend (FsckOutput s t) _ = FsckOutput s t+	mappend _ (FsckOutput s t) = FsckOutput s t+	mappend NoFsckOutput NoFsckOutput = NoFsckOutput+	mappend AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning+	mappend AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning+	mappend NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning+ {- Runs fsck to find some of the broken objects in the repository.  - May not find all broken objects, if fsck fails on bad data in some of  - the broken objects it does find.@@ -58,18 +77,24 @@ 			{ std_out = CreatePipe 			, std_err = CreatePipe 			}-	(bad1, bad2) <- concurrently-		(readMissingObjs maxobjs r supportsNoDangling (stdoutHandle p))-		(readMissingObjs maxobjs r supportsNoDangling (stderrHandle p))+	(o1, o2) <- concurrently+		(parseFsckOutput maxobjs r supportsNoDangling (stdoutHandle p))+		(parseFsckOutput maxobjs r supportsNoDangling (stderrHandle p)) 	fsckok <- checkSuccessProcess pid-	let truncated = S.size bad1 == maxobjs || S.size bad1 == maxobjs-	let badobjs = S.union bad1 bad2--	if S.null badobjs && not fsckok-		then return FsckFailed-		else return $ FsckFoundMissing badobjs truncated+	case mappend o1 o2 of+		FsckOutput badobjs truncated+			| S.null badobjs && not fsckok -> return FsckFailed+			| otherwise -> return $ FsckFoundMissing badobjs truncated+		NoFsckOutput+			| not fsckok -> return FsckFailed+			| otherwise -> return noproblem+		-- If all fsck output was duplicateEntries warnings,+		-- the repository is not broken, it just has some unusual+		-- tree objects in it. So ignore nonzero exit status.+		AllDuplicateEntriesWarning -> return noproblem   where 	maxobjs = 10000+	noproblem = FsckFoundMissing S.empty False  foundBroken :: FsckResults -> Bool foundBroken FsckFailed = True@@ -87,10 +112,18 @@ findMissing :: [Sha] -> Repo -> IO MissingObjects findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs -readMissingObjs :: Int -> Repo -> Bool -> Handle -> IO MissingObjects-readMissingObjs maxobjs r supportsNoDangling h = do-	objs <- take maxobjs . findShas supportsNoDangling <$> hGetContents h-	findMissing objs r+parseFsckOutput :: Int -> Repo -> Bool -> Handle -> IO FsckOutput+parseFsckOutput maxobjs r supportsNoDangling h = do+	ls <- lines <$> hGetContents h+	if null ls+		then return NoFsckOutput+		else if all ("duplicateEntries" `isInfixOf`) ls+			then return AllDuplicateEntriesWarning+			else do+				let shas = findShas supportsNoDangling ls+				let !truncated = length shas > maxobjs+				missingobjs <- findMissing (take maxobjs shas) r+				return $ FsckOutput missingobjs truncated  isMissing :: Sha -> Repo -> IO Bool isMissing s r = either (const True) (const False) <$> tryIO dump@@ -100,12 +133,10 @@ 		, Param (fromRef s) 		] r -findShas :: Bool -> String -> [Sha]-findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted . lines+findShas :: Bool -> [String] -> [Sha]+findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted   where 	wanted l-		-- Skip lines like "error in tree <sha>: duplicateEntries: contains duplicate file entries"-		| "duplicateEntries" `isInfixOf` l = False 		| supportsNoDangling = True 		| otherwise = not ("dangling " `isPrefixOf` l)

git-annex.cabal view

@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20161027+Version: 6.20161031 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>