diff options
Diffstat (limited to 'Git/Fsck.hs')
| -rw-r--r-- | Git/Fsck.hs | 58 |
1 files changed, 45 insertions, 13 deletions
diff --git a/Git/Fsck.hs b/Git/Fsck.hs index 2c94230..16b0235 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -21,6 +21,8 @@ import Git.CatFile import Utility.Batch import qualified Data.Set as S +import System.Process (std_err, std_out) +import Control.Concurrent type MissingObjects = S.Set Sha @@ -36,17 +38,47 @@ type FsckResults = Maybe MissingObjects - look for anything in its output (both stdout and stderr) that appears - to be a git sha. Not all such shas are of broken objects, so ask git - to try to cat the object, and see if it fails. + - + - Some forms of corruption will crash fsck in ways that does not let it + - output the sha of the broken object. In such a case, Nothing will be + - returned. In this case, to find broken objects, re-run with tryharder + - set to True. This makes fsck run in verbose mode, so it prints out + - shas before checking them. We assume that the last sha is the one that + - it crashed on, and it may have crashed following from eg, a commit to a + - tree to a subtree. So, run git show on the sha, and examin the stderr + - to find an actual bad sha. -} -findBroken :: Bool -> Repo -> IO FsckResults -findBroken batchmode r = do +findBroken :: Bool -> Bool -> Repo -> IO FsckResults +findBroken batchmode tryharder r = do (output, fsckok) <- processTranscript command' (toCommand params') Nothing - let objs = parseFsckOutput output - badobjs <- findMissing objs r - if S.null badobjs && not fsckok - then return Nothing - else return $ Just badobjs + let objs = findShas output + if fsckok || not tryharder + then do + badobjs <- findMissing objs r + if S.null badobjs && not fsckok + then return Nothing + else return $ Just badobjs + else case lastMaybe objs of + Nothing -> return Nothing + Just o -> do + p@(_, _, _, pid) <- createProcess $ + ( proc "git" $ toCommand $ gitCommandLine [ Param "show", Param $ show o ] r ) + { std_err = CreatePipe + , std_out = CreatePipe + } + void $ forkIO $ void $ hGetContents (stdoutHandle p) + objs' <- findShas <$> + hGetContentsStrict (stderrHandle p) + badobjs <- findMissing objs' r + ifM (checkSuccessProcess pid) + ( if S.null badobjs + then return Nothing + else return $ Just badobjs + , return $ Just $ S.singleton o + ) + where - (command, params) = ("git", fsckParams r) + (command, params) = ("git", fsckParams tryharder r) (command', params') | batchmode = toBatchCommand (command, params) | otherwise = (command, params) @@ -76,12 +108,12 @@ findMissing objs r = go objs [] =<< start Right True -> go os (o:c) h Right False -> go os c h -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 :: Bool -> Repo -> [CommandParam] +fsckParams verbose = gitCommandLine $ [ Param "fsck" , Param "--no-dangling" , Param "--no-reflogs" - ] + ] ++ if verbose then [ Param "--verbose" ] else [] |