From 7347e501239fda9eae0ca0a0fca8a76500c5327f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 8 Jul 2020 14:54:29 -0400 Subject: [PATCH] add stage number to stagedDetails parser And convert parser to attoparsec, probably faster. Before, a parse failure threw the whole --stage output line in to the filename, which was certianly a bad idea, so fixed that. --- Annex/View.hs | 6 +++--- Git/LsFiles.hs | 45 ++++++++++++++++++++++++++++++++------------- Git/Repair.hs | 11 ++++------- Logs/Web.hs | 5 ++--- Upgrade/V5.hs | 2 +- 5 files changed, 42 insertions(+), 27 deletions(-) diff --git a/Annex/View.hs b/Annex/View.hs index 8a07099a31..19c593858e 100644 --- a/Annex/View.hs +++ b/Annex/View.hs @@ -349,9 +349,9 @@ applyView' mkviewedfile getfilemetadata view = do liftIO . nukeFile =<< fromRepo gitAnnexViewIndex viewg <- withViewIndex gitRepo withUpdateIndex viewg $ \uh -> do - forM_ l $ \(f, sha, mode) -> do + forM_ l $ \(f, sha, mode, _) -> do topf <- inRepo (toTopFilePath f) - go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f + go uh topf sha (toTreeItemType mode) =<< lookupFile f liftIO $ void clean genViewBranch view where @@ -365,7 +365,7 @@ applyView' mkviewedfile getfilemetadata view = do f' <- fromRawFilePath <$> fromRepo (fromTopFilePath $ asTopFilePath $ toRawFilePath fv) stagesymlink uh f' =<< calcRepo (gitAnnexLink f' k) - go uh topf (Just sha) (Just treeitemtype) Nothing + go uh topf sha (Just treeitemtype) Nothing | "." `B.isPrefixOf` getTopFilePath topf = liftIO $ Git.UpdateIndex.streamUpdateIndex' uh $ pureStreamer $ updateIndexLine sha treeitemtype topf diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 2ba0ec7dde..d74c00121f 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -16,6 +16,8 @@ module Git.LsFiles ( modified, staged, stagedNotDeleted, + usualStageNum, + mergeConflictHeadStageNum, stagedDetails, typeChanged, typeChangedStaged, @@ -33,12 +35,13 @@ import Git.Types import Git.Sha import Utility.InodeCache import Utility.TimeStamp +import Utility.Attoparsec -import Numeric -import Data.Char import System.Posix.Types import qualified Data.Map as M import qualified Data.ByteString as S +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 {- It's only safe to use git ls-files on the current repo, not on a remote. - @@ -136,12 +139,23 @@ staged' ps l repo = guardSafeForLsFiles repo $ prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] suffix = Param "--" : map (File . fromRawFilePath) l -type StagedDetails = (RawFilePath, Maybe Sha, Maybe FileMode) +type StagedDetails = (RawFilePath, Sha, FileMode, StageNum) + +type StageNum = Int + +{- Used when not in a merge conflict. -} +usualStageNum :: Int +usualStageNum = 0 + +{- WHen in a merge conflict, git uses stage number 2 for the local HEAD + - side of the merge conflict. -} +mergeConflictHeadStageNum :: Int +mergeConflictHeadStageNum = 2 {- Returns details about all files that are staged in the index. - - Note that, during a conflict, a file will appear in the list - - more than once. + - more than once with different stage numbers. -} stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails = stagedDetails' [] @@ -149,20 +163,25 @@ stagedDetails = stagedDetails' [] stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails' ps l repo = guardSafeForLsFiles repo $ do (ls, cleanup) <- pipeNullSplit' params repo - return (map parseStagedDetails ls, cleanup) + return (mapMaybe parseStagedDetails ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ Param "--" : map (File . fromRawFilePath) l -parseStagedDetails :: S.ByteString -> StagedDetails -parseStagedDetails s - | S.null file = (s, Nothing, Nothing) - | otherwise = (file, extractSha sha, readmode mode) +parseStagedDetails :: S.ByteString -> Maybe StagedDetails +parseStagedDetails = eitherToMaybe . A.parseOnly parser where - (metadata, file) = separate' (== fromIntegral (ord '\t')) s - (mode, metadata') = separate' (== fromIntegral (ord ' ')) metadata - (sha, _) = separate' (== fromIntegral (ord ' ')) metadata' - readmode = fst <$$> headMaybe . readOct . decodeBS' + parser = do + mode <- octal + void $ A8.char ' ' + sha <- maybe (fail "bad sha") return . extractSha =<< nextword + void $ A8.char ' ' + stagenum <- A8.decimal + void $ A8.char '\t' + file <- A.takeByteString + return (file, sha, mode, stagenum) + + nextword = A8.takeTill (== ' ') {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} diff --git a/Git/Repair.hs b/Git/Repair.hs index f81aa786fc..cba9c6704d 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -38,7 +38,6 @@ import qualified Git.Branch as Branch import Utility.Tmp.Dir import Utility.Rsync import Utility.FileMode -import Utility.Tuple import qualified Data.Set as S import qualified Data.ByteString.Lazy as L @@ -379,9 +378,8 @@ missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) "ind partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) partitionIndex r = do (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r - l <- forM indexcontents $ \i -> case i of - (_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i - _ -> pure (False, i) + l <- forM indexcontents $ \i@(_file, sha, _mode, _stagenum) -> + (,) <$> isMissing sha r <*> pure i let (bad, good) = partition fst l return (map snd bad, map snd good, cleanup) @@ -397,13 +395,12 @@ rewriteIndex r UpdateIndex.streamUpdateIndex r =<< (catMaybes <$> mapM reinject good) void cleanup - return $ map (fromRawFilePath . fst3) bad + return $ map (\(file,_, _, _) -> fromRawFilePath file) bad where - reinject (file, Just sha, Just mode) = case toTreeItemType mode of + reinject (file, sha, mode, _) = case toTreeItemType mode of Nothing -> return Nothing Just treeitemtype -> Just <$> UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r - reinject _ = return Nothing newtype GoodCommits = GoodCommits (S.Set Sha) diff --git a/Logs/Web.hs b/Logs/Web.hs index c96a327245..77edc43358 100644 --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -99,11 +99,10 @@ knownUrls = do void $ liftIO cleanup return $ concat r where - getkeyurls (f, s, _) = case urlLogFileKey f of + getkeyurls (f, s, _, _) = case urlLogFileKey f of Just k -> zip (repeat k) <$> geturls s Nothing -> return [] - geturls Nothing = return [] - geturls (Just logsha) = + geturls logsha = map (decodeBS . fromLogInfo) . getLog <$> catObject logsha diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs index 7ce66003d8..31463d187e 100644 --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -114,7 +114,7 @@ upgradeDirectWorkTree = do forM_ l go void $ liftIO clean where - go (f, Just _sha, Just mode) | isSymLink mode = do + go (f, _sha, mode, _stagenum) | isSymLink mode = do -- Cannot use lookupFile here, as we're in between direct -- mode and v6. mk <- catKeyFile f