diff --git a/Build/Configure.hs b/Build/Configure.hs --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -7,11 +7,13 @@ import Control.Monad.IfElse import Build.TestConfig +import Build.Version import Git.Version tests :: [TestCase] tests = - [ TestCase "git" $ requireCmd "git" "git --version >/dev/null" + [ TestCase "version" getVersion + , TestCase "git" $ requireCmd "git" "git --version >/dev/null" , TestCase "git version" getGitVersion , TestCase "nice" $ testCmd "nice" "nice true >/dev/null" ] @@ -25,3 +27,5 @@ args <- getArgs config <- runTests ts writeSysConfig config + whenM (isReleaseBuild) $ + cabalSetup "git-repair.cabal" diff --git a/Build/Version.hs b/Build/Version.hs new file mode 100644 --- /dev/null +++ b/Build/Version.hs @@ -0,0 +1,69 @@ +{- Package version determination, for configure script. -} + +module Build.Version where + +import Data.Maybe +import Control.Applicative +import Data.List +import System.Environment +import System.Directory +import Data.Char +import System.Process + +import Build.TestConfig +import Utility.Monad +import Utility.Exception + +{- Set when making an official release. (Distribution vendors should set + - this too.) -} +isReleaseBuild :: IO Bool +isReleaseBuild = isJust <$> catchMaybeIO (getEnv "RELEASE_BUILD") + +{- Version is usually based on the major version from the changelog, + - plus the date of the last commit, plus the git rev of that commit. + - This works for autobuilds, ad-hoc builds, etc. + - + - If git or a git repo is not available, or something goes wrong, + - or this is a release build, just use the version from the changelog. -} +getVersion :: Test +getVersion = do + changelogversion <- getChangelogVersion + version <- ifM (isReleaseBuild) + ( return changelogversion + , catchDefaultIO changelogversion $ do + let major = takeWhile (/= '.') changelogversion + autoversion <- readProcess "sh" + [ "-c" + , "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'" + ] "" + if null autoversion + then return changelogversion + else return $ concat [ major, ".", autoversion ] + ) + return $ Config "packageversion" (StringConfig version) + +getChangelogVersion :: IO String +getChangelogVersion = do + changelog <- readFile "debian/changelog" + let verline = takeWhile (/= '\n') changelog + return $ middle (words verline !! 1) + where + middle = drop 1 . init + +{- Set up cabal file with version. -} +cabalSetup :: FilePath -> IO () +cabalSetup cabalfile = do + version <- takeWhile (\c -> isDigit c || c == '.') + <$> getChangelogVersion + cabal <- readFile cabalfile + writeFile tmpcabalfile $ unlines $ + map (setfield "Version" version) $ + lines cabal + renameFile tmpcabalfile cabalfile + where + tmpcabalfile = cabalfile++".tmp" + setfield field value s + | fullfield `isPrefixOf` s = fullfield ++ value + | otherwise = s + where + fullfield = field ++ ": " diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs new file mode 100644 --- /dev/null +++ b/Git/Destroyer.hs @@ -0,0 +1,126 @@ +{- 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 arbitraryBoundedIntegral + <*> 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 <$> oneof + -- An early file in the git tree, tends to be the most + -- interesting when there are lots of files. + [ nonNegative arbitrarySizedIntegral + -- Totally random choice from any of the files in + -- the git tree, to ensure good coverage. + , nonNegative arbitraryBoundedIntegral + ] + +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 . filter (not . skipped . takeFileName) + <$> 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) $ + applyDamageAction action f + `catchIO` \e -> error ("Failed to apply " ++ show action ++ " " ++ show f ++ ": " ++ show e ++ "(total damage: " ++ show l ++ ")") + where + -- A broken .git/config is not recoverable. + skipped f = f `elem` [ "config" ] + +applyDamageAction :: DamageAction -> FilePath -> IO () +applyDamageAction Empty f = withSaneMode f $ do + nukeFile f + writeFile f "" +applyDamageAction Reverse f = withSaneMode f $ + B.writeFile f =<< B.reverse <$> B.readFile f +applyDamageAction Delete f = nukeFile f +applyDamageAction (AppendGarbage garbage) f = withSaneMode f $ + B.appendFile f garbage +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 = withSaneMode 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 + +withSaneMode :: FilePath -> IO () -> IO () +withSaneMode f = withModifiedFileMode f (addModes [ownerWriteMode, ownerReadMode]) diff --git a/Git/Fsck.hs b/Git/Fsck.hs --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -17,7 +17,6 @@ import Git import Git.Command import Git.Sha -import Git.CatFile import Utility.Batch import qualified Data.Set as S @@ -40,7 +39,7 @@ findBroken :: Bool -> Repo -> IO FsckResults findBroken batchmode r = do (output, fsckok) <- processTranscript command' (toCommand params') Nothing - let objs = parseFsckOutput output + let objs = findShas output badobjs <- findMissing objs r if S.null badobjs && not fsckok then return Nothing @@ -57,30 +56,23 @@ {- Finds objects that are missing from the git repsitory, or are corrupt. - - - Note that catting a corrupt object will cause cat-file to crash; - - this is detected and it's restarted. + - This does not use git cat-file --batch, because catting a corrupt + - object can cause it to crash, or to report incorrect size information.a -} findMissing :: [Sha] -> Repo -> IO MissingObjects -findMissing objs r = go objs [] =<< start +findMissing objs r = S.fromList <$> filterM (not <$$> present) objs where - start = catFileStart' False r - go [] c h = do - catFileStop h - return $ S.fromList c - go (o:os) c h = do - v <- tryIO $ isNothing <$> catObjectDetails h o - case v of - Left _ -> do - void $ tryIO $ catFileStop h - go os (o:c) =<< start - Right True -> go os (o:c) h - Right False -> go os c h + present o = either (const False) (const True) <$> tryIO (dump o) + dump o = runQuiet + [ Param "show" + , Param (show o) + ] r -parseFsckOutput :: String -> [Sha] -parseFsckOutput = catMaybes . map extractSha . concat . map words . lines +findShas :: String -> [Sha] +findShas = catMaybes . map extractSha . concat . map words . lines fsckParams :: Repo -> [CommandParam] -fsckParams = gitCommandLine +fsckParams = gitCommandLine $ [ Param "fsck" , Param "--no-dangling" , Param "--no-reflogs" diff --git a/Git/Objects.hs b/Git/Objects.hs --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -9,6 +9,7 @@ import Common import Git +import Git.Sha objectsDir :: Repo -> FilePath objectsDir r = localGitDir r "objects" @@ -16,12 +17,17 @@ packDir :: Repo -> FilePath packDir r = objectsDir r "pack" +packIdxFile :: FilePath -> FilePath +packIdxFile = flip replaceExtension "idx" + listPackFiles :: Repo -> IO [FilePath] listPackFiles r = filter (".pack" `isSuffixOf`) <$> catchDefaultIO [] (dirContents $ packDir r) -packIdxFile :: FilePath -> FilePath -packIdxFile = flip replaceExtension "idx" +listLooseObjectShas :: Repo -> IO [Sha] +listLooseObjectShas r = catchDefaultIO [] $ + mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories) + <$> dirContentsRecursiveSkipping (== "pack") (objectsDir r) looseObjectFile :: Repo -> Sha -> FilePath looseObjectFile r sha = objectsDir r prefix rest diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -8,13 +8,13 @@ module Git.Repair ( runRepair, runRepairOf, + successfulRepair, cleanCorruptObjects, retrieveMissingObjects, resetLocalBranches, removeTrackingBranches, checkIndex, missingIndex, - nukeIndex, emptyGoodCommits, ) where @@ -35,71 +35,39 @@ import qualified Git.Branch as Branch import Utility.Tmp import Utility.Rsync +import Utility.FileMode import qualified Data.Set as S import qualified Data.ByteString.Lazy as L import Data.Tuple.Utils -{- Given a set of bad objects found by git fsck, removes all - - corrupt objects, and returns a list of missing objects, - - which need to be found elsewhere to finish recovery. - - - - Since git fsck may crash on corrupt objects, and so not - - report the full set of corrupt or missing objects, - - this removes corrupt objects, and re-runs fsck, until it - - stabalizes. - - - - To remove corrupt objects, unpack all packs, and remove the packs - - (to handle corrupt packs), and remove loose object files. +{- Given a set of bad objects found by git fsck, which may not + - be complete, finds and removes all corrupt objects, and + - returns a list of missing objects, which need to be + - found elsewhere to finish recovery. -} -cleanCorruptObjects :: FsckResults -> Repo -> IO MissingObjects -cleanCorruptObjects mmissing r = check mmissing - where - check Nothing = do - putStrLn "git fsck found a problem but no specific broken objects. Perhaps a corrupt pack file?" - ifM (explodePacks r) - ( retry S.empty - , return S.empty - ) - check (Just bad) - | S.null bad = return S.empty - | otherwise = do - putStrLn $ unwords - [ "git fsck found" - , show (S.size bad) - , "broken objects." - ] - exploded <- explodePacks r - removed <- removeLoose r bad - if exploded || removed - then retry bad - else return bad - retry oldbad = do - putStrLn "Re-running git fsck to see if it finds more problems." - v <- findBroken False r - case v of - Nothing -> error $ unwords - [ "git fsck found a problem, which was not corrected after removing" - , show (S.size oldbad) - , "corrupt objects." - ] - Just newbad -> do - removed <- removeLoose r newbad - let s = S.union oldbad newbad - if not removed || s == oldbad - then return s - else retry s +cleanCorruptObjects :: FsckResults -> Repo -> IO (Maybe MissingObjects) +cleanCorruptObjects fsckresults r = do + void $ explodePacks r + objs <- listLooseObjectShas r + mapM_ (tryIO . allowRead . looseObjectFile r) objs + bad <- findMissing objs r + void $ removeLoose r $ S.union bad (fromMaybe S.empty fsckresults) + -- Rather than returning the loose objects that were removed, re-run + -- fsck. Other missing objects may have been in the packs, + -- and this way fsck will find them. + findBroken False r removeLoose :: Repo -> MissingObjects -> IO Bool removeLoose r s = do - let fs = map (looseObjectFile r) (S.toList s) - count <- length <$> filterM doesFileExist fs - if (count > 0) + fs <- filterM doesFileExist (map (looseObjectFile r) (S.toList s)) + let count = length fs + if count > 0 then do putStrLn $ unwords - [ "removing" + [ "Removing" , show count - , "corrupt loose objects" + , "corrupt loose objects." ] mapM_ nukeFile fs return True @@ -115,57 +83,62 @@ mapM_ go packs return True where - go packfile = do + go packfile = withTmpFileIn (localGitDir r) "pack" $ \tmp _ -> do + moveFile packfile tmp + nukeFile $ packIdxFile packfile + allowRead tmp -- May fail, if pack file is corrupt. void $ tryIO $ - pipeWrite [Param "unpack-objects"] r $ \h -> - L.hPut h =<< L.readFile packfile - nukeFile packfile - nukeFile $ packIdxFile packfile + pipeWrite [Param "unpack-objects", Param "-r"] r $ \h -> + L.hPut h =<< L.readFile tmp {- Try to retrieve a set of missing objects, from the remotes of a - repository. Returns any that could not be retreived. - - + - - If another clone of the repository exists locally, which might not be a - remote of the repo being repaired, its path can be passed as a reference - repository. + + - Can also be run with Nothing, if it's not known which objects are + - missing, just that some are. (Ie, fsck failed badly.) -} -retrieveMissingObjects :: MissingObjects -> Maybe FilePath -> Repo -> IO MissingObjects +retrieveMissingObjects :: Maybe MissingObjects -> Maybe FilePath -> Repo -> IO (Maybe MissingObjects) retrieveMissingObjects missing referencerepo r - | S.null missing = return missing + | missing == Just S.empty = return $ Just S.empty | otherwise = withTmpDir "tmprepo" $ \tmpdir -> do unlessM (boolSystem "git" [Params "init", File tmpdir]) $ error $ "failed to create temp repository in " ++ tmpdir tmpr <- Config.read =<< Construct.fromAbsPath tmpdir stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing - if S.null stillmissing - then return stillmissing + if stillmissing == Just S.empty + then return $ Just S.empty else pullremotes tmpr (remotes r) fetchallrefs stillmissing where pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of Nothing -> return stillmissing Just p -> ifM (fetchfrom p fetchrefs tmpr) ( do + void $ explodePacks tmpr void $ copyObjects tmpr r - findMissing (S.toList stillmissing) r + case stillmissing of + Nothing -> return $ Just S.empty + Just s -> Just <$> findMissing (S.toList s) r , return stillmissing ) - pullremotes tmpr (rmt:rmts) fetchrefs s - | S.null s = return s + pullremotes tmpr (rmt:rmts) fetchrefs ms + | ms == Just S.empty = return $ Just S.empty | otherwise = do - putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt + putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt ++ "." ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr) ( do + void $ explodePacks tmpr void $ copyObjects tmpr r - stillmissing <- findMissing (S.toList s) r - pullremotes tmpr rmts fetchrefs stillmissing - , do - putStrLn $ unwords - [ "failed to fetch from remote" - , repoDescribe rmt - , "(will continue without it, but making this remote available may improve recovery)" - ] - pullremotes tmpr rmts fetchrefs s + case ms of + Nothing -> pullremotes tmpr rmts fetchrefs ms + Just s -> do + stillmissing <- findMissing (S.toList s) r + pullremotes tmpr rmts fetchrefs (Just stillmissing) + , pullremotes tmpr rmts fetchrefs ms ) fetchfrom fetchurl ps = runBool $ [ Param "fetch" @@ -179,7 +152,7 @@ fetchallrefs = [ Param "+*:*" ] {- Copies all objects from the src repository to the dest repository. - - This is done using rsync, so it copies all missing object, and all + - This is done using rsync, so it copies all missing objects, and all - objects they rely on. -} copyObjects :: Repo -> Repo -> IO Bool copyObjects srcr destr = rsync @@ -238,51 +211,44 @@ {- Gets all refs, including ones that are corrupt. - git show-ref does not output refs to commits that are directly - corrupted, so it is not used. + - + - Relies on packed refs being exploded before it's called. -} getAllRefs :: Repo -> IO [Ref] -getAllRefs r = do - packedrs <- mapMaybe parsePacked . lines - <$> catchDefaultIO "" (readFile $ packedRefsFile r) - loosers <- map toref <$> dirContentsRecursive refdir - return $ packedrs ++ loosers +getAllRefs r = map toref <$> dirContentsRecursive refdir where refdir = localGitDir r "refs" toref = Ref . relPathDirToFile (localGitDir r) +explodePackedRefsFile :: Repo -> IO () +explodePackedRefsFile r = do + let f = packedRefsFile r + whenM (doesFileExist f) $ do + rs <- mapMaybe parsePacked . lines + <$> catchDefaultIO "" (safeReadFile f) + forM_ rs makeref + nukeFile f + where + makeref (sha, ref) = do + let dest = localGitDir r ++ show ref + createDirectoryIfMissing True (parentDir dest) + unlessM (doesFileExist dest) $ + writeFile dest (show sha) + packedRefsFile :: Repo -> FilePath packedRefsFile r = localGitDir r "packed-refs" -parsePacked :: String -> Maybe Ref +parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of (sha:ref:[]) - | isJust (extractSha sha) -> Just $ Ref ref + | isJust (extractSha sha) && Ref.legal True ref -> + Just (Ref sha, Ref ref) _ -> Nothing {- git-branch -d cannot be used to remove a branch that is directly - - pointing to a corrupt commit. However, it's tried first. -} + - pointing to a corrupt commit. -} nukeBranchRef :: Branch -> Repo -> IO () -nukeBranchRef b r = void $ usegit <||> byhand - where - usegit = runBool - [ Param "branch" - , Params "-r -d" - , Param $ show $ Ref.base b - ] r - byhand = do - nukeFile $ localGitDir r show b - whenM (doesFileExist packedrefs) $ - withTmpFile "packed-refs" $ \tmp h -> do - ls <- lines <$> readFile packedrefs - hPutStr h $ unlines $ - filter (not . skiprefline) ls - hClose h - renameFile tmp packedrefs - return True - skiprefline l = case parsePacked l of - Just packedref - | packedref == b -> True - _ -> False - packedrefs = packedRefsFile r +nukeBranchRef b r = nukeFile $ localGitDir r show b {- Finds the most recent commit to a branch that does not need any - of the missing objects. If the input branch is good as-is, returns it. @@ -402,7 +368,7 @@ | otherwise = do (bad, good, cleanup) <- partitionIndex missing r unless (null bad) $ do - nukeIndex r + nukeFile (indexFile r) UpdateIndex.streamUpdateIndex r =<< (catMaybes <$> mapM reinject good) void cleanup @@ -414,8 +380,8 @@ UpdateIndex.stageFile sha blobtype file r reinject _ = return Nothing -nukeIndex :: Repo -> IO () -nukeIndex r = nukeFile (localGitDir r "index") +indexFile :: Repo -> FilePath +indexFile r = localGitDir r "index" newtype GoodCommits = GoodCommits (S.Set Sha) @@ -441,48 +407,91 @@ | numitems > 10 = take 10 items ++ ["(and " ++ show (numitems - 10) ++ " more)"] | otherwise = items +{- Fix problems that would prevent repair from working at all + - + - A missing or corrupt .git/HEAD makes git not treat the repository as a + - git repo. If there is a git repo in a parent directory, it may move up + - the tree and use that one instead. So, cannot use `git show-ref HEAD` to + - test it. + - + - Explode the packed refs file, to simplify dealing with refs, and because + - fsck can complain about bad refs in it. + -} +preRepair :: Repo -> IO () +preRepair g = do + unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do + nukeFile headfile + writeFile headfile "ref: refs/heads/master" + explodePackedRefsFile g + unless (repoIsLocalBare g) $ do + let f = indexFile g + void $ tryIO $ allowWrite f + where + headfile = localGitDir g "HEAD" + validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s) + {- Put it all together. -} runRepair :: Bool -> Repo -> IO (Bool, MissingObjects, [Branch]) runRepair forced g = do + preRepair g putStrLn "Running git fsck ..." fsckresult <- findBroken False g if foundBroken fsckresult - then runRepairOf fsckresult forced Nothing g + then runRepair' fsckresult forced Nothing g else do putStrLn "No problems found." return (True, S.empty, []) runRepairOf :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch]) runRepairOf fsckresult forced referencerepo g = do + preRepair g + runRepair' fsckresult forced referencerepo g + +runRepair' :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch]) +runRepair' fsckresult forced referencerepo g = do missing <- cleanCorruptObjects fsckresult g stillmissing <- retrieveMissingObjects missing referencerepo g - if S.null stillmissing - then if repoIsLocalBare g - then successfulfinish stillmissing [] - else ifM (checkIndex stillmissing g) - ( successfulfinish stillmissing [] - , do - putStrLn "No missing objects found, but the index file is corrupt!" - if forced - then corruptedindex - else needforce stillmissing - ) - else do - putStrLn $ unwords - [ show (S.size stillmissing) - , "missing objects could not be recovered!" - ] - if forced - then continuerepairs stillmissing - else unsuccessfulfinish stillmissing + case stillmissing of + Just s + | S.null s -> if repoIsLocalBare g + then successfulfinish S.empty [] + else ifM (checkIndex S.empty g) + ( successfulfinish s [] + , do + putStrLn "No missing objects found, but the index file is corrupt!" + if forced + then corruptedindex + else needforce S.empty + ) + | otherwise -> if forced + then ifM (checkIndex s g) + ( continuerepairs s + , corruptedindex + ) + else do + putStrLn $ unwords + [ show (S.size s) + , "missing objects could not be recovered!" + ] + unsuccessfulfinish s + Nothing + | forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex S.empty g) + ( do + missing' <- cleanCorruptObjects Nothing g + case missing' of + Nothing -> return (False, S.empty, []) + Just stillmissing' -> continuerepairs stillmissing' + , corruptedindex + ) + | otherwise -> unsuccessfulfinish S.empty where continuerepairs stillmissing = do (remotebranches, goodcommits) <- removeTrackingBranches stillmissing emptyGoodCommits g unless (null remotebranches) $ putStrLn $ unwords - [ "removed" + [ "Removed" , show (length remotebranches) - , "remote tracking branches that referred to missing objects" + , "remote tracking branches that referred to missing objects." ] (resetbranches, deletedbranches, _) <- resetLocalBranches stillmissing goodcommits g displayList (map show resetbranches) @@ -511,15 +520,18 @@ return (True, stillmissing, modifiedbranches) corruptedindex = do - nukeIndex g + nukeFile (indexFile g) + -- The corrupted index can prevent fsck from finding other + -- problems, so re-run repair. + fsckresult' <- findBroken False g + result <- runRepairOf fsckresult' forced referencerepo g putStrLn "Removed the corrupted index file. You should look at what files are present in your working tree and git add them back to the index when appropriate." - return (True, S.empty, []) + return result successfulfinish stillmissing modifiedbranches = do mapM_ putStrLn [ "Successfully recovered repository!" - , "You should run \"git fsck\" to make sure, but it looks like" - , "everything was recovered ok." + , "You should run \"git fsck\" to make sure, but it looks like everything was recovered ok." ] return (True, stillmissing, modifiedbranches) unsuccessfulfinish stillmissing = do @@ -532,3 +544,11 @@ needforce stillmissing = do putStrLn "To force a recovery to a usable state, retry with the --force parameter." return (False, stillmissing, []) + +successfulRepair :: (Bool, MissingObjects, [Branch]) -> Bool +successfulRepair = fst3 + +safeReadFile :: FilePath -> IO String +safeReadFile f = do + allowRead f + readFileStrictAnyEncoding f diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -17,9 +17,10 @@ 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 git-repair-test.log \ + dist configure Build/SysConfig.hs Setup tags + find . -name \*.o -exec rm {} \; + find . -name \*.hi -exec rm {} \; # Upload to hackage. hackage: clean @@ -29,3 +30,5 @@ # hothasktags chokes on some template haskell etc, so ignore errors tags: find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags > tags 2>/dev/null + +.PHONY: tags diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -64,12 +64,19 @@ allowWrite :: FilePath -> IO () allowWrite f = modifyFileMode f $ addModes [ownerWriteMode] +{- Turns a file's owner read bit back on. -} +allowRead :: FilePath -> IO () +allowRead f = modifyFileMode f $ addModes [ownerReadMode] + {- 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/Misc.hs b/Utility/Misc.hs --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -15,11 +15,15 @@ import Data.Char import Data.List import Control.Applicative +import System.Exit #ifndef mingw32_HOST_OS import System.Posix.Process (getAnyProcessStatus) import Utility.Exception #endif +import Utility.FileSystemEncoding +import Utility.Monad + {- A version of hgetContents that is not lazy. Ensures file is - all read before it gets closed. -} hGetContentsStrict :: Handle -> IO String @@ -29,6 +33,13 @@ readFileStrict :: FilePath -> IO String readFileStrict = readFile >=> \s -> length s `seq` return s +{- Reads a file strictly, and using the FileSystemEncofing, so it will + - never crash on a badly encoded file. -} +readFileStrictAnyEncoding :: FilePath -> IO String +readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do + fileEncoding h + hClose h `after` hGetContentsStrict h + {- Like break, but the item matching the condition is not included - in the second result list. - @@ -136,3 +147,7 @@ #else reapZombies = return () #endif + +exitBool :: Bool -> IO a +exitBool False = exitFailure +exitBool True = exitSuccess diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs new file mode 100644 --- /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/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs new file mode 100644 --- /dev/null +++ b/Utility/ThreadScheduler.hs @@ -0,0 +1,69 @@ +{- thread scheduling + - + - Copyright 2012, 2013 Joey Hess + - Copyright 2011 Bas van Dijk & Roel van Dijk + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Utility.ThreadScheduler where + +import Common + +import Control.Concurrent +#ifndef mingw32_HOST_OS +import System.Posix.Signals +#ifndef __ANDROID__ +import System.Posix.Terminal +#endif +#endif + +newtype Seconds = Seconds { fromSeconds :: Int } + deriving (Eq, Ord, Show) + +type Microseconds = Integer + +{- Runs an action repeatedly forever, sleeping at least the specified number + - of seconds in between. -} +runEvery :: Seconds -> IO a -> IO a +runEvery n a = forever $ do + threadDelaySeconds n + a + +threadDelaySeconds :: Seconds -> IO () +threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond) + +{- Like threadDelay, but not bounded by an Int. + - + - There is no guarantee that the thread will be rescheduled promptly when the + - delay has expired, but the thread will never continue to run earlier than + - specified. + - + - Taken from the unbounded-delay package to avoid a dependency for 4 lines + - of code. + -} +unboundDelay :: Microseconds -> IO () +unboundDelay time = do + let maxWait = min time $ toInteger (maxBound :: Int) + threadDelay $ fromInteger maxWait + when (maxWait /= time) $ unboundDelay (time - maxWait) + +{- Pauses the main thread, letting children run until program termination. -} +waitForTermination :: IO () +waitForTermination = do + lock <- newEmptyMVar +#ifndef mingw32_HOST_OS + let check sig = void $ + installHandler sig (CatchOnce $ putMVar lock ()) Nothing + check softwareTermination +#ifndef __ANDROID__ + whenM (queryTerminal stdInput) $ + check keyboardSignal +#endif +#endif + takeMVar lock + +oneSecond :: Microseconds +oneSecond = 1000000 diff --git a/debian/changelog b/debian/changelog new file mode 100644 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,22 @@ +git-repair (1.20131122) unstable; urgency=low + + * 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, + and this hides other problems. + * Write a dummy .git/HEAD if the file is missing or corrupt, as + git otherwise will not treat the repository as a git repo. + * 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 10000 tests (git-repair --test -n 10000 --force) + with 0 failures. + + -- Joey Hess Fri, 22 Nov 2013 11:16:03 -0400 + +git-repair (1.20131118) unstable; urgency=low + + * First release + + -- Joey Hess Mon, 18 Nov 2013 13:38:12 -0400 diff --git a/debian/compat b/debian/compat new file mode 100644 --- /dev/null +++ b/debian/compat @@ -0,0 +1,1 @@ +9 diff --git a/debian/control b/debian/control new file mode 100644 --- /dev/null +++ b/debian/control @@ -0,0 +1,29 @@ +Source: git-repair +Section: utils +Priority: optional +Build-Depends: + debhelper (>= 9), + ghc, + git, + libghc-missingh-dev, + libghc-hslogger-dev, + libghc-network-dev, + libghc-ifelse-dev, + libghc-extensible-exceptions-dev, + libghc-unix-compat-dev, + libghc-utf8-string-dev, + libghc-async-dev, + libghc-optparse-applicative-dev +Maintainer: Joey Hess +Standards-Version: 3.9.4 +Vcs-Git: git://git-repair.branchable.com/ +Homepage: http://git-repair.branchable.com/ + +Package: git-repair +Architecture: any +Section: utils +Depends: ${misc:Depends}, ${shlibs:Depends}, git, rsync +Description: repair various forms of damage to git repositorie + git-repair can repair various forms of damage to git repositories. + . + It is a complement to git fsck, which finds problems, but does not fix them. diff --git a/debian/copyright b/debian/copyright new file mode 100644 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,9 @@ +Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Source: native package + +Files: * +Copyright: © 2013 Joey Hess +License: GPL-3+ + The full text of version 3 of the GPL is distributed as doc/GPL in + this package's source, or in /usr/share/common-licenses/GPL-3 on + Debian systems. diff --git a/debian/manpages b/debian/manpages new file mode 100644 --- /dev/null +++ b/debian/manpages @@ -0,0 +1,1 @@ +git-repair.1 diff --git a/debian/rules b/debian/rules new file mode 100644 --- /dev/null +++ b/debian/rules @@ -0,0 +1,10 @@ +#!/usr/bin/make -f + +# Avoid using cabal, as it writes to $HOME +export CABAL=./Setup + +# Do use the changelog's version number, rather than making one up. +export RELEASE_BUILD=1 + +%: + dh $@ diff --git a/doc/index.mdwn b/doc/index.mdwn --- a/doc/index.mdwn +++ b/doc/index.mdwn @@ -5,7 +5,8 @@ ## download - git clone git://git-repair.branchable.com/ git-repair +* `git clone git://git-repair.branchable.com/ git-repair` +* from [Hackage](http://hackage.haskell.org/package/git-repair) ## install diff --git a/git-repair.cabal b/git-repair.cabal --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,5 +1,5 @@ Name: git-repair -Version: 1.20131118 +Version: 1.20131122 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess @@ -8,19 +8,22 @@ Copyright: 2013 Joey Hess License-File: GPL Build-Type: Custom -Homepage: http://git-reair.branchable.com/ +Homepage: http://git-repair.branchable.com/ Category: Utility Synopsis: repairs a damanged git repisitory Description: git-repair can repair various forms of damage to git repositories. + . + It is a complement to git fsck, which finds problems, but does not fix + them. Executable git-repair Main-Is: git-repair.hs - GHC-Options: -Wall + GHC-Options: -Wall -threaded Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl, network, extensible-exceptions, unix-compat, bytestring, - base >= 4.5, base < 5, IfElse, pretty-show, text, process, - utf8-string, async + base >= 4.5, base < 5, IfElse, text, process, time, QuickCheck, + utf8-string, async, optparse-applicative, SHA if (! os(windows)) Build-Depends: unix diff --git a/git-repair.hs b/git-repair.hs --- a/git-repair.hs +++ b/git-repair.hs @@ -5,34 +5,115 @@ - Licensed under the GNU GPL version 3 or higher. -} -import System.Environment -import Data.Tuple.Utils +import Options.Applicative 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 -header :: String -header = "Usage: git-repair" +data Settings = Settings + { forced :: Bool + , testMode :: Bool + , retryTestMode :: Bool + , numTests :: Int + } -usage :: a -usage = error $ "bad parameters\n\n" ++ header +parseSettings :: Parser Settings +parseSettings = Settings + <$> switch + ( 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 + ) -parseArgs :: IO Bool -parseArgs = do - args <- getArgs - return $ or $ map parse args +main :: IO () +main = execParser opts >>= go where - parse "--force" = True - parse _ = usage + 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 -main :: IO () -main = do - forced <- parseArgs - +repair :: Settings -> IO () +repair settings = do g <- Git.Config.read =<< Git.CurrentRepo.get - ifM (fst3 <$> Git.Repair.runRepair forced g) + ifM (Git.Repair.successfulRepair <$> Git.Repair.runRepair (forced settings) g) ( 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 + allOk + +retryTest :: Settings -> IO () +retryTest settings = do + l <- map Prelude.read . lines <$> readFile logFile + forM_ l $ \damage -> + runTest settings damage + allOk + +runTest :: Settings -> [Git.Destroyer.Damage] -> IO () +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 + _ -> testResult repairstatus Nothing + +-- Pass test result and fsck result +testResult :: (Maybe Bool) -> (Maybe Bool) -> IO () +testResult (Just True) (Just True) = putStrLn "** repair succeeded" +testResult (Just True) (Just False) = error "** repair succeeded, but final fsck failed" +testResult _ _ = error "** repair failed" + +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"