diff options
-rw-r--r-- | Makefile | 3 | ||||
-rw-r--r-- | debian/changelog | 4 | ||||
-rw-r--r-- | git-repair-test.hs | 126 | ||||
-rw-r--r-- | git-repair.cabal | 14 | ||||
-rw-r--r-- | git-repair.hs | 97 |
5 files changed, 100 insertions, 144 deletions
@@ -4,7 +4,6 @@ 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/git-repair-test/git-repair-test git-repair-test @$(MAKE) tags >/dev/null 2>&1 & Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs @@ -18,7 +17,7 @@ install: build install -m 0644 git-repair.1 $(DESTDIR)$(PREFIX)/share/man/man1 clean: - rm -rf git-repair git-repair-test git-repair-test.log \ + rm -rf git-repair git-repair-test.log \ dist configure Build/SysConfig.hs Setup tags find . -name \*.o -exec rm {} \; find . -name \*.hi -exec rm {} \; diff --git a/debian/changelog b/debian/changelog index 3d2b6bf..8fbb6ef 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,6 +1,6 @@ git-repair (1.20131119) UNRELEASED; urgency=low - * Added test-runner, which can be used to randomly corrupt test + * Added test mode, which can be used to randomly corrupt test repositories, in reproducible ways, which allows easy corruption-driven-development. * Improve repair code in the case where the index file is corrupt, @@ -10,7 +10,7 @@ git-repair (1.20131119) UNRELEASED; urgency=low * Improve fsck code to find badly corrupted objects that crash git fsck before it can complain about them. * Fixed crashes on bad file encodings. - * Can now run 1000 tests (./test-runner . --stop-on-failure -n 10000 --force) + * Can now run 1000 tests (git-repair --test -n 10000 --force) with 0 failures. -- Joey Hess <joeyh@debian.org> Tue, 19 Nov 2013 17:16:56 -0400 diff --git a/git-repair-test.hs b/git-repair-test.hs deleted file mode 100644 index 8256d31..0000000 --- a/git-repair-test.hs +++ /dev/null @@ -1,126 +0,0 @@ -{- 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 qualified Git.Fsck -import Utility.Tmp - -data Settings = Settings - { originalGitRepo :: FilePath - , forced :: Bool - , retryMode :: Bool - , stopOnFailure :: Bool - , numTests :: Int - } - -parseSettings :: Parser Settings -parseSettings = Settings - <$> argument str - (metavar "REPO") - <*> switch - ( long "force" - <> help "Force repair" - ) - <*> switch - ( long "retry" - <> help "Retry tests in git-repair-test.log" - ) - <*> switch - ( long "stop-on-failure" - <> help "Stop running tests on failure" - ) - <*> option - ( long "numtests" - <> short 'n' - <> metavar "N" - <> help "Run N tests" - <> value 1 - ) - -main :: IO () -main = execParser opts >>= run - where - opts = info (helper <*> parseSettings) desc - desc = fullDesc - <> header "git-repair-test - test git-repair" - -run :: Settings -> IO () -run settings - | retryMode settings = do - l <- map Prelude.read . lines <$> readFile logFile - go $ forM l $ \damage -> - runTest settings damage >>= showTestResult settings - | otherwise = - go $ forM [1 .. numTests settings] $ \n -> do - putStrLn $ "** Test " ++ show n ++ "/" ++ show (numTests settings) - runRandomTest settings - where - go a = exitBool . and =<< a - -runRandomTest :: Settings -> IO Bool -runRandomTest settings = do - damage <- Git.Destroyer.generateDamage - logDamage damage - result <- runTest settings damage - showTestResult settings result - -runTest :: Settings -> [Git.Destroyer.Damage] -> IO TestResult -runTest settings damage = withTmpDir "tmprepo" $ \tmpdir -> do - let cloneloc = tmpdir </> "clone" - cloned <- boolSystem "git" - [ Param "clone" - , Param "--no-hardlinks" - , File (originalGitRepo settings) - , File cloneloc - ] - unless cloned $ - error $ "failed to clone " ++ originalGitRepo settings - g <- Git.Config.read =<< Git.Construct.fromPath cloneloc - Git.Destroyer.applyDamage damage g - repairstatus <- catchMaybeIO $ Git.Repair.successfulRepair - <$> Git.Repair.runRepair (forced settings) g - case repairstatus of - Just True -> TestResult damage repairstatus - . Just . not . Git.Fsck.foundBroken - <$> Git.Fsck.findBroken False g - _ -> return $ TestResult damage repairstatus Nothing - -data TestResult = TestResult - { damageList :: [Git.Destroyer.Damage] - , repairResult :: Maybe Bool - , fsckResult :: Maybe Bool - } - deriving (Read, Show) - -showTestResult :: Settings -> TestResult -> IO Bool -showTestResult settings testresult = do - ok <- 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 False - when (stopOnFailure settings && not ok) $ - exitFailure - return ok - -logDamage :: [Git.Destroyer.Damage] -> IO () -logDamage damage = appendFile logFile $ show damage ++ "\n" - -logFile :: FilePath -logFile = "git-repair-test.log" diff --git a/git-repair.cabal b/git-repair.cabal index ff5e964..22edee1 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -22,24 +22,12 @@ Executable git-repair GHC-Options: -Wall -threaded Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl, network, extensible-exceptions, unix-compat, bytestring, - base >= 4.5, base < 5, IfElse, text, process, + base >= 4.5, base < 5, IfElse, text, process, time, QuickCheck, utf8-string, async, optparse-applicative if (! os(windows)) Build-Depends: unix -Executable git-repair-test - Main-Is: git-repair-test.hs - GHC-Options: -Wall -threaded - 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 ce1444f..797dec3 100644 --- a/git-repair.hs +++ b/git-repair.hs @@ -11,9 +11,16 @@ import Common import qualified Git.CurrentRepo import qualified Git.Repair import qualified Git.Config +import qualified Git.Construct +import qualified Git.Destroyer +import qualified Git.Fsck +import Utility.Tmp data Settings = Settings { forced :: Bool + , testMode :: Bool + , retryTestMode :: Bool + , numTests :: Int } parseSettings :: Parser Settings @@ -22,13 +29,32 @@ parseSettings = Settings ( long "force" <> help "Force repair, even if data is lost" ) + <*> switch + ( long "test" + <> help "Clone local repo, damage the clone, and test repair" + ) + <*> switch + ( long "retry" + <> help "Retry tests in git-repair-test.log" + ) + <*> option + ( long "numtests" + <> short 'n' + <> metavar "N" + <> help "Run N tests" + <> value 1 + ) main :: IO () -main = execParser opts >>= repair +main = execParser opts >>= go where opts = info (helper <*> parseSettings) desc desc = fullDesc <> header "git-repair - repair a damanged git repository" + go settings + | testModeĀ settings = test settings + | retryTestMode settings = retryTest settings + | otherwise = repair settings repair :: Settings -> IO () repair settings = do @@ -37,3 +63,72 @@ repair settings = do ( exitSuccess , exitFailure ) + +test :: Settings -> IO () +test settings = do + forM_ [1 .. numTests settings] $ \n -> do + putStrLn $ "** Test " ++ show n ++ "/" ++ show (numTests settings) + damage <- Git.Destroyer.generateDamage + logDamage damage + runTest settings damage >>= handleTestResult + allOk + +retryTest :: Settings -> IO () +retryTest settings = do + l <- map Prelude.read . lines <$> readFile logFile + forM_ l $ \damage -> + runTest settings damage >>= handleTestResult + allOk + +runTest :: Settings -> [Git.Destroyer.Damage] -> IO TestResult +runTest settings damage = withTmpDir "tmprepo" $ \tmpdir -> do + let cloneloc = tmpdir </> "clone" + cloned <- boolSystem "git" + [ Param "clone" + , Param "--no-hardlinks" + , File "." + , File cloneloc + ] + unless cloned $ + error $ "failed to clone this repo" + g <- Git.Config.read =<< Git.Construct.fromPath cloneloc + Git.Destroyer.applyDamage damage g + repairstatus <- catchMaybeIO $ Git.Repair.successfulRepair + <$> Git.Repair.runRepair (forced settings) g + case repairstatus of + Just True -> TestResult repairstatus + . Just . not . Git.Fsck.foundBroken + <$> Git.Fsck.findBroken False g + _ -> return $ TestResult repairstatus Nothing + +data TestResult = TestResult + { repairResult :: Maybe Bool + , fsckResult :: Maybe Bool + } + deriving (Read, Show) + +handleTestResult :: TestResult -> IO () +handleTestResult testresult = do + ok <- 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 False + unless ok $ + exitFailure + +allOk :: IO () +allOk = do + putStrLn "" + putStrLn "All tests ok!" + +logDamage :: [Git.Destroyer.Damage] -> IO () +logDamage damage = appendFile logFile $ show damage ++ "\n" + +logFile :: FilePath +logFile = "git-repair-test.log" |