summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess <joey@kitenet.net>2013-11-21 02:20:19 -0400
committerJoey Hess <joey@kitenet.net>2013-11-21 02:20:19 -0400
commite38c59dfde89f15c61b4073dcd19b53dfe440e74 (patch)
tree1f6d32f1b125f4c21232eb8c63748572f59c4c7a
parent897f030f68ff847c03494fbdd4104d1f8dfad9fe (diff)
downloadgit-repair-e38c59dfde89f15c61b4073dcd19b53dfe440e74.tar.gz
combine test program into git-repair
-rw-r--r--Makefile3
-rw-r--r--debian/changelog4
-rw-r--r--git-repair-test.hs126
-rw-r--r--git-repair.cabal14
-rw-r--r--git-repair.hs97
5 files changed, 100 insertions, 144 deletions
diff --git a/Makefile b/Makefile
index 756f686..ebbecdf 100644
--- a/Makefile
+++ b/Makefile
@@ -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"