File: Destroyer.hs

package info (click to toggle)
git-repair 1.20151215-1.2
  • links: PTS
  • area: main
  • in suites:
  • size: 548 kB
  • sloc: haskell: 4,574; makefile: 29; sh: 19
file content (148 lines) | stat: -rw-r--r-- 4,311 bytes parent folder | download
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
{- git repository destroyer
 -
 - Use with caution!
 -
 - Copyright 2013, 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Git.Destroyer (
	Damage(..),
	generateDamage,
	applyDamage
) where

import Common
import Git
import Utility.QuickCheck
import Utility.FileMode
import Utility.Tmp

import qualified Data.ByteString as B
import Data.Word

{- Ways to damange a git repository. -}
data Damage
	= Empty FileSelector
	| Delete FileSelector
	| Reverse FileSelector
	| AppendGarbage FileSelector B.ByteString
	| PrependGarbage FileSelector B.ByteString
	| CorruptByte FileSelector Int Word8
	| ScrambleFileMode FileSelector FileMode
	| SwapFiles FileSelector FileSelector
	deriving (Read, Show)

instance Arbitrary Damage where
	arbitrary = oneof
		[ Empty <$> arbitrary
		, Delete <$> arbitrary
		, Reverse <$> arbitrary
		, AppendGarbage <$> arbitrary <*> garbage
		, PrependGarbage <$> arbitrary <*> garbage
		, CorruptByte
			<$> arbitrary
			<*> nonNegative arbitraryBoundedIntegral
			<*> arbitrary
		, ScrambleFileMode
			<$> arbitrary
			<*> nonNegative arbitrarySizedIntegral
		, SwapFiles
			<$> arbitrary
			<*> arbitrary
		]
	  where
		garbage = B.pack <$> arbitrary `suchThat` (not . null)

{- To select a given file in a git repository, all files in the repository
 - are enumerated, sorted, and this is used as an index
 - into the list. (Wrapping around if higher than the length.) -}
data FileSelector = FileSelector Int
	deriving (Read, Show, Eq)

instance Arbitrary FileSelector where
	arbitrary = FileSelector <$> oneof
		-- An early file in the git tree, tends to be the most
		-- interesting when there are lots of files.
		[ nonNegative arbitrarySizedIntegral
		-- Totally random choice from any of the files in
		-- the git tree, to ensure good coverage.
		, nonNegative arbitraryBoundedIntegral
		]

selectFile :: [FilePath] -> FileSelector -> FilePath
selectFile sortedfs (FileSelector n) = sortedfs !! (n `mod` length sortedfs)

{- Generates random Damage. -}
generateDamage :: IO [Damage]
generateDamage = sample' (arbitrary :: Gen Damage)

{- Applies Damage to a Repo, in a reproducible fashion
 - (as long as the Repo contains the same files each time). -}
applyDamage :: [Damage] -> Repo -> IO ()
applyDamage ds r = do
	contents <- sort . filter (not . skipped)
		<$> dirContentsRecursive (localGitDir r)
	forM_ ds $ \d -> do
		let withfile s a = do
			let f = selectFile contents s
			-- Symlinks might be dangling, so are skipped.
			-- If the file was already removed by a previous Damage,
			-- it's skipped.
			whenM (doesFileExist f) $
				a f `catchIO` \e -> error ("Failed to apply damage " ++ show d ++ " to " ++ show f ++ ": " ++ show e ++ "(total damage: " ++ show ds ++ ")")
		case d of
			Empty s -> withfile s $ \f ->
				withSaneMode f $ do
					nukeFile f
					writeFile f ""
			Reverse s -> withfile s $ \f ->
				withSaneMode f $
					B.writeFile f =<< B.reverse <$> B.readFile f
			Delete s -> withfile s $ nukeFile
			AppendGarbage s garbage ->
				withfile s $ \f ->
					withSaneMode f $
					B.appendFile f garbage
			PrependGarbage s garbage ->
				withfile s $ \f ->
					withSaneMode f $ do
						b <- B.readFile f
						B.writeFile f $ B.concat [garbage, b]
			-- When the byte is past the end of the
			-- file, wrap around. Does nothing to empty file.
			CorruptByte s n garbage ->
				withfile s $ \f ->
					withSaneMode f $ do
						b <- B.readFile f
						let len = B.length b
						unless (len == 0) $ do
							let n' = n `mod` len
							let (prefix, rest) = B.splitAt n' b
							B.writeFile f $ B.concat
								[prefix
								, B.singleton garbage
								, B.drop 1 rest
								]
			ScrambleFileMode s mode ->
				withfile s $ \f ->
					setFileMode f mode
			SwapFiles a b ->
				withfile a $ \fa ->
					withfile b $ \fb -> 
						unless (fa == fb) $
							withTmpFile "swap" $ \tmp _ -> do
								moveFile fa tmp
								moveFile fb fa
								moveFile tmp fa
  where
	-- A broken .git/config is not recoverable.
	-- Don't damage hook scripts, to avoid running arbitrary code. ;)
	skipped f = or
		[ takeFileName f == "config"
		, "hooks" `isPrefixOf` f
		]

withSaneMode :: FilePath -> IO () -> IO ()
withSaneMode f = withModifiedFileMode f (addModes [ownerWriteMode, ownerReadMode])