summaryrefslogtreecommitdiff
path: root/Git/Fsck.hs
blob: a716b56e3a22fec39928c42f6f95b001006894f7 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
{- git fsck interface
 -
 - Copyright 2013 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE BangPatterns #-}

module Git.Fsck (
	FsckResults(..),
	MissingObjects,
	findBroken,
	foundBroken,
	findMissing,
	isMissing,
	knownMissing,
) where

import Common
import Git
import Git.Command
import Git.Sha
import Utility.Batch
import qualified Git.Version

import qualified Data.Set as S
import Control.Concurrent.Async

data FsckResults 
	= FsckFoundMissing
		{ missingObjects :: MissingObjects
		, missingObjectsTruncated :: Bool
		}
	| 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.
 -
 - Strategy: Rather than parsing fsck's current specific output,
 - 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.
 -}
findBroken :: Bool -> Repo -> IO FsckResults
findBroken batchmode r = do
	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)
	
	p@(_, _, _, pid) <- createProcess $
		(proc command' (toCommand params'))
			{ std_out = CreatePipe
			, std_err = CreatePipe
			}
	(o1, o2) <- concurrently
		(parseFsckOutput maxobjs r supportsNoDangling (stdoutHandle p))
		(parseFsckOutput maxobjs r supportsNoDangling (stderrHandle p))
	fsckok <- checkSuccessProcess pid
	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
foundBroken (FsckFoundMissing s _) = not (S.null s)

knownMissing :: FsckResults -> MissingObjects
knownMissing FsckFailed = S.empty
knownMissing (FsckFoundMissing s _) = 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.
 -}
findMissing :: [Sha] -> Repo -> IO MissingObjects
findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs

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
  where
	dump = runQuiet
		[ Param "show"
		, Param (fromRef s)
		] r

findShas :: Bool -> [String] -> [Sha]
findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted
  where
	wanted l
		| supportsNoDangling = True
		| otherwise = not ("dangling " `isPrefixOf` l)

fsckParams :: Bool -> Repo -> [CommandParam]
fsckParams supportsNoDangling = gitCommandLine $ map Param $ catMaybes
	[ Just "fsck"
	, if supportsNoDangling
		then Just "--no-dangling"
		else Nothing
	, Just "--no-reflogs"
	]