diff options
Diffstat (limited to 'Git')
| -rw-r--r-- | Git/Fsck.hs | 24 | ||||
| -rw-r--r-- | Git/Repair.hs | 43 |
2 files changed, 38 insertions, 29 deletions
diff --git a/Git/Fsck.hs b/Git/Fsck.hs index 309f4bb..a3a6e77 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -17,9 +17,12 @@ import Common import Git import Git.Command import Git.Sha +import Git.Objects import Utility.Batch +import Utility.Hash import qualified Data.Set as S +import qualified Data.ByteString.Lazy as L type MissingObjects = S.Set Sha @@ -57,18 +60,33 @@ foundBroken (Just s) = not (S.null s) {- Finds objects that are missing from the git repsitory, or are corrupt. - - This does not use git cat-file --batch, because catting a corrupt - - object can cause it to crash, or to report incorrect size information. + - object can cause it to crash, or to report incorrect size information.a + - + - Note that git cat-file -p can succeed in printing out objects that + - are corrupt. Since its output may be a pretty-printed object, or may be + - a blob, it cannot be verified. So, this has false negatives. + - + - As a secondary check, if cat-file says the object is there, check if + - the loose object file is available, and if so, try taking its sha1 + - ourselves. This will always work once all packs have been unpacked. -} findMissing :: [Sha] -> Repo -> IO MissingObjects -findMissing objs r = S.fromList <$> filterM (not <$$> cancat) objs +findMissing objs r = S.fromList <$> filterM (not <$$> present) objs where - cancat o = either (const False) (const True) <$> tryIO (cat o) + present o = + either (const $ return False) (const $ verifyLooseObject o r) + =<< tryIO (cat o) cat o = runQuiet [ Param "cat-file" , Param "-p" , Param (show o) ] r +verifyLooseObject :: Sha -> Repo -> IO Bool +verifyLooseObject s r = do + sha <- sha1 <$> L.readFile (looseObjectFile r s) + return $ show sha == show s + findShas :: String -> [Sha] findShas = catMaybes . map extractSha . concat . map words . lines diff --git a/Git/Repair.hs b/Git/Repair.hs index 88150e4..3fb79df 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -78,26 +78,13 @@ cleanCorruptObjects mmissing r = check mmissing putStrLn "Re-running git fsck to see if it finds more problems." v <- findBroken False r case v of - Nothing - | numremoved > 0 -> do - hPutStrLn stderr $ unwords - [ "git fsck found a problem, which was not corrected after removing" - , show numremoved - , "corrupt objects." - ] - return Nothing - | otherwise -> do - hPutStrLn stderr "Repacking all objects, to try to flush out unknown corrupt ones." - void $ runBool - [ Param "repack" - , Param "-a" - ] r - void $ runBool - [ Param "prune-packed" - ] r - s <- S.fromList <$> listLooseObjectShas r - void $ removeLoose r s - retry (S.size s) S.empty + Nothing -> do + hPutStrLn stderr $ unwords + [ "git fsck found a problem, which was not corrected after removing" + , show numremoved + , "corrupt objects." + ] + return Nothing Just newbad -> do removed <- removeLoose r newbad let s = S.union oldbad newbad @@ -133,6 +120,7 @@ explodePacks r = 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", Param "-r"] r $ \h -> @@ -267,8 +255,7 @@ removeTrackingBranches missing goodcommits r = getAllRefs :: Repo -> IO [Ref] getAllRefs r = do packedrs <- mapMaybe parsePacked . lines - <$> catchDefaultIO "" - (readFileStrictAnyEncoding $ packedRefsFile r) + <$> catchDefaultIO "" (safeReadFile $ packedRefsFile r) loosers <- map toref <$> dirContentsRecursive refdir return $ packedrs ++ loosers where @@ -296,9 +283,9 @@ nukeBranchRef b r = void $ usegit <||> byhand ] r byhand = do nukeFile $ localGitDir r </> show b - whenM (doesFileExist packedrefs) $ + whenM (doesFileExist packedrefs) $ do withTmpFile "packed-refs" $ \tmp h -> do - ls <- lines <$> readFileStrictAnyEncoding packedrefs + ls <- lines <$> safeReadFile packedrefs hPutStr h $ unlines $ filter (not . skiprefline) ls hClose h @@ -476,8 +463,7 @@ displayList items header -} preRepair :: Repo -> IO () preRepair g = do - void $ tryIO $ allowRead headfile - unlessM (validhead <$> catchDefaultIO "" (readFileStrictAnyEncoding headfile)) $ do + unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do nukeFile headfile writeFile headfile "ref: refs/heads/master" where @@ -596,3 +582,8 @@ runRepairOf fsckresult forced referencerepo g = do successfulRepair :: (Bool, MissingObjects, [Branch]) -> Bool successfulRepair = fst3 + +safeReadFile :: FilePath -> IO String +safeReadFile f = do + allowRead f + readFileStrictAnyEncoding f |