summaryrefslogtreecommitdiff
path: root/git-repair-test.hs
diff options
context:
space:
mode:
Diffstat (limited to 'git-repair-test.hs')
-rw-r--r--git-repair-test.hs126
1 files changed, 126 insertions, 0 deletions
diff --git a/git-repair-test.hs b/git-repair-test.hs
new file mode 100644
index 0000000..8256d31
--- /dev/null
+++ b/git-repair-test.hs
@@ -0,0 +1,126 @@
+{- 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"