retrying

4 files changed, 63 insertions, 41 deletions

diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs
index 74a7941..7597be8 100644
--- a/Git/Destroyer.hs
+++ b/Git/Destroyer.hs
@@ -87,20 +87,20 @@ applyDamage l r = do
 				`catchIO` \e -> error ("Failed to apply " ++ show action ++ " " ++ show f ++ ": " ++ show e ++ "(total damage: " ++ show l ++ ")")
 
 applyDamageAction :: DamageAction -> FilePath -> IO ()
-applyDamageAction Empty f = changeFile f $ do
+applyDamageAction Empty f = withSaneMode f $ do
 	nukeFile f
 	writeFile f ""
-applyDamageAction Reverse f = changeFile f $
+applyDamageAction Reverse f = withSaneMode f $
 	B.writeFile f =<< B.reverse <$> B.readFile f
 applyDamageAction Delete f = nukeFile f
-applyDamageAction (AppendGarbage garbage) f = changeFile f $
+applyDamageAction (AppendGarbage garbage) f = withSaneMode f $
 	B.appendFile f garbage
-applyDamageAction (PrependGarbage garbage) f = changeFile f $ do
+applyDamageAction (PrependGarbage garbage) 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.
-applyDamageAction (CorruptByte n garbage) f = changeFile f $ do
+applyDamageAction (CorruptByte n garbage) f = withSaneMode f $ do
 	b <- B.readFile f
 	let len = B.length b
 	unless (len == 0) $ do
@@ -113,6 +113,5 @@ applyDamageAction (CorruptByte n garbage) f = changeFile f $ do
 			]
 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])
+withSaneMode :: FilePath -> IO () -> IO ()
+withSaneMode f = withModifiedFileMode f (addModes [ownerWriteMode, ownerReadMode])
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index a2c9c81..4b0e9a1 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -15,6 +15,7 @@ import Foreign
 import Data.Char
 import Data.List
 import Control.Applicative
+import System.Exit
 #ifndef mingw32_HOST_OS
 import System.Posix.Process (getAnyProcessStatus)
 import Utility.Exception
@@ -136,3 +137,7 @@ reapZombies = do
 #else
 reapZombies = return ()
 #endif
+
+exitBool :: Bool -> IO a
+exitBool False = exitFailure
+exitBool True = exitSuccess
diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs
index 186cd12..3770654 100644
--- a/Utility/Tmp.hs
+++ b/Utility/Tmp.hs
@@ -62,7 +62,7 @@ withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a
 withTmpDirIn tmpdir template = bracket create remove
   where
 	remove d = whenM (doesDirectoryExist d) $
-		removeDirectoryRecursive d
+		return () -- removeDirectoryRecursive d
 	create = do
 		createDirectoryIfMissing True tmpdir
 		makenewdir (tmpdir </> template) (0 :: Int)
diff --git a/test-runner.hs b/test-runner.hs
index 58c80b8..a17d678 100644
--- a/test-runner.hs
+++ b/test-runner.hs
@@ -19,25 +19,45 @@ import Utility.Tmp
 data Settings = Settings
 	{ originalGitRepo :: FilePath
 	, forced :: Bool
+	, retryMode :: Bool
 	}
 
 parseSettings :: Parser Settings
 parseSettings = Settings
 	<$> argument str (metavar "REPO")
         <*> switch forceopt
+	<*> switch retryopt
   where
 	forceopt = long "force"
 		<> help "Force repair"
+	retryopt = long "retry"
+		<> help "Retry tests in test-runner.log"
 
 main :: IO ()
-main = execParser opts >>= runTest
+main = execParser opts >>= run
   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
+run :: Settings -> IO ()
+run settings
+	| retryMode settings = do
+		l <- map Prelude.read . lines <$> readFile logFile
+		rs <- forM l $ \damage -> 
+			runTest settings damage >>= showTestResult
+		exitBool $ and rs
+	| otherwise = runRandomTest settings
+
+runRandomTest :: Settings -> IO ()
+runRandomTest settings = do
+	damage <- Git.Destroyer.generateDamage
+	logDamage damage
+	result <- runTest settings damage
+	showTestResult result >>= exitBool
+
+runTest :: Settings -> [Git.Destroyer.Damage] -> IO TestResult
+runTest settings damage = withTmpDir "tmprepo" $ \tmpdir -> do
 	let cloneloc = tmpdir </> "clone"
 	cloned <- boolSystem "git"
 		[ Param "clone"
@@ -47,39 +67,37 @@ runTest settings = withTmpDir "tmprepo" $ \tmpdir -> do
 		]
 	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
+	repairstatus <- catchMaybeIO $ Git.Repair.successfulRepair
 		<$> Git.Repair.runRepair (forced settings) g
-	case result of
-		Just True -> do
-			fsckok <- not . Git.Fsck.foundBroken
-				<$> Git.Fsck.findBroken False g
-			logTest damage result (Just fsckok)
-			if fsckok
-				then do
-					putStrLn "** repair succeeded"
-					exitSuccess
-				else do
-					putStrLn "** repair succeeded, but final fsck failed"
-					exitFailure
-		_ -> do
-			logTest damage result Nothing
-			putStrLn "** repair failed"
-			exitFailure
+	case repairstatus of
+		Just True -> TestResult damage repairstatus 
+			. Just . not . Git.Fsck.foundBroken
+			<$> Git.Fsck.findBroken False g
+		_ -> return $ TestResult damage repairstatus Nothing
 
-data TestLog = TestLog
-	{ damagelist :: [Git.Destroyer.Damage]
-	, resut :: Maybe Bool
-	, fsckresult ::  Maybe Bool
+data TestResult = TestResult
+	{ damageList :: [Git.Destroyer.Damage]
+	, repairResult :: Maybe Bool
+	, fsckResult ::  Maybe Bool
 	}
 	deriving (Read, Show)
 
-logTest :: [Git.Destroyer.Damage] -> Maybe Bool -> Maybe Bool -> IO ()
-logTest damage result fsckok =
-	appendFile "test-runner.log" $
-		show (TestLog damage result fsckok) ++ "\n"
+showTestResult :: TestResult -> IO Bool
+showTestResult testresult = case (repairResult testresult, fsckResult testresult) of
+	(Just True, Just True) -> do
+		putStrLn "** repair succeeded"
+		return True
+	(Just True, Just False) -> do
+		putStrLn "** repair succeeded, but final fsck failed"
+		return False
+	_ -> do
+		putStrLn "** repair failed"
+		return True
+
+logDamage :: [Git.Destroyer.Damage] -> IO ()
+logDamage damage = appendFile logFile $ show damage ++ "\n"
+
+logFile :: FilePath
+logFile = "test-runner.log"