git-repair 1.20140227 → 1.20140914
raw patch · 42 files changed
+601/−214 lines, 42 filesdep ~optparse-applicative
Dependency ranges changed: optparse-applicative
Files
- Build/make-sdist.sh +1/−1
- CHANGELOG +74/−0
- Git/Branch.hs +53/−11
- Git/CatFile.hs +6/−1
- Git/Command.hs +0/−12
- Git/Config.hs +0/−1
- Git/CurrentRepo.hs +4/−4
- Git/Fsck.hs +30/−7
- Git/Index.hs +4/−0
- Git/LsFiles.hs +2/−2
- Git/Repair.hs +106/−71
- Git/Types.hs +3/−2
- Git/UpdateIndex.hs +8/−1
- Makefile +1/−1
- Utility/Applicative.hs +1/−1
- Utility/Batch.hs +1/−2
- Utility/CoProcess.hs +4/−4
- Utility/Data.hs +1/−1
- Utility/Directory.hs +99/−4
- Utility/Env.hs +1/−1
- Utility/Exception.hs +2/−2
- Utility/FileMode.hs +30/−12
- Utility/FileSystemEncoding.hs +42/−3
- Utility/Format.hs +1/−1
- Utility/Metered.hs +1/−1
- Utility/Misc.hs +1/−13
- Utility/Monad.hs +1/−1
- Utility/Path.hs +1/−2
- Utility/PosixFiles.hs +1/−1
- Utility/Process.hs +18/−25
- Utility/QuickCheck.hs +3/−3
- Utility/Rsync.hs +5/−2
- Utility/SafeCommand.hs +1/−2
- Utility/ThreadScheduler.hs +7/−5
- Utility/Tmp.hs +15/−8
- Utility/URI.hs +18/−0
- Utility/UserInfo.hs +1/−1
- debian/changelog +22/−0
- debian/control +1/−1
- debian/copyright +26/−0
- git-repair.cabal +4/−3
- git-repair.hs +1/−1
Build/make-sdist.sh view
@@ -13,7 +13,7 @@ | xargs cp --parents --target-directory dist/$sdist_dir cd dist-tar -caf $sdist_dir.tar.gz $sdist_dir+tar --format=ustar -caf $sdist_dir.tar.gz $sdist_dir # Check that tarball can be unpacked by cabal. # It's picky about tar longlinks etc.
+ CHANGELOG view
@@ -0,0 +1,74 @@+git-repair (1.20140914) unstable; urgency=medium++ * Update to build with optparse-applicative 0.10. Closes: #761552++ -- Joey Hess <joeyh@debian.org> Sun, 14 Sep 2014 12:48:27 -0400++git-repair (1.20140815) unstable; urgency=medium++ * Removing bad objects could leave fsck finding no more unreachable objects,+ but some branches no longer accessible. Fix this, including support for+ fixing up repositories that were incompletely repaired before.+ * Merge from git-annex.++ -- Joey Hess <joeyh@debian.org> Fri, 15 Aug 2014 13:49:09 -0400++git-repair (1.20140423) unstable; urgency=medium++ * Improve memory usage when git fsck finds a great many broken objects.+ * Merge from git-annex.++ -- Joey Hess <joeyh@debian.org> Wed, 23 Apr 2014 14:01:30 -0400++git-repair (1.20140227) unstable; urgency=medium++ * Optimise unpacking of pack files, and avoid repeated error+ messages about corrupt pack files.+ * Add swapping 2 files test case.++ -- Joey Hess <joeyh@debian.org> Thu, 27 Feb 2014 11:56:27 -0400++git-repair (1.20140115) unstable; urgency=medium++ * Support old git versions from before git fsck --no-dangling was+ implemented.+ * Fix bug in packed refs file exploding code that caused a .gitrefs+ directory to be created instead of .git/refs+ * Check git version at run time.++ -- Joey Hess <joeyh@debian.org> Wed, 15 Jan 2014 16:53:30 -0400++git-repair (1.20131213) unstable; urgency=low++ * Improve repair of index files in some situations.++ -- Joey Hess <joeyh@debian.org> Fri, 13 Dec 2013 14:51:51 -0400++git-repair (1.20131203) unstable; urgency=low++ * Fix build deps. Closes: #731179++ -- Joey Hess <joeyh@debian.org> Tue, 03 Dec 2013 15:02:21 -0400++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 <joeyh@debian.org> Fri, 22 Nov 2013 11:16:03 -0400++git-repair (1.20131118) unstable; urgency=low++ * First release++ -- Joey Hess <joeyh@debian.org> Mon, 18 Nov 2013 13:38:12 -0400
Git/Branch.hs view
@@ -14,6 +14,7 @@ import Git.Sha import Git.Command import qualified Git.Ref+import qualified Git.BuildVersion {- The currently checked out branch. -@@ -52,9 +53,24 @@ diffs = pipeReadStrict [ Param "log" , Param (fromRef origbranch ++ ".." ++ fromRef newbranch)- , Params "--oneline -n1"+ , Param "-n1"+ , Param "--pretty=%H" ] repo +{- Check if it's possible to fast-forward from the old+ - ref to the new ref.+ -+ - This requires there to be a path from the old to the new. -}+fastForwardable :: Ref -> Ref -> Repo -> IO Bool+fastForwardable old new repo = not . null <$>+ pipeReadStrict+ [ Param "log"+ , Param $ fromRef old ++ ".." ++ fromRef new+ , Param "-n1"+ , Param "--pretty=%H"+ , Param "--ancestry-path"+ ] repo+ {- Given a set of refs that are all known to have commits not - on the branch, tries to update the branch by a fast-forward. -@@ -74,7 +90,7 @@ where no_ff = return False do_ff to = do- run [Param "update-ref", Param $ fromRef branch, Param $ fromRef to] repo+ update branch to repo return True findbest c [] = return $ Just c findbest c (r:rs)@@ -88,6 +104,31 @@ (False, True) -> findbest c rs -- worse (False, False) -> findbest c rs -- same +{- The user may have set commit.gpgsign, indending all their manual+ - commits to be signed. But signing automatic/background commits could+ - easily lead to unwanted gpg prompts or failures.+ -}+data CommitMode = ManualCommit | AutomaticCommit+ deriving (Eq)++applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam]+applyCommitMode commitmode ps+ | commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") =+ Param "--no-gpg-sign" : ps+ | otherwise = ps++{- Commit via the usual git command. -}+commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool+commitCommand = commitCommand' runBool++{- Commit will fail when the tree is clean. This suppresses that error. -}+commitQuiet :: CommitMode -> [CommandParam] -> Repo -> IO ()+commitQuiet commitmode ps = void . tryIO . commitCommand' runQuiet commitmode ps++commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a+commitCommand' runner commitmode ps = runner $+ Param "commit" : applyCommitMode commitmode ps+ {- Commits the index into the specified branch (or other ref), - with the specified parent refs, and returns the committed sha. -@@ -97,30 +138,31 @@ - Unlike git-commit, does not run any hooks, or examine the work tree - in any way. -}-commit :: Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)-commit allowempty message branch parentrefs repo = do+commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)+commit commitmode allowempty message branch parentrefs repo = do tree <- getSha "write-tree" $ pipeReadStrict [Param "write-tree"] repo ifM (cancommit tree) ( do- sha <- getSha "commit-tree" $ pipeWriteRead- (map Param $ ["commit-tree", fromRef tree] ++ ps)- (Just $ flip hPutStr message) repo+ sha <- getSha "commit-tree" $+ pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo update branch sha repo return $ Just sha , return Nothing ) where- ps = concatMap (\r -> ["-p", fromRef r]) parentrefs+ ps = applyCommitMode commitmode $+ map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs cancommit tree | allowempty = return True | otherwise = case parentrefs of [p] -> maybe False (tree /=) <$> Git.Ref.tree p repo _ -> return True+ sendmsg = Just $ flip hPutStr message -commitAlways :: String -> Branch -> [Ref] -> Repo -> IO Sha-commitAlways message branch parentrefs repo = fromJust- <$> commit True message branch parentrefs repo+commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha+commitAlways commitmode message branch parentrefs repo = fromJust+ <$> commit commitmode True message branch parentrefs repo {- A leading + makes git-push force pushing a branch. -} forcePush :: String -> String
Git/CatFile.hs view
@@ -11,6 +11,7 @@ catFileStart', catFileStop, catFile,+ catFileDetails, catTree, catObject, catObjectDetails,@@ -52,6 +53,10 @@ catFile h branch file = catObject h $ Ref $ fromRef branch ++ ":" ++ toInternalGitPath file +catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))+catFileDetails h branch file = catObjectDetails h $ Ref $+ fromRef branch ++ ":" ++ toInternalGitPath file+ {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} catObject :: CatFileHandle -> Ref -> IO L.ByteString@@ -103,6 +108,6 @@ dropsha = L.drop 21 parsemodefile b = - let (modestr, file) = separate (== ' ') (encodeW8 $ L.unpack b)+ let (modestr, file) = separate (== ' ') (decodeBS b) in (file, readmode modestr) readmode = fst . fromMaybe (0, undefined) . headMaybe . readOct
Git/Command.hs view
@@ -9,16 +9,10 @@ module Git.Command where -import System.Process (std_out, env)- import Common import Git import Git.Types import qualified Utility.CoProcess as CoProcess-#ifdef mingw32_HOST_OS-import Git.FilePath-#endif-import Utility.Batch {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]@@ -35,12 +29,6 @@ runBool :: [CommandParam] -> Repo -> IO Bool runBool params repo = assertLocal repo $ boolSystemEnv "git" (gitCommandLine params repo) (gitEnv repo)--{- Runs git in batch mode. -}-runBatch :: BatchCommandMaker -> [CommandParam] -> Repo -> IO Bool-runBatch batchmaker params repo = assertLocal repo $ do- let (cmd, params') = batchmaker ("git", gitCommandLine params repo)- boolSystemEnv cmd params' (gitEnv repo) {- Runs git in the specified repo, throwing an error if it fails. -} run :: [CommandParam] -> Repo -> IO ()
Git/Config.hs view
@@ -9,7 +9,6 @@ import qualified Data.Map as M import Data.Char-import System.Process (cwd, env) import Control.Exception.Extensible import Common
Git/CurrentRepo.hs view
@@ -37,8 +37,8 @@ case wt of Nothing -> return r Just d -> do- cwd <- getCurrentDirectory- unless (d `dirContains` cwd) $+ curr <- getCurrentDirectory+ unless (d `dirContains` curr) $ setCurrentDirectory d return $ addworktree wt r where@@ -57,8 +57,8 @@ configure Nothing (Just r) = Git.Config.read r configure (Just d) _ = do absd <- absPath d- cwd <- getCurrentDirectory- r <- newFrom $ Local { gitdir = absd, worktree = Just cwd }+ curr <- getCurrentDirectory+ r <- newFrom $ Local { gitdir = absd, worktree = Just curr } Git.Config.read r configure Nothing Nothing = error "Not in a git repository."
Git/Fsck.hs view
@@ -23,10 +23,16 @@ import qualified Git.Version import qualified Data.Set as S+import Control.Concurrent.Async type MissingObjects = S.Set Sha -data FsckResults = FsckFoundMissing MissingObjects | FsckFailed+data FsckResults + = FsckFoundMissing+ { missingObjects :: MissingObjects+ , missingObjectsTruncated :: Bool+ }+ | FsckFailed deriving (Show) {- Runs fsck to find some of the broken objects in the repository.@@ -46,20 +52,32 @@ (command', params') <- if batchmode then toBatchCommand (command, params) else return (command, params)- (output, fsckok) <- processTranscript command' (toCommand params') Nothing- let objs = findShas supportsNoDangling output- badobjs <- findMissing objs r+ + p@(_, _, _, pid) <- createProcess $+ (proc command' (toCommand params'))+ { std_out = CreatePipe+ , std_err = CreatePipe+ }+ (bad1, bad2) <- concurrently+ (readMissingObjs maxobjs r supportsNoDangling (stdoutHandle p))+ (readMissingObjs maxobjs r supportsNoDangling (stderrHandle p))+ fsckok <- checkSuccessProcess pid+ let truncated = S.size bad1 == maxobjs || S.size bad1 == maxobjs+ let badobjs = S.union bad1 bad2+ if S.null badobjs && not fsckok then return FsckFailed- else return $ FsckFoundMissing badobjs+ else return $ FsckFoundMissing badobjs truncated+ where+ maxobjs = 10000 foundBroken :: FsckResults -> Bool foundBroken FsckFailed = True-foundBroken (FsckFoundMissing s) = not (S.null s)+foundBroken (FsckFoundMissing s _) = not (S.null s) knownMissing :: FsckResults -> MissingObjects knownMissing FsckFailed = S.empty-knownMissing (FsckFoundMissing s) = s+knownMissing (FsckFoundMissing s _) = s {- Finds objects that are missing from the git repsitory, or are corrupt. -@@ -68,6 +86,11 @@ -} findMissing :: [Sha] -> Repo -> IO MissingObjects findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs++readMissingObjs :: Int -> Repo -> Bool -> Handle -> IO MissingObjects+readMissingObjs maxobjs r supportsNoDangling h = do+ objs <- take maxobjs . findShas supportsNoDangling <$> hGetContents h+ findMissing objs r isMissing :: Sha -> Repo -> IO Bool isMissing s r = either (const True) (const False) <$> tryIO dump
Git/Index.hs view
@@ -30,3 +30,7 @@ indexFile :: Repo -> FilePath indexFile r = localGitDir r </> "index"++{- Git locks the index by creating this file. -}+indexFileLock :: Repo -> FilePath+indexFileLock r = indexFile r ++ ".lock"
Git/LsFiles.hs view
@@ -132,8 +132,8 @@ -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files. let top = repoPath repo- cwd <- getCurrentDirectory- return (map (\f -> relPathDirToFile cwd $ top </> f) fs, cleanup)+ currdir <- getCurrentDirectory+ return (map (\f -> relPathDirToFile currdir $ top </> f) fs, cleanup) where prefix = [Params "diff --name-only --diff-filter=T -z"] suffix = Param "--" : (if null l then [File "."] else map File l)
Git/Repair.hs view
@@ -1,7 +1,6 @@ {- git repository recovery-import qualified Data.Set as S -- - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -}@@ -9,6 +8,7 @@ module Git.Repair ( runRepair, runRepairOf,+ removeBadBranches, successfulRepair, cleanCorruptObjects, retrieveMissingObjects,@@ -45,35 +45,18 @@ import Data.Tuple.Utils {- Given a set of bad objects found by git fsck, which may not- - be complete, finds and removes all corrupt objects,- - and returns missing objects.- -}-cleanCorruptObjects :: FsckResults -> Repo -> IO FsckResults+ - be complete, finds and removes all corrupt objects. -}+cleanCorruptObjects :: FsckResults -> Repo -> IO () 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 (knownMissing 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- fs <- filterM doesFileExist (map (looseObjectFile r) (S.toList s))- let count = length fs- if count > 0- then do- putStrLn $ unwords- [ "Removing"- , show count- , "corrupt loose objects."- ]- mapM_ nukeFile fs- return True- else return False+ mapM_ removeLoose (S.toList $ knownMissing fsckresults)+ mapM_ removeBad =<< listLooseObjectShas r+ where+ removeLoose s = nukeFile (looseObjectFile r s)+ removeBad s = do+ void $ tryIO $ allowRead $ looseObjectFile r s+ whenM (isMissing s r) $+ removeLoose s {- Explodes all pack files, and deletes them. -@@ -132,7 +115,9 @@ void $ copyObjects tmpr r case stillmissing of FsckFailed -> return $ FsckFailed- FsckFoundMissing s -> FsckFoundMissing <$> findMissing (S.toList s) r+ FsckFoundMissing s t -> FsckFoundMissing + <$> findMissing (S.toList s) r+ <*> pure t , return stillmissing ) pullremotes tmpr (rmt:rmts) fetchrefs ms@@ -145,9 +130,9 @@ void $ copyObjects tmpr r case ms of FsckFailed -> pullremotes tmpr rmts fetchrefs ms- FsckFoundMissing s -> do+ FsckFoundMissing s t -> do stillmissing <- findMissing (S.toList s) r- pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing)+ pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing t) , pullremotes tmpr rmts fetchrefs ms ) fetchfrom fetchurl ps = runBool $@@ -207,8 +192,11 @@ - any branches (filtered by a predicate) that reference them - Returns a list of all removed branches. -}-removeBadBranches :: (Ref -> Bool) -> MissingObjects -> GoodCommits -> Repo -> IO ([Branch], GoodCommits)-removeBadBranches removablebranch missing goodcommits r =+removeBadBranches :: (Ref -> Bool) -> Repo -> IO [Branch]+removeBadBranches removablebranch r = fst <$> removeBadBranches' removablebranch S.empty emptyGoodCommits r++removeBadBranches' :: (Ref -> Bool) -> MissingObjects -> GoodCommits -> Repo -> IO ([Branch], GoodCommits)+removeBadBranches' removablebranch missing goodcommits r = go [] goodcommits =<< filter removablebranch <$> getAllRefs r where go removed gcs [] = return (removed, gcs)@@ -220,6 +208,11 @@ nukeBranchRef b r go (b:removed) gcs' bs +badBranches :: MissingObjects -> Repo -> IO [Branch]+badBranches missing r = filterM isbad =<< getAllRefs r+ where+ isbad b = not . fst <$> verifyCommit missing emptyGoodCommits b r+ {- 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.@@ -295,7 +288,7 @@ then return (Just c, gcs') else findfirst gcs' cs -{- Verifies tha none of the missing objects in the set are used by+{- Verifies that none of the missing objects in the set are used by - the commit. Also adds to a set of commit shas that have been verified to - be good, which can be passed into subsequent calls to avoid - redundant work when eg, chasing down branches to find the first@@ -455,8 +448,12 @@ if foundBroken fsckresult then runRepair' removablebranch fsckresult forced Nothing g else do- putStrLn "No problems found."- return (True, [])+ bad <- badBranches S.empty g+ if null bad+ then do+ putStrLn "No problems found."+ return (True, [])+ else runRepair' removablebranch fsckresult forced Nothing g runRepairOf :: FsckResults -> (Ref -> Bool) -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) runRepairOf fsckresult removablebranch forced referencerepo g = do@@ -465,14 +462,15 @@ runRepair' :: (Ref -> Bool) -> FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) runRepair' removablebranch fsckresult forced referencerepo g = do- missing <- cleanCorruptObjects fsckresult g+ cleanCorruptObjects fsckresult g+ missing <- findBroken False g stillmissing <- retrieveMissingObjects missing referencerepo g case stillmissing of- FsckFoundMissing s+ FsckFoundMissing s t | S.null s -> if repoIsLocalBare g- then successfulfinish []+ then checkbadbranches s else ifM (checkIndex g)- ( successfulfinish []+ ( checkbadbranches s , do putStrLn "No missing objects found, but the index file is corrupt!" if forced@@ -481,7 +479,7 @@ ) | otherwise -> if forced then ifM (checkIndex g)- ( continuerepairs s+ ( forcerepair s t , corruptedindex ) else do@@ -493,17 +491,17 @@ FsckFailed | forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex g) ( do- missing' <- cleanCorruptObjects FsckFailed g- case missing' of+ cleanCorruptObjects FsckFailed g+ stillmissing' <- findBroken False g+ case stillmissing' of FsckFailed -> return (False, [])- FsckFoundMissing stillmissing' ->- continuerepairs stillmissing'+ FsckFoundMissing s t -> forcerepair s t , corruptedindex ) | otherwise -> unsuccessfulfinish where- continuerepairs stillmissing = do- (removedbranches, goodcommits) <- removeBadBranches removablebranch stillmissing emptyGoodCommits g+ repairbranches missing = do+ (removedbranches, goodcommits) <- removeBadBranches' removablebranch missing emptyGoodCommits g let remotebranches = filter isTrackingBranch removedbranches unless (null remotebranches) $ putStrLn $ unwords@@ -511,32 +509,53 @@ , show (length remotebranches) , "remote tracking branches that referred to missing objects." ]- (resetbranches, deletedbranches, _) <- resetLocalBranches stillmissing goodcommits g+ (resetbranches, deletedbranches, _) <- resetLocalBranches missing goodcommits g displayList (map fromRef resetbranches) "Reset these local branches to old versions before the missing objects were committed:" displayList (map fromRef deletedbranches) "Deleted these local branches, which could not be recovered due to missing objects:"+ return (resetbranches ++ deletedbranches)++ checkbadbranches missing = do+ bad <- badBranches missing g+ case (null bad, forced) of+ (True, _) -> successfulfinish []+ (False, False) -> do+ displayList (map fromRef bad)+ "Some git branches refer to missing objects:"+ unsuccessfulfinish+ (False, True) -> successfulfinish =<< repairbranches missing++ forcerepair missing fscktruncated = do+ modifiedbranches <- repairbranches missing deindexedfiles <- rewriteIndex g displayList deindexedfiles "Removed these missing files from the index. You should look at what files are present in your working tree and git add them back to the index when appropriate."- let modifiedbranches = resetbranches ++ deletedbranches- if null resetbranches && null deletedbranches- then successfulfinish modifiedbranches- else do- unless (repoIsLocalBare g) $ do- mcurr <- Branch.currentUnsafe g- case mcurr of- Nothing -> return ()- Just curr -> when (any (== curr) modifiedbranches) $ do++ -- When the fsck results were truncated, try+ -- fscking again, and as long as different+ -- missing objects are found, continue+ -- the repair process.+ if fscktruncated+ then do+ fsckresult' <- findBroken False g+ case fsckresult' of+ FsckFailed -> do+ putStrLn "git fsck is failing"+ return (False, modifiedbranches)+ FsckFoundMissing s _+ | S.null s -> successfulfinish modifiedbranches+ | S.null (s `S.difference` missing) -> do putStrLn $ unwords- [ "You currently have"- , fromRef curr- , "checked out. You may have staged changes in the index that can be committed to recover the lost state of this branch!"+ [ show (S.size s)+ , "missing objects could not be recovered!" ]- putStrLn "Successfully recovered repository!"- putStrLn "Please carefully check that the changes mentioned above are ok.."- return (True, modifiedbranches)- + return (False, modifiedbranches) + | otherwise -> do+ (ok, modifiedbranches') <- runRepairOf fsckresult' removablebranch forced referencerepo g+ return (ok, modifiedbranches++modifiedbranches')+ else successfulfinish modifiedbranches+ corruptedindex = do nukeFile (indexFile g) -- The corrupted index can prevent fsck from finding other@@ -546,12 +565,28 @@ 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 result - successfulfinish modifiedbranches = do- mapM_ putStrLn- [ "Successfully recovered repository!"- , "You should run \"git fsck\" to make sure, but it looks like everything was recovered ok."- ]- return (True, modifiedbranches)+ successfulfinish modifiedbranches+ | null modifiedbranches = do+ mapM_ putStrLn+ [ "Successfully recovered repository!"+ , "You should run \"git fsck\" to make sure, but it looks like everything was recovered ok."+ ]+ return (True, modifiedbranches)+ | otherwise = do+ unless (repoIsLocalBare g) $ do+ mcurr <- Branch.currentUnsafe g+ case mcurr of+ Nothing -> return ()+ Just curr -> when (any (== curr) modifiedbranches) $ do+ putStrLn $ unwords+ [ "You currently have"+ , fromRef curr+ , "checked out. You may have staged changes in the index that can be committed to recover the lost state of this branch!"+ ]+ putStrLn "Successfully recovered repository!"+ putStrLn "Please carefully check that the changes mentioned above are ok.."+ return (True, modifiedbranches)+ unsuccessfulfinish = do if repoIsLocalBare g then do
Git/Types.hs view
@@ -11,6 +11,7 @@ import qualified Data.Map as M import System.Posix.Types import Utility.SafeCommand+import Utility.URI () {- Support repositories on local disk, and repositories accessed via an URL. -@@ -27,7 +28,7 @@ | LocalUnknown FilePath | Url URI | Unknown- deriving (Show, Eq)+ deriving (Show, Eq, Ord) data Repo = Repo { location :: RepoLocation@@ -41,7 +42,7 @@ , gitEnv :: Maybe [(String, String)] -- global options to pass to git when running git commands , gitGlobalOpts :: [CommandParam]- } deriving (Show, Eq)+ } deriving (Show, Eq, Ord) type RemoteName = String
Git/UpdateIndex.hs view
@@ -15,6 +15,7 @@ startUpdateIndex, stopUpdateIndex, lsTree,+ lsSubTree, updateIndexLine, stageFile, unstageFile,@@ -29,7 +30,6 @@ import Git.Sha import Control.Exception (bracket)-import System.Process (std_in) {- Streamers are passed a callback and should feed it lines in the form - read by update-index, and generated by ls-tree. -}@@ -74,6 +74,13 @@ void $ cleanup where params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]+lsSubTree :: Ref -> FilePath -> Repo -> Streamer+lsSubTree (Ref x) p repo streamer = do+ (s, cleanup) <- pipeNullSplit params repo+ mapM_ streamer s+ void $ cleanup+ where+ params = map Param ["ls-tree", "-z", "-r", "--full-tree", x, p] {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -}
Makefile view
@@ -29,6 +29,6 @@ # 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+ (for f in $$(find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$'); do hothasktags -c --cpp -c -traditional -c --include=dist/build/autogen/cabal_macros.h $$f; done) 2>/dev/null | sort > tags .PHONY: tags
Utility/Applicative.hs view
@@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} module Utility.Applicative where
Utility/Batch.hs view
@@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# LANGUAGE CPP #-}@@ -16,7 +16,6 @@ import System.Posix.Process #endif import qualified Control.Exception as E-import System.Process (env) {- Runs an operation, at batch priority. -
Utility/CoProcess.hs view
@@ -3,7 +3,7 @@ - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# LANGUAGE CPP #-}@@ -37,8 +37,8 @@ } start :: Int -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle-start numrestarts cmd params env = do- s <- start' $ CoProcessSpec numrestarts cmd params env+start numrestarts cmd params environ = do+ s <- start' $ CoProcessSpec numrestarts cmd params environ newMVar s start' :: CoProcessSpec -> IO CoProcessState@@ -62,7 +62,7 @@ s <- readMVar ch restartable s (send $ coProcessTo s) $ const $ restartable s (hFlush $ coProcessTo s) $ const $- restartable s (receive $ coProcessFrom s) $+ restartable s (receive $ coProcessFrom s) return where restartable s a cont
Utility/Data.hs view
@@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} module Utility.Data where
Utility/Directory.hs view
@@ -1,8 +1,8 @@-{- directory manipulation+{- directory traversal and manipulation - - Copyright 2011-2014 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# LANGUAGE CPP #-}@@ -11,13 +11,21 @@ import System.IO.Error import System.Directory-import Control.Exception (throw)+import Control.Exception (throw, bracket) import Control.Monad import Control.Monad.IfElse import System.FilePath import Control.Applicative+import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO)+import Data.Maybe +#ifdef mingw32_HOST_OS+import qualified System.Win32 as Win32+#else+import qualified System.Posix as Posix+#endif+ import Utility.PosixFiles import Utility.SafeCommand import Utility.Tmp@@ -43,7 +51,7 @@ - When the directory does not exist, no exception is thrown, - instead, [] is returned. -} dirContentsRecursive :: FilePath -> IO [FilePath]-dirContentsRecursive topdir = dirContentsRecursiveSkipping (const False) True topdir+dirContentsRecursive = dirContentsRecursiveSkipping (const False) True {- Skips directories whose basenames match the skipdir. -} dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]@@ -133,3 +141,90 @@ #else go = removeFile file #endif++#ifndef mingw32_HOST_OS+data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream+#else+data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ())+#endif++type IsOpen = MVar () -- full when the handle is open++openDirectory :: FilePath -> IO DirectoryHandle+openDirectory path = do+#ifndef mingw32_HOST_OS+ dirp <- Posix.openDirStream path+ isopen <- newMVar ()+ return (DirectoryHandle isopen dirp)+#else+ (h, fdat) <- Win32.findFirstFile (path </> "*")+ -- Indicate that the fdat contains a filename that readDirectory+ -- has not yet returned, by making the MVar be full.+ -- (There's always at least a "." entry.)+ alreadyhave <- newMVar ()+ isopen <- newMVar ()+ return (DirectoryHandle isopen h fdat alreadyhave)+#endif++closeDirectory :: DirectoryHandle -> IO ()+#ifndef mingw32_HOST_OS+closeDirectory (DirectoryHandle isopen dirp) =+ whenOpen isopen $+ Posix.closeDirStream dirp+#else+closeDirectory (DirectoryHandle isopen h _ alreadyhave) =+ whenOpen isopen $ do+ _ <- tryTakeMVar alreadyhave+ Win32.findClose h+#endif+ where+ whenOpen :: IsOpen -> IO () -> IO ()+ whenOpen mv f = do+ v <- tryTakeMVar mv+ when (isJust v) f++{- |Reads the next entry from the handle. Once the end of the directory+is reached, returns Nothing and automatically closes the handle.+-}+readDirectory :: DirectoryHandle -> IO (Maybe FilePath)+#ifndef mingw32_HOST_OS+readDirectory hdl@(DirectoryHandle _ dirp) = do+ e <- Posix.readDirStream dirp+ if null e+ then do+ closeDirectory hdl+ return Nothing+ else return (Just e)+#else+readDirectory hdl@(DirectoryHandle _ h fdat mv) = do+ -- If the MVar is full, then the filename in fdat has+ -- not yet been returned. Otherwise, need to find the next+ -- file.+ r <- tryTakeMVar mv+ case r of+ Just () -> getfn+ Nothing -> do+ more <- Win32.findNextFile h fdat+ if more+ then getfn+ else do+ closeDirectory hdl+ return Nothing+ where+ getfn = do+ filename <- Win32.getFindDataFileName fdat+ return (Just filename)+#endif++-- True only when directory exists and contains nothing.+-- Throws exception if directory does not exist.+isDirectoryEmpty :: FilePath -> IO Bool+isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check+ where+ check h = do+ v <- readDirectory h+ case v of+ Nothing -> return True+ Just f+ | not (dirCruft f) -> return False+ | otherwise -> check h
Utility/Env.hs view
@@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# LANGUAGE CPP #-}
Utility/Exception.hs view
@@ -2,7 +2,7 @@ - - Copyright 2011-2012 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# LANGUAGE ScopedTypeVariables #-}@@ -18,7 +18,7 @@ {- Catches IO errors and returns a Bool -} catchBoolIO :: IO Bool -> IO Bool-catchBoolIO a = catchDefaultIO False a+catchBoolIO = catchDefaultIO False {- Catches IO errors and returns a Maybe -} catchMaybeIO :: IO a -> IO (Maybe a)
Utility/FileMode.hs view
@@ -2,22 +2,25 @@ - - Copyright 2010-2012 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# LANGUAGE CPP #-} module Utility.FileMode where -import Common-+import System.IO+import Control.Monad import Control.Exception (bracket) import System.PosixCompat.Types+import Utility.PosixFiles #ifndef mingw32_HOST_OS import System.Posix.Files #endif import Foreign (complement) +import Utility.Exception+ {- Applies a conversion function to a file's mode. -} modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO () modifyFileMode f convert = void $ modifyFileMode' f convert@@ -56,6 +59,12 @@ executeModes :: [FileMode] executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode] +otherGroupModes :: [FileMode]+otherGroupModes = + [ groupReadMode, otherReadMode+ , groupWriteMode, otherWriteMode+ ]+ {- Removes the write bits from a file. -} preventWrite :: FilePath -> IO () preventWrite f = modifyFileMode f $ removeModes writeModes@@ -99,13 +108,20 @@ #ifndef mingw32_HOST_OS noUmask mode a | mode == stdFileMode = a- | otherwise = bracket setup cleanup go+ | otherwise = withUmask nullFileMode a+#else+noUmask _ a = a+#endif++withUmask :: FileMode -> IO a -> IO a+#ifndef mingw32_HOST_OS+withUmask umask a = bracket setup cleanup go where- setup = setFileCreationMask nullFileMode+ setup = setFileCreationMask umask cleanup = setFileCreationMask go _ = a #else-noUmask _ a = a+withUmask _ a = a #endif combineModes :: [FileMode] -> FileMode@@ -127,14 +143,16 @@ #endif {- Writes a file, ensuring that its modes do not allow it to be read- - by anyone other than the current user, before any content is written.+ - or written by anyone other than the current user,+ - before any content is written. -+ - When possible, this is done using the umask.+ - - On a filesystem that does not support file permissions, this is the same - as writeFile. -} writeFileProtected :: FilePath -> String -> IO ()-writeFileProtected file content = withFile file WriteMode $ \h -> do- void $ tryIO $- modifyFileMode file $- removeModes [groupReadMode, otherReadMode]- hPutStr h content+writeFileProtected file content = withUmask 0o0077 $+ withFile file WriteMode $ \h -> do+ void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes+ hPutStr h content
Utility/FileSystemEncoding.hs view
@@ -1,14 +1,17 @@ {- GHC File system encoding handling. -- - Copyright 2012-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} +{-# LANGUAGE CPP #-}+ module Utility.FileSystemEncoding ( fileEncoding, withFilePath, md5FilePath,+ decodeBS, decodeW8, encodeW8, truncateFilePath,@@ -22,13 +25,24 @@ import qualified Data.Hash.MD5 as MD5 import Data.Word import Data.Bits.Utils+import qualified Data.ByteString.Lazy as L+#ifdef mingw32_HOST_OS+import qualified Data.ByteString.Lazy.UTF8 as L8+#endif {- Sets a Handle to use the filesystem encoding. This causes data - written or read from it to be encoded/decoded the same - as ghc 7.4 does to filenames etc. This special encoding- - allows "arbitrary undecodable bytes to be round-tripped through it". -}+ - allows "arbitrary undecodable bytes to be round-tripped through it".+ -} fileEncoding :: Handle -> IO ()+#ifndef mingw32_HOST_OS fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding+#else+{- The file system encoding does not work well on Windows,+ - and Windows only has utf FilePaths anyway. -}+fileEncoding h = hSetEncoding h Encoding.utf8+#endif {- Marshal a Haskell FilePath into a NUL terminated C string using temporary - storage. The FilePath is encoded using the filesystem encoding,@@ -60,6 +74,16 @@ md5FilePath :: FilePath -> MD5.Str md5FilePath = MD5.Str . _encodeFilePath +{- Decodes a ByteString into a FilePath, applying the filesystem encoding. -}+decodeBS :: L.ByteString -> FilePath+#ifndef mingw32_HOST_OS+decodeBS = encodeW8 . L.unpack+#else+{- On Windows, we assume that the ByteString is utf-8, since Windows+ - only uses unicode for filenames. -}+decodeBS = L8.toString+#endif+ {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. - - w82c produces a String, which may contain Chars that are invalid@@ -84,6 +108,7 @@ - cost of efficiency when running on a large FilePath. -} truncateFilePath :: Int -> FilePath -> FilePath+#ifndef mingw32_HOST_OS truncateFilePath n = go . reverse where go f =@@ -91,3 +116,17 @@ in if length bytes <= n then reverse f else go (drop 1 f)+#else+{- On Windows, count the number of bytes used by each utf8 character. -}+truncateFilePath n = reverse . go [] n . L8.fromString+ where+ go coll cnt bs+ | cnt <= 0 = coll+ | otherwise = case L8.decode bs of+ Just (c, x) | c /= L8.replacement_char ->+ let x' = fromIntegral x+ in if cnt - x' < 0+ then coll+ else go (c:coll) (cnt - x') (L8.drop 1 bs)+ _ -> coll+#endif
Utility/Format.hs view
@@ -2,7 +2,7 @@ - - Copyright 2010, 2011 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} module Utility.Format (
Utility/Metered.hs view
@@ -2,7 +2,7 @@ - - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# LANGUAGE TypeSynonymInstances #-}
Utility/Misc.hs view
@@ -2,7 +2,7 @@ - - Copyright 2010-2011 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# LANGUAGE CPP #-}@@ -108,18 +108,6 @@ | val `isPrefixOf` s = go (replacement:acc) vs (drop (length val) s) | otherwise = go acc rest s--{- Given two orderings, returns the second if the first is EQ and returns- - the first otherwise.- -- - Example use:- -- - compare lname1 lname2 `thenOrd` compare fname1 fname2- -}-thenOrd :: Ordering -> Ordering -> Ordering-thenOrd EQ x = x-thenOrd x _ = x-{-# INLINE thenOrd #-} {- Wrapper around hGetBufSome that returns a String. -
Utility/Monad.hs view
@@ -2,7 +2,7 @@ - - Copyright 2010-2012 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} module Utility.Monad where
Utility/Path.hs view
@@ -2,7 +2,7 @@ - - Copyright 2010-2014 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# LANGUAGE PackageImports, CPP #-}@@ -18,7 +18,6 @@ import Control.Applicative #ifdef mingw32_HOST_OS-import Data.Char import qualified System.FilePath.Posix as Posix #else import System.Posix.Files
Utility/PosixFiles.hs view
@@ -4,7 +4,7 @@ - - Copyright 2014 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# LANGUAGE CPP #-}
Utility/Process.hs view
@@ -3,14 +3,14 @@ - - Copyright 2012 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# LANGUAGE CPP, Rank2Types #-} module Utility.Process ( module X,- CreateProcess,+ CreateProcess(..), StdHandle(..), readProcess, readProcessEnv,@@ -31,6 +31,7 @@ stdinHandle, stdoutHandle, stderrHandle,+ processHandle, devNull, ) where @@ -166,10 +167,10 @@ processTranscript cmd opts input = processTranscript' cmd opts Nothing input processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)+processTranscript' cmd opts environ input = do #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order - the process writes them. -}-processTranscript' cmd opts environ input = do (readf, writef) <- createPipe readh <- fdToHandle readf writeh <- fdToHandle writef@@ -183,24 +184,13 @@ hClose writeh get <- mkreader readh-- -- now write and flush any input- case input of- Just s -> do- let inh = stdinHandle p- unless (null s) $ do- hPutStr inh s- hFlush inh- hClose inh- Nothing -> return ()-+ writeinput input p transcript <- get ok <- checkSuccessProcess pid return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -}-processTranscript' cmd opts environ input = do p@(_, _, _, pid) <- createProcess $ (proc cmd opts) { std_in = if isJust input then CreatePipe else Inherit@@ -211,17 +201,9 @@ getout <- mkreader (stdoutHandle p) geterr <- mkreader (stderrHandle p)-- case input of- Just s -> do- let inh = stdinHandle p- unless (null s) $ do- hPutStr inh s- hFlush inh- hClose inh- Nothing -> return ()- + writeinput input p transcript <- (++) <$> getout <*> geterr+ ok <- checkSuccessProcess pid return (transcript, ok) #endif@@ -236,6 +218,14 @@ takeMVar v return s + writeinput (Just s) p = do+ let inh = stdinHandle p+ unless (null s) $ do+ hPutStr inh s+ hFlush inh+ hClose inh+ writeinput Nothing _ = return ()+ {- Runs a CreateProcessRunner, on a CreateProcess structure, that - is adjusted to pipe only from/to a single StdHandle, and passes - the resulting Handle to an action. -}@@ -312,6 +302,9 @@ bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) bothHandles (Just hin, Just hout, _, _) = (hin, hout) bothHandles _ = error "expected bothHandles"++processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle+processHandle (_, _, _, pid) = pid {- Debugging trace for a CreateProcess. -} debugProcess :: CreateProcess -> IO ()
Utility/QuickCheck.hs view
@@ -2,7 +2,7 @@ - - Copyright 2012-2014 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -28,10 +28,10 @@ {- Times before the epoch are excluded. -} instance Arbitrary POSIXTime where- arbitrary = nonNegative arbitrarySizedIntegral+ arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral instance Arbitrary EpochTime where- arbitrary = nonNegative arbitrarySizedIntegral+ arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral {- Pids are never negative, or 0. -} instance Arbitrary ProcessID where
Utility/Rsync.hs view
@@ -2,7 +2,7 @@ - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} module Utility.Rsync where@@ -124,6 +124,9 @@ - after the \r is the number of bytes processed. After the number, - there must appear some whitespace, or we didn't get the whole number, - and return the \r and part we did get, for later processing.+ -+ - In some locales, the number will have one or more commas in the middle+ - of it. -} parseRsyncProgress :: String -> (Maybe Integer, String) parseRsyncProgress = go [] . reverse . progresschunks@@ -142,7 +145,7 @@ parsebytes s = case break isSpace s of ([], _) -> Nothing (_, []) -> Nothing- (b, _) -> readish b+ (b, _) -> readish $ filter (/= ',') b {- Filters options to those that are safe to pass to rsync in server mode, - without causing it to eg, expose files. -}
Utility/SafeCommand.hs view
@@ -2,14 +2,13 @@ - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} module Utility.SafeCommand where import System.Exit import Utility.Process-import System.Process (env) import Data.String.Utils import Control.Applicative import System.FilePath
Utility/ThreadScheduler.hs view
@@ -3,17 +3,20 @@ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> - Copyright 2011 Bas van Dijk & Roel van Dijk -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# LANGUAGE CPP #-} module Utility.ThreadScheduler where -import Common-+import Control.Monad import Control.Concurrent #ifndef mingw32_HOST_OS+import Control.Monad.IfElse+import System.Posix.IO+#endif+#ifndef mingw32_HOST_OS import System.Posix.Signals #ifndef __ANDROID__ import System.Posix.Terminal@@ -54,8 +57,7 @@ waitForTermination :: IO () waitForTermination = do #ifdef mingw32_HOST_OS- runEvery (Seconds 600) $- void getLine+ forever $ threadDelaySeconds (Seconds 6000) #else lock <- newEmptyMVar let check sig = void $
Utility/Tmp.hs view
@@ -2,7 +2,7 @@ - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# LANGUAGE CPP #-}@@ -25,13 +25,20 @@ - then moving it into place. The temp file is stored in the same - directory as the final file to avoid cross-device renames. -} viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO ()-viaTmp a file content = do- let (dir, base) = splitFileName file- createDirectoryIfMissing True dir- (tmpfile, handle) <- openTempFile dir (base ++ ".tmp")- hClose handle- a tmpfile content- rename tmpfile file+viaTmp a file content = bracket setup cleanup use+ where+ (dir, base) = splitFileName file+ template = base ++ ".tmp"+ setup = do+ createDirectoryIfMissing True dir+ openTempFile dir template+ cleanup (tmpfile, handle) = do+ _ <- tryIO $ hClose handle+ tryIO $ removeFile tmpfile+ use (tmpfile, handle) = do+ hClose handle+ a tmpfile content+ rename tmpfile file {- Runs an action with a tmp file located in the system's tmp directory - (or in "." if there is none) then removes the file. -}
+ Utility/URI.hs view
@@ -0,0 +1,18 @@+{- Network.URI+ -+ - Copyright 2014 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}++module Utility.URI where++-- Old versions of network lacked an Ord for URI+#if ! MIN_VERSION_network(2,4,0)+import Network.URI++instance Ord URI where+ a `compare` b = show a `compare` show b+#endif
Utility/UserInfo.hs view
@@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess <joey@kitenet.net> -- - Licensed under the GNU GPL version 3 or higher.+ - License: BSD-2-clause -} {-# LANGUAGE CPP #-}
debian/changelog view
@@ -1,3 +1,25 @@+git-repair (1.20140914) unstable; urgency=medium++ * Update to build with optparse-applicative 0.10. Closes: #761552++ -- Joey Hess <joeyh@debian.org> Sun, 14 Sep 2014 12:48:27 -0400++git-repair (1.20140815) unstable; urgency=medium++ * Removing bad objects could leave fsck finding no more unreachable objects,+ but some branches no longer accessible. Fix this, including support for+ fixing up repositories that were incompletely repaired before.+ * Merge from git-annex.++ -- Joey Hess <joeyh@debian.org> Fri, 15 Aug 2014 13:49:09 -0400++git-repair (1.20140423) unstable; urgency=medium++ * Improve memory usage when git fsck finds a great many broken objects.+ * Merge from git-annex.++ -- Joey Hess <joeyh@debian.org> Wed, 23 Apr 2014 14:01:30 -0400+ git-repair (1.20140227) unstable; urgency=medium * Optimise unpacking of pack files, and avoid repeated error
debian/control view
@@ -15,7 +15,7 @@ libghc-quickcheck2-dev, libghc-utf8-string-dev, libghc-async-dev,- libghc-optparse-applicative-dev+ libghc-optparse-applicative-dev (>= 0.10.0) Maintainer: Joey Hess <joeyh@debian.org> Standards-Version: 3.9.5 Vcs-Git: git://git-repair.branchable.com/
debian/copyright view
@@ -7,3 +7,29 @@ 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.++Files: Utility/*+Copyright: 2012-2014 Joey Hess <joey@kitenet.net>+License: BSD-2-clause++License: BSD-2-clause+ Redistribution and use in source and binary forms, with or without+ modification, are permitted provided that the following conditions+ are met:+ 1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ 2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ .+ THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS ``AS IS'' AND+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+ SUCH DAMAGE.
git-repair.cabal view
@@ -1,12 +1,13 @@ Name: git-repair-Version: 1.20140227-Cabal-Version: >= 1.6+Version: 1.20140914+Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess <joey@kitenet.net> Author: Joey Hess Stability: Stable Copyright: 2013 Joey Hess License-File: GPL+Extra-Source-Files: CHANGELOG Build-Type: Custom Homepage: http://git-repair.branchable.com/ Category: Utility@@ -27,7 +28,7 @@ Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl, network, extensible-exceptions, unix-compat, bytestring, base >= 4.5, base < 5, IfElse, text, process, time, QuickCheck,- utf8-string, async, optparse-applicative+ utf8-string, async, optparse-applicative (>= 0.10.0) if (! os(windows)) Build-Depends: unix
git-repair.hs view
@@ -37,7 +37,7 @@ ( long "retry" <> help "Retry tests in git-repair-test.log" )- <*> option+ <*> option auto ( long "numtests" <> short 'n' <> metavar "N"