diff options
Diffstat (limited to 'Git/Fsck.hs')
| -rw-r--r-- | Git/Fsck.hs | 45 |
1 files changed, 8 insertions, 37 deletions
diff --git a/Git/Fsck.hs b/Git/Fsck.hs index ad92cdb..9c62ae0 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -21,8 +21,6 @@ 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 @@ -38,47 +36,20 @@ 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 -> Bool -> Repo -> IO FsckResults -findBroken batchmode tryharder r = do +findBroken :: Bool -> Repo -> IO FsckResults +findBroken batchmode r = do (output, fsckok) <- processTranscript command' (toCommand params') Nothing let objs = findShas output - if fsckok || not tryharder + if fsckok 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 - ) - + else return Nothing where - (command, params) = ("git", fsckParams tryharder r) + (command, params) = ("git", fsckParams r) (command', params') | batchmode = toBatchCommand (command, params) | otherwise = (command, params) @@ -111,9 +82,9 @@ findMissing objs r = go objs [] =<< start findShas :: String -> [Sha] findShas = catMaybes . map extractSha . concat . map words . lines -fsckParams :: Bool -> Repo -> [CommandParam] -fsckParams verbose = gitCommandLine $ +fsckParams :: Repo -> [CommandParam] +fsckParams = gitCommandLine $ [ Param "fsck" , Param "--no-dangling" , Param "--no-reflogs" - ] ++ if verbose then [ Param "--verbose" ] else [] + ] |