initial work on git repository destroyer

I suspect this might sometimes corrupt the **source** repo, so use with
caution!

2 files changed, 121 insertions, 0 deletions

diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs
new file mode 100644
index 0000000..baffa05
--- /dev/null
+++ b/Git/Destroyer.hs
@@ -0,0 +1,117 @@
+{- git repository destroyer
+ -
+ - Use with caution!
+ -
+ - Copyright 2013 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 qualified Data.ByteString as B
+import Data.Word
+import System.PosixCompat.Types
+
+{- Ways to damange a git repository. -}
+data Damage = Damage DamageAction FileSelector
+	deriving (Read, Show)
+
+instance Arbitrary Damage where
+	arbitrary = Damage <$> arbitrary <*> arbitrary
+
+data DamageAction
+	= Empty
+	| Delete
+	| Reverse
+	| AppendGarbage B.ByteString
+	| PrependGarbage B.ByteString
+	| CorruptByte Int Word8
+	| ScrambleFileMode FileMode
+	deriving (Read, Show)
+
+instance Arbitrary DamageAction where
+	arbitrary = oneof
+		[ pure Empty
+		, pure Delete
+		, pure Reverse
+		, AppendGarbage <$> garbage
+		, PrependGarbage <$> garbage
+		, CorruptByte
+			<$> nonNegative arbitrarySizedIntegral
+			<*> arbitrary
+		, ScrambleFileMode <$> nonNegative arbitrarySizedIntegral
+		]
+	  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)
+
+instance Arbitrary FileSelector where
+	arbitrary = FileSelector <$> nonNegative arbitrarySizedIntegral
+
+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 l r = do
+	contents <- sort <$> dirContentsRecursive (localGitDir r)
+	forM_ l $ \(Damage action fileselector) -> do
+		let f = selectFile contents fileselector
+		-- Symlinks might be dangling, so are skipped.
+		-- If the file was already removed by a previous Damage,
+		-- it's skipped.
+		whenM (doesFileExist f) $
+			withModifiedFileMode f (addModes [ownerWriteMode]) $
+				applyDamageAction action f
+					`catchIO` \e -> error ("Failed to apply " ++ show action ++ " " ++ show f ++ ": " ++ show e)
+
+applyDamageAction :: DamageAction -> FilePath -> IO ()
+applyDamageAction Empty f = changeFile f $ do
+	nukeFile f
+	writeFile f ""
+applyDamageAction Reverse f = changeFile f $
+	B.writeFile f =<< B.reverse <$> B.readFile f
+applyDamageAction Delete f = nukeFile f
+applyDamageAction (AppendGarbage garbage) f = changeFile f $
+	B.appendFile f garbage
+applyDamageAction (PrependGarbage garbage) f = changeFile 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.
+applyDamageAction (CorruptByte n garbage) 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
+			]
+applyDamageAction (ScrambleFileMode mode) f = setFileMode f mode
+
+-- Files in git are often not writable, so fix up mode temporarily.
+changeFile :: FilePath -> IO () -> IO ()
+changeFile f = withModifiedFileMode f (addModes [ownerWriteMode])
diff --git a/Git/Repair.hs b/Git/Repair.hs
index 270b041..41d0535 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -8,6 +8,7 @@
 module Git.Repair (
 	runRepair,
 	runRepairOf,
+	successfulRepair,
 	cleanCorruptObjects,
 	retrieveMissingObjects,
 	resetLocalBranches,
@@ -452,6 +453,9 @@ runRepair forced g = do
 			putStrLn "No problems found."
 			return (True, S.empty, [])
 
+successfulRepair :: (Bool, MissingObjects, [Branch]) -> Bool
+successfulRepair = fst3
+
 runRepairOf :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch])
 runRepairOf fsckresult forced referencerepo g = do
 	missing <- cleanCorruptObjects fsckresult g