initial work on git repository destroyer

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

9 files changed, 261 insertions, 8 deletions

diff --git a/.gitignore b/.gitignore
index 55a966c..61a7f1e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,5 @@
 Build/SysConfig.hs
 tags
 git-repair
+test-runner
+test-runner.log
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
diff --git a/Makefile b/Makefile
index 07df05d..90274ac 100644
--- a/Makefile
+++ b/Makefile
@@ -4,6 +4,7 @@ CABAL?=cabal # set to "./Setup" if you lack a cabal program
 build: Build/SysConfig.hs
 	$(CABAL) build
 	ln -sf dist/build/git-repair/git-repair git-repair
+	ln -sf dist/build/test-runner/test-runner test-runner
 	@$(MAKE) tags >/dev/null 2>&1 &
 
 Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs
@@ -17,9 +18,10 @@ install: build
 	install -m 0644 git-repair.1 $(DESTDIR)$(PREFIX)/share/man/man1
 
 clean:
-	rm -rf git-repair dist configure Build/SysConfig.hs Setup tags
-	find -name \*.o -exec rm {} \;
-	find -name \*.hi -exec rm {} \;
+	rm -rf git-repair test-runner test-runner.log \
+		dist configure Build/SysConfig.hs Setup tags
+	find . -name \*.o -exec rm {} \;
+	find . -name \*.hi -exec rm {} \;
 
 # Upload to hackage.
 hackage: clean
diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs
index d76fb57..1307d38 100644
--- a/Utility/FileMode.hs
+++ b/Utility/FileMode.hs
@@ -65,12 +65,15 @@ allowWrite :: FilePath -> IO ()
 allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]
 
 {- Allows owner and group to read and write to a file. -}
-groupWriteRead :: FilePath -> IO ()
-groupWriteRead f = modifyFileMode f $ addModes
+groupSharedModes :: [FileMode]
+groupSharedModes =
 	[ ownerWriteMode, groupWriteMode
 	, ownerReadMode, groupReadMode
 	]
 
+groupWriteRead :: FilePath -> IO ()
+groupWriteRead f = modifyFileMode f $ addModes groupSharedModes
+
 checkMode :: FileMode -> FileMode -> Bool
 checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor
 
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
new file mode 100644
index 0000000..82af09f
--- /dev/null
+++ b/Utility/QuickCheck.hs
@@ -0,0 +1,48 @@
+{- QuickCheck with additional instances
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Utility.QuickCheck
+	( module X
+	, module Utility.QuickCheck
+	) where
+
+import Test.QuickCheck as X
+import Data.Time.Clock.POSIX
+import System.Posix.Types
+import qualified Data.Map as M
+import Control.Applicative
+
+instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where
+	arbitrary = M.fromList <$> arbitrary
+
+{- Times before the epoch are excluded. -}
+instance Arbitrary POSIXTime where
+	arbitrary = nonNegative arbitrarySizedIntegral
+
+instance Arbitrary EpochTime where
+	arbitrary = nonNegative arbitrarySizedIntegral
+
+{- Pids are never negative, or 0. -}
+instance Arbitrary ProcessID where
+	arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)
+
+{- Inodes are never negative. -}
+instance Arbitrary FileID where
+	arbitrary = nonNegative arbitrarySizedIntegral
+
+{- File sizes are never negative. -}
+instance Arbitrary FileOffset where
+	arbitrary = nonNegative arbitrarySizedIntegral
+
+nonNegative :: (Num a, Ord a) => Gen a -> Gen a
+nonNegative g = g `suchThat` (>= 0)
+
+positive :: (Num a, Ord a) => Gen a -> Gen a
+positive g = g `suchThat` (> 0)
diff --git a/git-repair.cabal b/git-repair.cabal
index 15acb79..a74b117 100644
--- a/git-repair.cabal
+++ b/git-repair.cabal
@@ -28,6 +28,18 @@ Executable git-repair
   if (! os(windows))
     Build-Depends: unix
 
+Executable test-runner
+  Main-Is: test-runner.hs
+  GHC-Options: -Wall
+  Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl,
+   network, extensible-exceptions, unix-compat, bytestring,
+   base >= 4.5, base < 5, IfElse, text, process,
+   utf8-string, async, optparse-applicative,
+   QuickCheck >= 2.1, time
+
+  if (! os(windows))
+    Build-Depends: unix
+
 source-repository head
   type: git
   location: git://git-repair.branchable.com/
diff --git a/git-repair.hs b/git-repair.hs
index 9ece7e5..5a092d3 100644
--- a/git-repair.hs
+++ b/git-repair.hs
@@ -5,7 +5,6 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-import Data.Tuple.Utils
 import Options.Applicative
 
 import Common
@@ -22,7 +21,7 @@ parseSettings = Settings
 	<$> switch forceopt
   where
 	forceopt = long "force"
-		<> help "Force recovery, even if data is lost"
+		<> help "Force repair, even if data is lost"
 
 main :: IO ()
 main = execParser opts >>= repair
@@ -34,7 +33,7 @@ main = execParser opts >>= repair
 repair :: Settings -> IO ()
 repair settings = do
 	g <- Git.Config.read =<< Git.CurrentRepo.get
-	ifM (fst3 <$> Git.Repair.runRepair (forced settings) g)
+	ifM (Git.Repair.successfulRepair <$> Git.Repair.runRepair (forced settings) g)
 		( exitSuccess
 		, exitFailure
 		)
diff --git a/test-runner.hs b/test-runner.hs
new file mode 100644
index 0000000..6687744
--- /dev/null
+++ b/test-runner.hs
@@ -0,0 +1,66 @@
+{- Test runner
+ -
+ - Passed a git repository, makes a temporary clone of the git repository,
+ - corrupts part of it, then tries to repair it, and logs the result.
+ -}
+
+module Main where
+
+import Options.Applicative
+
+import Common
+import qualified Git.Construct
+import qualified Git.Config
+import qualified Git.Destroyer
+import qualified Git.Repair
+import Utility.Tmp
+
+data Settings = Settings
+	{ originalGitRepo :: FilePath
+	, forced :: Bool
+	}
+
+parseSettings :: Parser Settings
+parseSettings = Settings
+	<$> argument str (metavar "REPO")
+        <*> switch forceopt
+  where
+	forceopt = long "force"
+		<> help "Force repair"
+
+main :: IO ()
+main = execParser opts >>= runTest
+  where
+	opts = info (helper <*> parseSettings) desc
+	desc = fullDesc
+		<> header "test-runner - test command in corrupted git repository"
+
+runTest :: Settings -> IO ()
+runTest settings = withTmpDir "tmprepo" $ \tmpdir -> do
+	let cloneloc = tmpdir </> "clone"
+	cloned <- boolSystem "git"
+		[ Param "clone"
+		, File (originalGitRepo settings)
+		, File cloneloc
+		]
+	unless cloned $
+		error $ "failed to clone " ++ originalGitRepo settings
+	-- Note that we read the config before destroying the repo.
+	-- Recovering from repos with a corrupted config is not currently
+	-- a goal.
+	g <- Git.Config.read =<< Git.Construct.fromPath cloneloc
+	damage <- Git.Destroyer.generateDamage
+	Git.Destroyer.applyDamage damage g
+	result <- catchMaybeIO $ Git.Repair.successfulRepair
+		<$> Git.Repair.runRepair (forced settings) g
+	logTest damage result
+	case result of
+		Just True -> exitSuccess
+		_ -> exitFailure
+
+data TestLog = TestLog [Git.Destroyer.Damage] (Maybe Bool)
+	deriving (Read, Show)
+
+logTest :: [Git.Destroyer.Damage] -> Maybe Bool -> IO ()
+logTest damage result =
+	appendFile "test-runner.log" $ show (TestLog damage result) ++ "\n"