From e011fd72ef69dbbaa4f63bfd61564e0918cb3e22 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 19 Nov 2013 16:09:44 -0400 Subject: initial work on git repository destroyer I suspect this might sometimes corrupt the **source** repo, so use with caution! --- .gitignore | 2 + Git/Destroyer.hs | 117 ++++++++++++++++++++++++++++++++++++++++++++++++++ Git/Repair.hs | 4 ++ Makefile | 8 ++-- Utility/FileMode.hs | 7 ++- Utility/QuickCheck.hs | 48 +++++++++++++++++++++ git-repair.cabal | 12 ++++++ git-repair.hs | 5 +-- test-runner.hs | 66 ++++++++++++++++++++++++++++ 9 files changed, 261 insertions(+), 8 deletions(-) create mode 100644 Git/Destroyer.hs create mode 100644 Utility/QuickCheck.hs create mode 100644 test-runner.hs diff --git a/.gitignore b/.gitignore index 55a966c..61a7f1e 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,5 @@ Build/SysConfig.hs tags git-repair +test-runner +test-runner.log diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs new file mode 100644 index 0000000..baffa05 --- /dev/null +++ b/Git/Destroyer.hs @@ -0,0 +1,117 @@ +{- git repository destroyer + - + - Use with caution! + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Destroyer ( + Damage(..), + generateDamage, + applyDamage +) where + +import Common +import Git +import Utility.QuickCheck +import Utility.FileMode + +import qualified Data.ByteString as B +import Data.Word +import System.PosixCompat.Types + +{- Ways to damange a git repository. -} +data Damage = Damage DamageAction FileSelector + deriving (Read, Show) + +instance Arbitrary Damage where + arbitrary = Damage <$> arbitrary <*> arbitrary + +data DamageAction + = Empty + | Delete + | Reverse + | AppendGarbage B.ByteString + | PrependGarbage B.ByteString + | CorruptByte Int Word8 + | ScrambleFileMode FileMode + deriving (Read, Show) + +instance Arbitrary DamageAction where + arbitrary = oneof + [ pure Empty + , pure Delete + , pure Reverse + , AppendGarbage <$> garbage + , PrependGarbage <$> garbage + , CorruptByte + <$> nonNegative arbitrarySizedIntegral + <*> arbitrary + , ScrambleFileMode <$> nonNegative arbitrarySizedIntegral + ] + where + garbage = B.pack <$> arbitrary `suchThat` (not . null) + +{- To select a given file in a git repository, all files in the repository + - are enumerated, sorted, and this is used as an index + - into the list. (Wrapping around if higher than the length.) -} +data FileSelector = FileSelector Int + deriving (Read, Show) + +instance Arbitrary FileSelector where + arbitrary = FileSelector <$> nonNegative arbitrarySizedIntegral + +selectFile :: [FilePath] -> FileSelector -> FilePath +selectFile sortedfs (FileSelector n) = sortedfs !! (n `mod` length sortedfs) + +{- Generates random Damage. -} +generateDamage :: IO [Damage] +generateDamage = sample' (arbitrary :: Gen Damage) + +{- Applies Damage to a Repo, in a reproducible fashion + - (as long as the Repo contains the same files each time). -} +applyDamage :: [Damage] -> Repo -> IO () +applyDamage l r = do + contents <- sort <$> dirContentsRecursive (localGitDir r) + forM_ l $ \(Damage action fileselector) -> do + let f = selectFile contents fileselector + -- Symlinks might be dangling, so are skipped. + -- If the file was already removed by a previous Damage, + -- it's skipped. + whenM (doesFileExist f) $ + withModifiedFileMode f (addModes [ownerWriteMode]) $ + applyDamageAction action f + `catchIO` \e -> error ("Failed to apply " ++ show action ++ " " ++ show f ++ ": " ++ show e) + +applyDamageAction :: DamageAction -> FilePath -> IO () +applyDamageAction Empty f = changeFile f $ do + nukeFile f + writeFile f "" +applyDamageAction Reverse f = changeFile f $ + B.writeFile f =<< B.reverse <$> B.readFile f +applyDamageAction Delete f = nukeFile f +applyDamageAction (AppendGarbage garbage) f = changeFile f $ + B.appendFile f garbage +applyDamageAction (PrependGarbage garbage) f = changeFile 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 = do + b <- B.readFile f + let len = B.length b + unless (len == 0) $ do + let n' = n `mod` len + let (prefix, rest) = B.splitAt n' b + B.writeFile f $ B.concat + [prefix + , B.singleton garbage + , B.drop 1 rest + ] +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]) diff --git a/Git/Repair.hs b/Git/Repair.hs index 270b041..41d0535 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -8,6 +8,7 @@ module Git.Repair ( runRepair, runRepairOf, + successfulRepair, cleanCorruptObjects, retrieveMissingObjects, resetLocalBranches, @@ -452,6 +453,9 @@ runRepair forced g = do putStrLn "No problems found." return (True, S.empty, []) +successfulRepair :: (Bool, MissingObjects, [Branch]) -> Bool +successfulRepair = fst3 + runRepairOf :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch]) runRepairOf fsckresult forced referencerepo g = do missing <- cleanCorruptObjects fsckresult g diff --git a/Makefile b/Makefile index 07df05d..90274ac 100644 --- a/Makefile +++ b/Makefile @@ -4,6 +4,7 @@ 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/test-runner/test-runner test-runner @$(MAKE) tags >/dev/null 2>&1 & Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs @@ -17,9 +18,10 @@ install: build install -m 0644 git-repair.1 $(DESTDIR)$(PREFIX)/share/man/man1 clean: - rm -rf git-repair dist configure Build/SysConfig.hs Setup tags - find -name \*.o -exec rm {} \; - find -name \*.hi -exec rm {} \; + rm -rf git-repair test-runner test-runner.log \ + dist configure Build/SysConfig.hs Setup tags + find . -name \*.o -exec rm {} \; + find . -name \*.hi -exec rm {} \; # Upload to hackage. hackage: clean diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index d76fb57..1307d38 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -65,12 +65,15 @@ allowWrite :: FilePath -> IO () allowWrite f = modifyFileMode f $ addModes [ownerWriteMode] {- Allows owner and group to read and write to a file. -} -groupWriteRead :: FilePath -> IO () -groupWriteRead f = modifyFileMode f $ addModes +groupSharedModes :: [FileMode] +groupSharedModes = [ ownerWriteMode, groupWriteMode , ownerReadMode, groupReadMode ] +groupWriteRead :: FilePath -> IO () +groupWriteRead f = modifyFileMode f $ addModes groupSharedModes + checkMode :: FileMode -> FileMode -> Bool checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs new file mode 100644 index 0000000..82af09f --- /dev/null +++ b/Utility/QuickCheck.hs @@ -0,0 +1,48 @@ +{- QuickCheck with additional instances + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Utility.QuickCheck + ( module X + , module Utility.QuickCheck + ) where + +import Test.QuickCheck as X +import Data.Time.Clock.POSIX +import System.Posix.Types +import qualified Data.Map as M +import Control.Applicative + +instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where + arbitrary = M.fromList <$> arbitrary + +{- Times before the epoch are excluded. -} +instance Arbitrary POSIXTime where + arbitrary = nonNegative arbitrarySizedIntegral + +instance Arbitrary EpochTime where + arbitrary = nonNegative arbitrarySizedIntegral + +{- Pids are never negative, or 0. -} +instance Arbitrary ProcessID where + arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0) + +{- Inodes are never negative. -} +instance Arbitrary FileID where + arbitrary = nonNegative arbitrarySizedIntegral + +{- File sizes are never negative. -} +instance Arbitrary FileOffset where + arbitrary = nonNegative arbitrarySizedIntegral + +nonNegative :: (Num a, Ord a) => Gen a -> Gen a +nonNegative g = g `suchThat` (>= 0) + +positive :: (Num a, Ord a) => Gen a -> Gen a +positive g = g `suchThat` (> 0) diff --git a/git-repair.cabal b/git-repair.cabal index 15acb79..a74b117 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -28,6 +28,18 @@ Executable git-repair if (! os(windows)) Build-Depends: unix +Executable test-runner + Main-Is: test-runner.hs + GHC-Options: -Wall + 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 9ece7e5..5a092d3 100644 --- a/git-repair.hs +++ b/git-repair.hs @@ -5,7 +5,6 @@ - Licensed under the GNU GPL version 3 or higher. -} -import Data.Tuple.Utils import Options.Applicative import Common @@ -22,7 +21,7 @@ parseSettings = Settings <$> switch forceopt where forceopt = long "force" - <> help "Force recovery, even if data is lost" + <> help "Force repair, even if data is lost" main :: IO () main = execParser opts >>= repair @@ -34,7 +33,7 @@ main = execParser opts >>= repair repair :: Settings -> IO () repair settings = do g <- Git.Config.read =<< Git.CurrentRepo.get - ifM (fst3 <$> Git.Repair.runRepair (forced settings) g) + ifM (Git.Repair.successfulRepair <$> Git.Repair.runRepair (forced settings) g) ( exitSuccess , exitFailure ) diff --git a/test-runner.hs b/test-runner.hs new file mode 100644 index 0000000..6687744 --- /dev/null +++ b/test-runner.hs @@ -0,0 +1,66 @@ +{- 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 Utility.Tmp + +data Settings = Settings + { originalGitRepo :: FilePath + , forced :: Bool + } + +parseSettings :: Parser Settings +parseSettings = Settings + <$> argument str (metavar "REPO") + <*> switch forceopt + where + forceopt = long "force" + <> help "Force repair" + +main :: IO () +main = execParser opts >>= runTest + 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 + let cloneloc = tmpdir "clone" + cloned <- boolSystem "git" + [ Param "clone" + , File (originalGitRepo settings) + , File cloneloc + ] + 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 + <$> Git.Repair.runRepair (forced settings) g + logTest damage result + case result of + Just True -> exitSuccess + _ -> exitFailure + +data TestLog = TestLog [Git.Destroyer.Damage] (Maybe Bool) + deriving (Read, Show) + +logTest :: [Git.Destroyer.Damage] -> Maybe Bool -> IO () +logTest damage result = + appendFile "test-runner.log" $ show (TestLog damage result) ++ "\n" -- cgit v1.2.3