git-repair 1.20210629 → 1.20220404
raw patch · 26 files changed
+353/−248 lines, 26 filesdep ~filepath-bytestring
Dependency ranges changed: filepath-bytestring
Files
- CHANGELOG +7/−0
- COPYRIGHT +2/−2
- Git/Branch.hs +14/−5
- Git/CatFile.hs +37/−20
- Git/Command.hs +1/−1
- Git/Config.hs +12/−4
- Git/Construct.hs +4/−1
- Git/Fsck.hs +17/−5
- Git/LsFiles.hs +25/−7
- Git/LsTree.hs +1/−1
- Git/Ref.hs +20/−13
- Git/Remote.hs +2/−2
- Git/Repair.hs +34/−23
- Git/Types.hs +5/−5
- Git/UpdateIndex.hs +2/−2
- Utility/Data.hs +17/−1
- Utility/Debug.hs +2/−2
- Utility/FileSystemEncoding.hs +22/−126
- Utility/HumanNumber.hs +7/−3
- Utility/InodeCache.hs +2/−7
- Utility/Metered.hs +48/−4
- Utility/Path.hs +45/−3
- Utility/Tmp.hs +16/−2
- Utility/Tmp/Dir.hs +5/−3
- git-repair.cabal +5/−5
- git-repair.hs +1/−1
CHANGELOG view
@@ -1,3 +1,10 @@+git-repair (1.20220404) unstable; urgency=medium++ * Avoid treating refs that are not commit objects as evidence of+ repository corruption.++ -- Joey Hess <id@joeyh.name> Wed, 04 May 2022 11:43:15 -0400+ git-repair (1.20210629) unstable; urgency=medium * Fixed bug that interrupting the program while it was fixing repository
COPYRIGHT view
@@ -2,11 +2,11 @@ Source: git://git-repair.branchable.com/ Files: *-Copyright: © 2013-2019 Joey Hess <joey@kitenet.net>+Copyright: © 2013-2022 Joey Hess <joey@kitenet.net> License: AGPL-3+ Files: Utility/*-Copyright: 2012-2014 Joey Hess <joey@kitenet.net>+Copyright: 2012-2022 Joey Hess <joey@kitenet.net> License: BSD-2-clause Files: Utility/Attoparsec.hs
Git/Branch.hs view
@@ -121,6 +121,13 @@ (False, True) -> findbest c rs -- worse (False, False) -> findbest c rs -- same +{- Should the commit avoid the usual summary output? -}+newtype CommitQuiet = CommitQuiet Bool++applyCommitQuiet :: CommitQuiet -> [CommandParam] -> [CommandParam]+applyCommitQuiet (CommitQuiet True) ps = Param "--quiet" : ps+applyCommitQuiet (CommitQuiet False) ps = ps+ {- The user may have set commit.gpgsign, intending all their manual - commits to be signed. But signing automatic/background commits could - easily lead to unwanted gpg prompts or failures.@@ -148,12 +155,14 @@ ps' = applyCommitMode commitmode ps {- Commit via the usual git command. -}-commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool+commitCommand :: CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO Bool commitCommand = commitCommand' runBool -commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a-commitCommand' runner commitmode ps = runner $- Param "commit" : applyCommitMode commitmode ps+commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO a+commitCommand' runner commitmode commitquiet ps =+ runner $ Param "commit" : ps'+ where+ ps' = applyCommitMode commitmode (applyCommitQuiet commitquiet ps) {- Commits the index into the specified branch (or other ref), - with the specified parent refs, and returns the committed sha.@@ -162,7 +171,7 @@ - one parent, and it has the same tree that would be committed. - - Unlike git-commit, does not run any hooks, or examine the work tree- - in any way.+ - in any way, or output a summary. -} commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) commit commitmode allowempty message branch parentrefs repo = do
Git/CatFile.hs view
@@ -1,6 +1,6 @@ {- git cat-file interface -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -10,9 +10,13 @@ module Git.CatFile ( CatFileHandle,+ CatFileMetaDataHandle, catFileStart,+ catFileMetaDataStart, catFileStart',+ catFileMetaDataStart', catFileStop,+ catFileMetaDataStop, catFile, catFileDetails, catTree,@@ -55,32 +59,45 @@ data CatFileHandle = CatFileHandle { catFileProcess :: CoProcess.CoProcessHandle- , checkFileProcess :: CoProcess.CoProcessHandle- , gitRepo :: Repo+ , catFileGitRepo :: Repo } +data CatFileMetaDataHandle = CatFileMetaDataHandle+ { checkFileProcess :: CoProcess.CoProcessHandle+ , checkFileGitRepo :: Repo+ }+ catFileStart :: Repo -> IO CatFileHandle catFileStart = catFileStart' True catFileStart' :: Bool -> Repo -> IO CatFileHandle catFileStart' restartable repo = CatFileHandle- <$> startp "--batch"- <*> startp ("--batch-check=" ++ batchFormat)+ <$> startcat restartable repo "--batch" <*> pure repo- where- startp p = gitCoProcessStart restartable- [ Param "cat-file"- , Param p- ] repo +catFileMetaDataStart :: Repo -> IO CatFileMetaDataHandle+catFileMetaDataStart = catFileMetaDataStart' True++catFileMetaDataStart' :: Bool -> Repo -> IO CatFileMetaDataHandle+catFileMetaDataStart' restartable repo = CatFileMetaDataHandle+ <$> startcat restartable repo ("--batch-check=" ++ batchFormat)+ <*> pure repo+ batchFormat :: String batchFormat = "%(objectname) %(objecttype) %(objectsize)" +startcat :: Bool -> Repo -> String -> IO CoProcess.CoProcessHandle+startcat restartable repo p = gitCoProcessStart restartable+ [ Param "cat-file"+ , Param p+ ] repo+ catFileStop :: CatFileHandle -> IO ()-catFileStop h = do- CoProcess.stop (catFileProcess h)- CoProcess.stop (checkFileProcess h)+catFileStop = CoProcess.stop . catFileProcess +catFileMetaDataStop :: CatFileMetaDataHandle -> IO ()+catFileMetaDataStop = CoProcess.stop . checkFileProcess+ {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString catFile h branch file = catObject h $@@ -106,16 +123,16 @@ Nothing -> error $ "unknown response from git cat-file " ++ show (header, object) where -- Slow fallback path for filenames containing newlines.- newlinefallback = queryObjectType object (gitRepo h) >>= \case+ newlinefallback = queryObjectType object (catFileGitRepo h) >>= \case Nothing -> return Nothing- Just objtype -> queryContent object (gitRepo h) >>= \case+ Just objtype -> queryContent object (catFileGitRepo h) >>= \case Nothing -> return Nothing Just content -> do -- only the --batch interface allows getting -- the sha, so have to re-hash the object sha <- hashObject' objtype (flip L.hPut content)- (gitRepo h)+ (catFileGitRepo h) return (Just (content, sha, objtype)) readObjectContent :: Handle -> ParsedResp -> IO L.ByteString@@ -131,7 +148,7 @@ readObjectContent _ DNE = error "internal" {- Gets the size and type of an object, without reading its content. -}-catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType))+catObjectMetaData :: CatFileMetaDataHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType)) catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do resp <- S8.hGetLine from case parseResp object resp of@@ -142,9 +159,9 @@ where -- Slow fallback path for filenames containing newlines. newlinefallback = do- sha <- Git.Ref.sha object (gitRepo h)- sz <- querySize object (gitRepo h)- objtype <- queryObjectType object (gitRepo h)+ sha <- Git.Ref.sha object (checkFileGitRepo h)+ sz <- querySize object (checkFileGitRepo h)+ objtype <- queryObjectType object (checkFileGitRepo h) return $ (,,) <$> sha <*> sz <*> objtype data ParsedResp = ParsedResp Sha ObjectType FileSize | DNE
Git/Command.hs view
@@ -39,7 +39,7 @@ run :: [CommandParam] -> Repo -> IO () run params repo = assertLocal repo $ unlessM (runBool params repo) $- error $ "git " ++ show params ++ " failed"+ giveup $ "git " ++ show params ++ " failed" {- Runs git and forces it to be quiet, throwing an error if it fails. -} runQuiet :: [CommandParam] -> Repo -> IO ()
Git/Config.hs view
@@ -170,7 +170,7 @@ {- Checks if a string from git config is a true/false value. -} isTrueFalse :: String -> Maybe Bool-isTrueFalse = isTrueFalse' . ConfigValue . encodeBS'+isTrueFalse = isTrueFalse' . ConfigValue . encodeBS isTrueFalse' :: ConfigValue -> Maybe Bool isTrueFalse' (ConfigValue s)@@ -241,6 +241,14 @@ , Param "--list" ] ConfigList +{- Changes a git config setting in .git/config. -}+change :: ConfigKey -> S.ByteString -> Repo -> IO Bool+change (ConfigKey k) v = Git.Command.runBool+ [ Param "config"+ , Param (decodeBS k)+ , Param (decodeBS v)+ ]+ {- Changes a git config setting in the specified config file. - (Creates the file if it does not already exist.) -} changeFile :: FilePath -> ConfigKey -> S.ByteString -> IO Bool@@ -248,8 +256,8 @@ [ Param "config" , Param "--file" , File f- , Param (decodeBS' k)- , Param (decodeBS' v)+ , Param (decodeBS k)+ , Param (decodeBS v) ] {- Unsets a git config setting, in both the git repo,@@ -264,4 +272,4 @@ , return Nothing ) where- ps = [Param "config", Param "--unset-all", Param (decodeBS' k)]+ ps = [Param "config", Param "--unset-all", Param (decodeBS k)]
Git/Construct.hs view
@@ -184,7 +184,10 @@ #ifdef mingw32_HOST_OS expandTilde = return #else-expandTilde = expandt True+expandTilde p = expandt True p+ -- If unable to expand a tilde, eg due to a user not existing,+ -- use the path as given.+ `catchNonAsync` (const (return p)) where expandt _ [] = return "" expandt _ ('/':cs) = do
Git/Fsck.hs view
@@ -1,4 +1,5 @@ {- git fsck interface+i it is not fully repoducibleI repeated the same steps - - Copyright 2013 Joey Hess <id@joeyh.name> -@@ -69,9 +70,17 @@ - look for anything in its output (both stdout and stderr) that appears - to be a git sha. Not all such shas are of broken objects, so ask git - to try to cat the object, and see if it fails.+ -+ - Note that there is a possible false positive: When changes are being+ - made to the repo while this is running, fsck might complain about a+ - missing object that has not made it to disk yet. Catting the object+ - then succeeds, so it's not included in the FsckResults. But, fsck then+ - exits nonzero, and so FsckFailed is returned. Set ignorenonzeroexit+ - to avoid this false positive, at the risk of perhaps missing a problem+ - so bad that fsck crashes without outputting any missing shas. -}-findBroken :: Bool -> Repo -> IO FsckResults-findBroken batchmode r = do+findBroken :: Bool -> Bool -> Repo -> IO FsckResults+findBroken batchmode ignorenonzeroexit r = do let (command, params) = ("git", fsckParams r) (command', params') <- if batchmode then toBatchCommand (command, params)@@ -90,10 +99,10 @@ fsckok <- checkSuccessProcess pid case mappend o1 o2 of FsckOutput badobjs truncated- | S.null badobjs && not fsckok -> return FsckFailed+ | S.null badobjs && not fsckok -> return fsckfailed | otherwise -> return $ FsckFoundMissing badobjs truncated NoFsckOutput- | not fsckok -> return FsckFailed+ | not fsckok -> return fsckfailed | otherwise -> return noproblem -- If all fsck output was duplicateEntries warnings, -- the repository is not broken, it just has some@@ -104,6 +113,9 @@ maxobjs = 10000 noproblem = FsckFoundMissing S.empty False+ fsckfailed+ | ignorenonzeroexit = noproblem+ | otherwise = FsckFailed foundBroken :: FsckResults -> Bool foundBroken FsckFailed = True@@ -147,7 +159,7 @@ ] r findShas :: [String] -> [Sha]-findShas = catMaybes . map (extractSha . encodeBS') +findShas = catMaybes . map (extractSha . encodeBS) . concat . map words . filter wanted where wanted l = not ("dangling " `isPrefixOf` l)
Git/LsFiles.hs view
@@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-}+ module Git.LsFiles ( Options(..), inRepo,@@ -66,7 +68,7 @@ guardSafeForLsFiles :: Repo -> IO a -> IO a guardSafeForLsFiles r a | safeForLsFiles r = a- | otherwise = error $ "git ls-files is unsafe to run on repository " ++ repoDescribe r+ | otherwise = giveup $ "git ls-files is unsafe to run on repository " ++ repoDescribe r data Options = ErrorUnmatch @@ -236,7 +238,14 @@ { unmergedFile :: RawFilePath , unmergedTreeItemType :: Conflicting TreeItemType , unmergedSha :: Conflicting Sha- }+ , unmergedSiblingFile :: Maybe RawFilePath+ -- ^ Normally this is Nothing, because a+ -- merge conflict is represented as a single file with two+ -- stages. However, git resolvers sometimes choose to stage+ -- two files, one for each side of the merge conflict. In such a case,+ -- this is used for the name of the second file, which is related+ -- to the first file. (Eg, "foo" and "foo~ref")+ } deriving (Show) {- Returns a list of the files in the specified locations that have - unresolved merge conflicts.@@ -246,12 +255,12 @@ - 1 = old version, can be ignored - 2 = us - 3 = them- - If a line is omitted, that side removed the file.+ - If line 2 or 3 is omitted, that side removed the file. -} unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool) unmerged l repo = guardSafeForLsFiles repo $ do (fs, cleanup) <- pipeNullSplit params repo- return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup)+ return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL) fs, cleanup) where params = Param "ls-files" :@@ -265,7 +274,7 @@ , ifile :: RawFilePath , itreeitemtype :: Maybe TreeItemType , isha :: Maybe Sha- }+ } deriving (Show) parseUnmerged :: String -> Maybe InternalUnmerged parseUnmerged s@@ -277,7 +286,7 @@ then Nothing else do treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype)- sha <- extractSha (encodeBS' rawsha)+ sha <- extractSha (encodeBS rawsha) return $ InternalUnmerged (stage == 2) (toRawFilePath file) (Just treeitemtype) (Just sha) _ -> Nothing@@ -296,16 +305,25 @@ { unmergedFile = ifile i , unmergedTreeItemType = Conflicting treeitemtypeA treeitemtypeB , unmergedSha = Conflicting shaA shaB+ , unmergedSiblingFile = if ifile sibi == ifile i+ then Nothing+ else Just (ifile sibi) } findsib templatei [] = ([], removed templatei) findsib templatei (l:ls)- | ifile l == ifile templatei = (ls, l)+ | ifile l == ifile templatei || issibfile templatei l = (ls, l) | otherwise = (l:ls, removed templatei) removed templatei = templatei { isus = not (isus templatei) , itreeitemtype = Nothing , isha = Nothing }+ -- foo~<ref> are unmerged sibling files of foo+ -- Some versions or resolvers of git stage the sibling files,+ -- other versions or resolvers do not.+ issibfile x y = (ifile x <> "~") `S.isPrefixOf` ifile y+ && isus x || isus y+ && not (isus x && isus y) {- Gets the InodeCache equivilant information stored in the git index. -
Git/LsTree.hs view
@@ -149,7 +149,7 @@ - generated, so any size information is not included. -} formatLsTree :: TreeItem -> S.ByteString formatLsTree ti = S.intercalate (S.singleton (fromIntegral (ord ' ')))- [ encodeBS' (showOct (mode ti) "")+ [ encodeBS (showOct (mode ti) "") , typeobj ti , fromRef' (sha ti) ] <> (S.cons (fromIntegral (ord '\t')) (getTopFilePath (file ti)))
Git/Ref.hs view
@@ -64,17 +64,21 @@ {- A Ref that can be used to refer to a file in the repository, as staged - in the index.+ - + - If the input file is located outside the repository, returns Nothing. -}-fileRef :: RawFilePath -> IO Ref-fileRef f = do+fileRef :: RawFilePath -> Repo -> IO (Maybe Ref)+fileRef f repo = do -- The filename could be absolute, or contain eg "../repo/file", -- neither of which work in a ref, so convert it to a minimal -- relative path. f' <- relPathCwdToFile f- -- Prefixing the file with ./ makes this work even when in a- -- subdirectory of a repo. Eg, ./foo in directory bar refers- -- to bar/foo, not to foo in the top of the repository.- return $ Ref $ ":./" <> toInternalGitPath f'+ return $ if repoPath repo `dirContains` f'+ -- Prefixing the file with ./ makes this work even when in a+ -- subdirectory of a repo. Eg, ./foo in directory bar refers+ -- to bar/foo, not to foo in the top of the repository.+ then Just $ Ref $ ":./" <> toInternalGitPath f'+ else Nothing {- A Ref that can be used to refer to a file in a particular branch. -} branchFileRef :: Branch -> RawFilePath -> Ref@@ -82,14 +86,17 @@ {- Converts a Ref to refer to the content of the Ref on a given date. -} dateRef :: Ref -> RefDate -> Ref-dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS' d+dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS d {- A Ref that can be used to refer to a file in the repository as it- - appears in a given Ref. -}-fileFromRef :: Ref -> RawFilePath -> IO Ref-fileFromRef r f = do- (Ref fr) <- fileRef f- return (Ref (fromRef' r <> fr))+ - appears in a given Ref. + -+ - If the file path is located outside the repository, returns Nothing.+ -}+fileFromRef :: Ref -> RawFilePath -> Repo -> IO (Maybe Ref)+fileFromRef r f repo = fileRef f repo >>= return . \case+ Just (Ref fr) -> Just (Ref (fromRef' r <> fr))+ Nothing -> Nothing {- Checks if a ref exists. Note that it must be fully qualified, - eg refs/heads/master rather than master. -}@@ -177,7 +184,7 @@ [ Param "rev-parse" , Param "--verify" , Param "--quiet"- , Param (decodeBS' ref')+ , Param (decodeBS ref') ] where ref' = if ":" `S.isInfixOf` ref
Git/Remote.hs view
@@ -37,7 +37,7 @@ remoteKeyToRemoteName (ConfigKey k) | "remote." `S.isPrefixOf` k = let n = S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k- in if S.null n then Nothing else Just (decodeBS' n)+ in if S.null n then Nothing else Just (decodeBS n) | otherwise = Nothing {- Construct a legal git remote name out of an arbitrary input string.@@ -90,7 +90,7 @@ | null insteadofs = l | otherwise = replacement ++ drop (S.length bestvalue) l where- replacement = decodeBS' $ S.drop (S.length prefix) $+ replacement = decodeBS $ S.drop (S.length prefix) $ S.take (S.length bestkey - S.length suffix) bestkey (bestkey, bestvalue) = case maximumBy longestvalue insteadofs of
Git/Repair.hs view
@@ -114,7 +114,7 @@ | not (foundBroken missing) = return missing | otherwise = withTmpDir "tmprepo" $ \tmpdir -> do unlessM (boolSystem "git" [Param "init", File tmpdir]) $- error $ "failed to create temp repository in " ++ tmpdir+ giveup $ "failed to create temp repository in " ++ tmpdir tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir) let repoconfig r' = fromRawFilePath (localGitDir r' P.</> "config") whenM (doesFileExist (repoconfig r)) $@@ -252,7 +252,7 @@ getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do let topsegs = length (splitPath refdir) - 1- let toref = Ref . encodeBS' . joinPath . drop topsegs . splitPath+ let toref = Ref . encodeBS . joinPath . drop topsegs . splitPath map toref <$> dirContentsRecursive refdir explodePackedRefsFile :: Repo -> IO ()@@ -279,8 +279,8 @@ parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of (sha:ref:[])- | isJust (extractSha (encodeBS' sha)) && Ref.legal True ref ->- Just (Ref (encodeBS' sha), Ref (encodeBS' ref))+ | isJust (extractSha (encodeBS sha)) && Ref.legal True ref ->+ Just (Ref (encodeBS sha), Ref (encodeBS ref)) _ -> Nothing {- git-branch -d cannot be used to remove a branch that is directly@@ -325,7 +325,11 @@ - 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- - uncorrupted commit. -}+ - uncorrupted commit.+ -+ - When the sha is not a commit but some other git object, returns+ - true, but does not add it to the set.+ -} verifyCommit :: MissingObjects -> GoodCommits -> Sha -> Repo -> IO (Bool, GoodCommits) verifyCommit missing goodcommits commit r | checkGoodCommit commit goodcommits = return (True, goodcommits)@@ -337,21 +341,28 @@ , Param (fromRef commit) ] r let committrees = map (parse . decodeBL) ls- if any isNothing committrees || null committrees- then do- void cleanup- return (False, goodcommits)- else do- let cts = catMaybes committrees- ifM (cleanup <&&> check cts)- ( return (True, addGoodCommits (map fst cts) goodcommits)- , return (False, goodcommits)- )+ -- git log on an object that is not a commit will+ -- succeed without any output+ if null committrees+ then ifM cleanup+ ( return (True, goodcommits)+ , return (False, goodcommits)+ )+ else if any isNothing committrees+ then do+ void cleanup+ return (False, goodcommits)+ else do+ let cts = catMaybes committrees+ ifM (cleanup <&&> check cts)+ ( return (True, addGoodCommits (map fst cts) goodcommits)+ , return (False, goodcommits)+ ) where parse l = case words l of (commitsha:treesha:[]) -> (,)- <$> extractSha (encodeBS' commitsha)- <*> extractSha (encodeBS' treesha)+ <$> extractSha (encodeBS commitsha)+ <*> extractSha (encodeBS treesha) _ -> Nothing check [] = return True check ((c, t):rest)@@ -469,14 +480,14 @@ where headfile = localGitDir g P.</> "HEAD" validhead s = "ref: refs/" `isPrefixOf` s- || isJust (extractSha (encodeBS' s))+ || isJust (extractSha (encodeBS s)) {- Put it all together. -} runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch]) runRepair removablebranch forced g = do preRepair g putStrLn "Running git fsck ..."- fsckresult <- findBroken False g+ fsckresult <- findBroken False False g if foundBroken fsckresult then do putStrLn "Fsck found problems, attempting repair."@@ -500,7 +511,7 @@ runRepair' :: (Ref -> Bool) -> FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) runRepair' removablebranch fsckresult forced referencerepo g = do cleanCorruptObjects fsckresult g- missing <- findBroken False g+ missing <- findBroken False False g stillmissing <- retrieveMissingObjects missing referencerepo g case stillmissing of FsckFoundMissing s t@@ -529,7 +540,7 @@ | forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex g) ( do cleanCorruptObjects FsckFailed g- stillmissing' <- findBroken False g+ stillmissing' <- findBroken False False g case stillmissing' of FsckFailed -> return (False, []) FsckFoundMissing s t -> forcerepair s t@@ -575,7 +586,7 @@ -- the repair process. if fscktruncated then do- fsckresult' <- findBroken False g+ fsckresult' <- findBroken False False g case fsckresult' of FsckFailed -> do putStrLn "git fsck is failing"@@ -597,7 +608,7 @@ removeWhenExistsWith R.removeLink (indexFile g) -- The corrupted index can prevent fsck from finding other -- problems, so re-run repair.- fsckresult' <- findBroken False g+ fsckresult' <- findBroken False False g result <- runRepairOf fsckresult' removablebranch 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 result
Git/Types.hs view
@@ -75,7 +75,7 @@ def = ConfigValue mempty fromConfigKey :: ConfigKey -> String-fromConfigKey (ConfigKey s) = decodeBS' s+fromConfigKey (ConfigKey s) = decodeBS s instance Show ConfigKey where show = fromConfigKey@@ -88,16 +88,16 @@ fromConfigValue NoConfigValue = mempty instance FromConfigValue String where- fromConfigValue = decodeBS' . fromConfigValue+ fromConfigValue = decodeBS . fromConfigValue instance Show ConfigValue where show = fromConfigValue instance IsString ConfigKey where- fromString = ConfigKey . encodeBS'+ fromString = ConfigKey . encodeBS instance IsString ConfigValue where- fromString = ConfigValue . encodeBS'+ fromString = ConfigValue . encodeBS type RemoteName = String @@ -106,7 +106,7 @@ deriving (Eq, Ord, Read, Show) fromRef :: Ref -> String-fromRef = decodeBS' . fromRef'+fromRef = decodeBS . fromRef' fromRef' :: Ref -> S.ByteString fromRef' (Ref s) = s
Git/UpdateIndex.hs view
@@ -80,14 +80,14 @@ mapM_ streamer s void $ cleanup where- params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x]+ params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS 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", decodeBS' x, p]+ params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x, p] {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -}
Utility/Data.hs view
@@ -1,6 +1,6 @@ {- utilities for simple data types -- - Copyright 2013 Joey Hess <id@joeyh.name>+ - Copyright 2013-2021 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -10,8 +10,12 @@ module Utility.Data ( firstJust, eitherToMaybe,+ s2w8,+ w82s, ) where +import Data.Word+ {- First item in the list that is not Nothing. -} firstJust :: Eq a => [Maybe a] -> Maybe a firstJust ms = case dropWhile (== Nothing) ms of@@ -20,3 +24,15 @@ eitherToMaybe :: Either a b -> Maybe b eitherToMaybe = either (const Nothing) Just++c2w8 :: Char -> Word8+c2w8 = fromIntegral . fromEnum++w82c :: Word8 -> Char+w82c = toEnum . fromIntegral++s2w8 :: String -> [Word8]+s2w8 = map c2w8++w82s :: [Word8] -> String+w82s = map w82c
Utility/Debug.hs view
@@ -34,7 +34,7 @@ deriving (Eq, Show) instance IsString DebugSource where- fromString = DebugSource . encodeBS'+ fromString = DebugSource . encodeBS -- | Selects whether to display a message from a source. data DebugSelector @@ -97,6 +97,6 @@ formatDebugMessage :: DebugSource -> String -> IO S.ByteString formatDebugMessage (DebugSource src) msg = do- t <- encodeBS' . formatTime defaultTimeLocale "[%F %X%Q]"+ t <- encodeBS . formatTime defaultTimeLocale "[%F %X%Q]" <$> getZonedTime return (t <> " (" <> src <> ") " <> encodeBS msg)
Utility/FileSystemEncoding.hs view
@@ -1,6 +1,6 @@ {- GHC File system encoding handling. -- - Copyright 2012-2016 Joey Hess <id@joeyh.name>+ - Copyright 2012-2021 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -11,7 +11,6 @@ module Utility.FileSystemEncoding ( useFileSystemEncoding, fileEncoding,- withFilePath, RawFilePath, fromRawFilePath, toRawFilePath,@@ -19,36 +18,22 @@ encodeBL, decodeBS, encodeBS,- decodeBL',- encodeBL',- decodeBS',- encodeBS', truncateFilePath,- s2w8,- w82s,- c2w8,- w82c, ) where import qualified GHC.Foreign as GHC import qualified GHC.IO.Encoding as Encoding-import Foreign.C import System.IO import System.IO.Unsafe-import Data.Word import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L+import Data.ByteString.Unsafe (unsafePackMallocCStringLen) #ifdef mingw32_HOST_OS import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.Lazy.UTF8 as L8-#else-import Data.List-import Utility.Split #endif -import Utility.Exception- {- Makes all subsequent Handles that are opened, as well as stdio Handles, - use the filesystem encoding, instead of the encoding of the current - locale.@@ -81,40 +66,10 @@ 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,- - reversing the decoding that should have been done when the FilePath- - was obtained. -}-withFilePath :: FilePath -> (CString -> IO a) -> IO a-withFilePath fp f = Encoding.getFileSystemEncoding- >>= \enc -> GHC.withCString enc fp f--{- Encodes a FilePath into a String, applying the filesystem encoding.- -- - There are very few things it makes sense to do with such an encoded- - string. It's not a legal filename; it should not be displayed.- - So this function is not exported, but instead used by the few functions- - that can usefully consume it.- -- - This use of unsafePerformIO is belived to be safe; GHC's interface- - only allows doing this conversion with CStrings, and the CString buffer- - is allocated, used, and deallocated within the call, with no side- - effects.- -- - If the FilePath contains a value that is not legal in the filesystem- - encoding, rather than thowing an exception, it will be returned as-is.- -}-{-# NOINLINE _encodeFilePath #-}-_encodeFilePath :: FilePath -> String-_encodeFilePath fp = unsafePerformIO $ do- enc <- Encoding.getFileSystemEncoding- GHC.withCString enc fp (GHC.peekCString Encoding.char8)- `catchNonAsync` (\_ -> return fp)- {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} decodeBL :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS-decodeBL = encodeW8NUL . L.unpack+decodeBL = decodeBS . L.toStrict #else {- On Windows, we assume that the ByteString is utf-8, since Windows - only uses unicode for filenames. -}@@ -124,104 +79,45 @@ {- Encodes a FilePath into a ByteString, applying the filesystem encoding. -} encodeBL :: FilePath -> L.ByteString #ifndef mingw32_HOST_OS-encodeBL = L.pack . decodeW8NUL+encodeBL = L.fromStrict . encodeBS #else encodeBL = L8.fromString #endif decodeBS :: S.ByteString -> FilePath #ifndef mingw32_HOST_OS-decodeBS = encodeW8NUL . S.unpack+-- This does the same thing as System.FilePath.ByteString.decodeFilePath,+-- with an identical implementation. However, older versions of that library+-- truncated at NUL, which this must not do, because it may end up used on+-- something other than a unix filepath.+{-# NOINLINE decodeBS #-}+decodeBS b = unsafePerformIO $ do+ enc <- Encoding.getFileSystemEncoding+ S.useAsCStringLen b (GHC.peekCStringLen enc) #else decodeBS = S8.toString #endif encodeBS :: FilePath -> S.ByteString #ifndef mingw32_HOST_OS-encodeBS = S.pack . decodeW8NUL+-- This does the same thing as System.FilePath.ByteString.encodeFilePath,+-- with an identical implementation. However, older versions of that library+-- truncated at NUL, which this must not do, because it may end up used on+-- something other than a unix filepath.+{-# NOINLINE encodeBS #-}+encodeBS f = unsafePerformIO $ do+ enc <- Encoding.getFileSystemEncoding+ GHC.newCStringLen enc f >>= unsafePackMallocCStringLen #else encodeBS = S8.fromString #endif -{- Faster version that assumes the string does not contain NUL;- - if it does it will be truncated before the NUL. -}-decodeBS' :: S.ByteString -> FilePath-#ifndef mingw32_HOST_OS-decodeBS' = encodeW8 . S.unpack-#else-decodeBS' = S8.toString-#endif--encodeBS' :: FilePath -> S.ByteString-#ifndef mingw32_HOST_OS-encodeBS' = S.pack . decodeW8-#else-encodeBS' = S8.fromString-#endif--decodeBL' :: L.ByteString -> FilePath-#ifndef mingw32_HOST_OS-decodeBL' = encodeW8 . L.unpack-#else-decodeBL' = L8.toString-#endif--encodeBL' :: FilePath -> L.ByteString-#ifndef mingw32_HOST_OS-encodeBL' = L.pack . decodeW8-#else-encodeBL' = L8.fromString-#endif- fromRawFilePath :: RawFilePath -> FilePath fromRawFilePath = decodeFilePath toRawFilePath :: FilePath -> RawFilePath toRawFilePath = encodeFilePath -#ifndef mingw32_HOST_OS-{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.- -- - w82s produces a String, which may contain Chars that are invalid- - unicode. From there, this is really a simple matter of applying the- - file system encoding, only complicated by GHC's interface to doing so.- -- - Note that the encoding stops at any NUL in the input. FilePaths- - cannot contain embedded NUL, but Haskell Strings may.- -}-{-# NOINLINE encodeW8 #-}-encodeW8 :: [Word8] -> FilePath-encodeW8 w8 = unsafePerformIO $ do- enc <- Encoding.getFileSystemEncoding- GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc--decodeW8 :: FilePath -> [Word8]-decodeW8 = s2w8 . _encodeFilePath--{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -}-encodeW8NUL :: [Word8] -> FilePath-encodeW8NUL = intercalate [nul] . map encodeW8 . splitc (c2w8 nul)- where- nul = '\NUL'--decodeW8NUL :: FilePath -> [Word8]-decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul- where- nul = '\NUL'-#endif--c2w8 :: Char -> Word8-c2w8 = fromIntegral . fromEnum--w82c :: Word8 -> Char-w82c = toEnum . fromIntegral--s2w8 :: String -> [Word8]-s2w8 = map c2w8--w82s :: [Word8] -> String-w82s = map w82c- {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. -@@ -233,8 +129,8 @@ truncateFilePath n = go . reverse where go f =- let bytes = decodeW8 f- in if length bytes <= n+ let b = encodeBS f+ in if S.length b <= n then reverse f else go (drop 1 f) #else
Utility/HumanNumber.hs view
@@ -1,6 +1,6 @@ {- numbers for humans -- - Copyright 2012-2013 Joey Hess <id@joeyh.name>+ - Copyright 2012-2021 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -11,11 +11,15 @@ - of decimal digits. -} showImprecise :: RealFrac a => Int -> a -> String showImprecise precision n- | precision == 0 || remainder == 0 = show (round n :: Integer)- | otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder)+ | precision == 0 || remainder' == 0 = show (round n :: Integer)+ | otherwise = show int' ++ "." ++ striptrailing0s (pad0s $ show remainder') where int :: Integer (int, frac) = properFraction n remainder = round (frac * 10 ^ precision) :: Integer+ (int', remainder')+ -- carry the 1+ | remainder == 10 ^ precision = (int + 1, 0)+ | otherwise = (int, remainder) pad0s s = replicate (precision - length s) '0' ++ s striptrailing0s = reverse . dropWhile (== '0') . reverse
Utility/InodeCache.hs view
@@ -55,7 +55,7 @@ #ifdef mingw32_HOST_OS import Data.Word (Word64) #else-import System.Posix.Files+import qualified System.Posix.Files as Posix #endif data InodeCachePrim = InodeCachePrim FileID FileSize MTime@@ -200,7 +200,7 @@ #ifdef mingw32_HOST_OS mtime <- utcTimeToPOSIXSeconds <$> getModificationTime (fromRawFilePath f) #else- let mtime = modificationTimeHiRes s+ let mtime = Posix.modificationTimeHiRes s #endif return $ Just $ InodeCache $ InodeCachePrim inode sz (MTimeHighRes (mtime + highResTime delta)) | otherwise = pure Nothing@@ -299,11 +299,6 @@ [ (50, MTimeLowRes <$> (abs . fromInteger <$> arbitrary)) , (50, MTimeHighRes <$> arbitrary) ]--#ifdef mingw32_HOST_OS-instance Arbitrary FileID where- arbitrary = fromIntegral <$> (arbitrary :: Gen Word64)-#endif prop_read_show_inodecache :: InodeCache -> Bool prop_read_show_inodecache c = case readInodeCache (showInodeCache c) of
Utility/Metered.hs view
@@ -37,6 +37,7 @@ demeterCommandEnv, avoidProgress, rateLimitMeterUpdate,+ bwLimitMeterUpdate, Meter, mkMeter, setMeterTotalSize,@@ -51,6 +52,7 @@ import Utility.DataUnits import Utility.HumanTime import Utility.SimpleProtocol as Proto+import Utility.ThreadScheduler import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S@@ -380,6 +382,46 @@ meterupdate n else putMVar lastupdate prev +-- | Bandwidth limiting by inserting a delay at the point that a meter is+-- updated.+--+-- This will only work when the actions that use bandwidth are run in the+-- same process and thread as the call to the MeterUpdate.+--+-- For example, if the desired bandwidth is 100kb/s, and over the past+-- 1/10th of a second, 30kb was sent, then the current bandwidth is+-- 300kb/s, 3x as fast as desired. So, after getting the next chunk,+-- pause for twice as long as it took to get it.+bwLimitMeterUpdate :: ByteSize -> Duration -> MeterUpdate -> IO MeterUpdate+bwLimitMeterUpdate bwlimit duration meterupdate+ | bwlimit <= 0 = return meterupdate+ | otherwise = do+ nowtime <- getPOSIXTime+ mv <- newMVar (nowtime, Nothing)+ return (mu mv)+ where+ mu mv n@(BytesProcessed i) = do+ endtime <- getPOSIXTime+ (starttime, mprevi) <- takeMVar mv++ case mprevi of+ Just previ -> do+ let runtime = endtime - starttime+ let currbw = fromIntegral (i - previ) / runtime+ let pausescale = if currbw > bwlimit'+ then (currbw / bwlimit') - 1+ else 0+ unboundDelay (floor (runtime * pausescale * msecs))+ Nothing -> return ()++ meterupdate n++ nowtime <- getPOSIXTime+ putMVar mv (nowtime, Just i)++ bwlimit' = fromIntegral (bwlimit * durationSeconds duration) + msecs = fromIntegral oneSecond+ data Meter = Meter (MVar (Maybe TotalSize)) (MVar MeterState) (MVar String) DisplayMeter data MeterState = MeterState@@ -417,12 +459,14 @@ -- | Display meter to a Handle. displayMeterHandle :: Handle -> RenderMeter -> DisplayMeter displayMeterHandle h rendermeter v msize old new = do+ olds <- takeMVar v let s = rendermeter msize old new- olds <- swapMVar v s+ let padding = replicate (length olds - length s) ' '+ let s' = s <> padding+ putMVar v s' -- Avoid writing when the rendered meter has not changed.- when (olds /= s) $ do- let padding = replicate (length olds - length s) ' '- hPutStr h ('\r':s ++ padding)+ when (olds /= s') $ do+ hPutStr h ('\r':s') hFlush h -- | Clear meter displayed by displayMeterHandle. May be called before
Utility/Path.hs view
@@ -95,13 +95,49 @@ dirContains :: RawFilePath -> RawFilePath -> Bool dirContains a b = a == b || a' == b'- || (addTrailingPathSeparator a') `B.isPrefixOf` b'- || a' == "." && normalise ("." </> b') == b'+ || (a'' `B.isPrefixOf` b' && avoiddotdotb)+ || a' == "." && normalise ("." </> b') == b' && nodotdot b'+ || dotdotcontains where a' = norm a+ a'' = addTrailingPathSeparator a' b' = norm b norm = normalise . simplifyPath + {- This handles the case where a is ".." and b is "../..",+ - which is not inside a. Similarly, "../.." does not contain+ - "../../../". Due to the use of norm, cases like + - "../../foo/../../" get converted to eg "../../.." and+ - so do not need to be handled specially here.+ -+ - When this is called, we already know that + - a'' is a prefix of b', so all that needs to be done is drop+ - that prefix, and check if the next path component is ".."+ -}+ avoiddotdotb = nodotdot $ B.drop (B.length a'') b'++ nodotdot p = all (not . isdotdot) (splitPath p)+ + isdotdot s = dropTrailingPathSeparator s == ".."++ {- This handles the case where a is ".." or "../.." etc,+ - and b is "foo" or "../foo" etc. The rule is that when+ - a is entirely ".." components, b is under it when it starts+ - with fewer ".." components. + - + - Due to the use of norm, cases like "../../foo/../../" get+ - converted to eg "../../../" and so do not need to be handled+ - specially here.+ -}+ dotdotcontains+ | isAbsolute b' = False+ | otherwise = + let aps = splitPath a'+ bps = splitPath b'+ in if all isdotdot aps+ then length (takeWhile isdotdot bps) < length aps+ else False+ {- Given an original list of paths, and an expanded list derived from it, - which may be arbitrarily reordered, generates a list of lists, where - each sublist corresponds to one of the original paths.@@ -187,7 +223,13 @@ dotdots = replicate (length pfrom - numcommon) ".." numcommon = length common #ifdef mingw32_HOST_OS- normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive+ normdrive = map toLower+ -- Get just the drive letter, removing any leading+ -- path separator, which takeDrive leaves on the drive+ -- letter.+ . dropWhileEnd (isPathSeparator . fromIntegral . ord)+ . fromRawFilePath + . takeDrive #endif {- Checks if a command is available in PATH.
Utility/Tmp.hs view
@@ -14,6 +14,7 @@ withTmpFile, withTmpFileIn, relatedTemplate,+ openTmpFileIn, ) where import System.IO@@ -21,6 +22,7 @@ import System.Directory import Control.Monad.IO.Class import System.PosixCompat.Files hiding (removeLink)+import System.IO.Error import Utility.Exception import Utility.FileSystemEncoding@@ -28,6 +30,18 @@ type Template = String +{- This is the same as openTempFile, except when there is an+ - error, it displays the template as well as the directory,+ - to help identify what call was responsible.+ -}+openTmpFileIn :: FilePath -> String -> IO (FilePath, Handle)+openTmpFileIn dir template = openTempFile dir template+ `catchIO` decoraterrror+ where+ decoraterrror e = throwM $+ let loc = ioeGetLocation e ++ " template " ++ template+ in annotateIOError e loc Nothing Nothing+ {- Runs an action like writeFile, writing to a temp file first and - then moving it into place. The temp file is stored in the same - directory as the final file to avoid cross-device renames.@@ -43,7 +57,7 @@ template = relatedTemplate (base ++ ".tmp") setup = do createDirectoryIfMissing True dir- openTempFile dir template+ openTmpFileIn dir template cleanup (tmpfile, h) = do _ <- tryIO $ hClose h tryIO $ removeFile tmpfile@@ -73,7 +87,7 @@ withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use where- create = liftIO $ openTempFile tmpdir template+ create = liftIO $ openTmpFileIn tmpdir template remove (name, h) = liftIO $ do hClose h catchBoolIO (removeFile name >> return True)
Utility/Tmp/Dir.hs view
@@ -1,6 +1,6 @@ {- Temporary directories -- - Copyright 2010-2013 Joey Hess <id@joeyh.name>+ - Copyright 2010-2022 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -63,8 +63,10 @@ -- after a process has just written to it and exited. -- Because it's crap, presumably. So, ignore failure -- to delete the temp directory.- _ <- tryIO $ removeDirectoryRecursive tmpdir+ _ <- tryIO $ go tmpdir return () #else- removeDirectoryRecursive tmpdir+ go tmpdir #endif+ where+ go = removeDirectoryRecursive
git-repair.cabal view
@@ -1,11 +1,11 @@ Name: git-repair-Version: 1.20210629+Version: 1.20220404 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <joey@kitenet.net> Author: Joey Hess Stability: Stable-Copyright: 2013-2021 Joey Hess+Copyright: 2013-2022 Joey Hess License-File: COPYRIGHT Build-Type: Custom Homepage: http://git-repair.branchable.com/@@ -26,9 +26,9 @@ git-repair.1 custom-setup- Setup-Depends: base (>= 4.11.1.0 && < 5.0), + Setup-Depends: base (>= 4.11.1.0), hslogger, split, unix-compat, process, unix, filepath,- filepath-bytestring (>= 1.4.2.1.1), async,+ filepath-bytestring (>= 1.4.2.1.4), async, exceptions, bytestring, directory, IfElse, data-default, mtl, Cabal, time @@ -47,7 +47,7 @@ utf8-string, async, optparse-applicative (>= 0.14.1), data-default, deepseq, attoparsec, network-uri (>= 2.6), network (>= 2.6),- filepath-bytestring (>= 1.4.2.1.0),+ filepath-bytestring (>= 1.4.2.1.4), time if (os(windows))
git-repair.hs view
@@ -100,7 +100,7 @@ case repairstatus of Just True -> testResult repairstatus . Just . not . Git.Fsck.foundBroken- =<< Git.Fsck.findBroken False g+ =<< Git.Fsck.findBroken False False g _ -> testResult repairstatus Nothing -- Pass test result and fsck result