diff options
-rw-r--r-- | Git/Destroyer.hs | 15 | ||||
-rw-r--r-- | Utility/Misc.hs | 5 | ||||
-rw-r--r-- | Utility/Tmp.hs | 2 | ||||
-rw-r--r-- | test-runner.hs | 82 |
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" |