From 8c4352a0a544b2e5a4ed717999fc7c6ecb0a328f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 4 May 2020 15:38:39 -0400 Subject: merge from git-annex * Improve fetching from a remote with an url in host:path format. * Merge from git-annex. --- Git/LsFiles.hs | 146 +++++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 116 insertions(+), 30 deletions(-) (limited to 'Git/LsFiles.hs') diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 5534307..830b5f5 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -1,6 +1,6 @@ {- git ls-files interface - - - Copyright 2010-2018 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -24,6 +24,7 @@ module Git.LsFiles ( Unmerged(..), unmerged, StagedDetails, + inodeCaches, ) where import Common @@ -31,17 +32,45 @@ import Git import Git.Command import Git.Types import Git.Sha +import Utility.InodeCache +import Utility.TimeStamp import Numeric +import Data.Char import System.Posix.Types -import qualified Data.ByteString.Lazy as L +import qualified Data.Map as M +import qualified Data.ByteString as S -{- Scans for files that are checked into git's index at the specified locations. -} +{- It's only safe to use git ls-files on the current repo, not on a remote. + - + - Git has some strange behavior when git ls-files is used with repos + - that are not the one that the cwd is in: + - git --git-dir=../foo/.git --worktree=../foo ../foo fails saying + - "../foo is outside repository". + - That does not happen when an absolute path is provided. + - + - Also, the files output by ls-files are relative to the cwd. + - Unless it's run on remote. Then it's relative to the top of the remote + - repo. + - + - So, best to avoid that class of problems. + -} +safeForLsFiles :: Repo -> Bool +safeForLsFiles r = isNothing (remoteName r) + +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 + +{- Lists files that are checked into git's index at the specified paths. + - With no paths, all files are listed. + -} inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) inRepo = inRepo' [] inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -inRepo' ps l repo = pipeNullSplit' params repo +inRepo' ps l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -53,14 +82,15 @@ inRepo' ps l repo = pipeNullSplit' params repo {- Files that are checked into the index or have been committed to a - branch. -} inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b] +inRepoOrBranch b = inRepo' [Param $ "--with-tree=" ++ fromRef b] {- Scans for files at the specified locations that are not checked into git. -} notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) notInRepo = notInRepo' [] notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -notInRepo' ps include_ignored l repo = pipeNullSplit' params repo +notInRepo' ps include_ignored l repo = guardSafeForLsFiles repo $ + pipeNullSplit' params repo where params = concat [ [ Param "ls-files", Param "--others"] @@ -81,18 +111,20 @@ notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"] {- Finds all files in the specified locations, whether checked into git or - not. -} allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -allFiles l = pipeNullSplit' $ - Param "ls-files" : - Param "--cached" : - Param "--others" : - Param "-z" : - Param "--" : - map (File . fromRawFilePath) l +allFiles l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo + where + params = + Param "ls-files" : + Param "--cached" : + Param "--others" : + Param "-z" : + Param "--" : + map (File . fromRawFilePath) l {- Returns a list of files in the specified locations that have been - deleted. -} deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -deleted l repo = pipeNullSplit' params repo +deleted l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -104,7 +136,7 @@ deleted l repo = pipeNullSplit' params repo {- Returns a list of files in the specified locations that have been - modified. -} modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -modified l repo = pipeNullSplit' params repo +modified l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -116,7 +148,7 @@ modified l repo = pipeNullSplit' params repo {- Files that have been modified or are not checked into git (and are not - ignored). -} modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -modifiedOthers l repo = pipeNullSplit' params repo +modifiedOthers l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" : @@ -137,7 +169,8 @@ stagedNotDeleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -staged' ps l repo = pipeNullSplit' (prefix ++ ps ++ suffix) repo +staged' ps l repo = guardSafeForLsFiles repo $ + pipeNullSplit' (prefix ++ ps ++ suffix) repo where prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] suffix = Param "--" : map (File . fromRawFilePath) l @@ -156,19 +189,22 @@ stagedDetails = stagedDetails' [] {- Gets details about staged files, including the Sha of their staged - contents. -} stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) -stagedDetails' ps l repo = do - (ls, cleanup) <- pipeNullSplit params repo - return (map parse ls, cleanup) +stagedDetails' ps l repo = guardSafeForLsFiles repo $ do + (ls, cleanup) <- pipeNullSplit' params repo + return (map parseStagedDetails ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ Param "--" : map (File . fromRawFilePath) l - parse s - | null file = (L.toStrict s, Nothing, Nothing) - | otherwise = (toRawFilePath file, extractSha $ take shaSize rest, readmode mode) - where - (metadata, file) = separate (== '\t') (decodeBL' s) - (mode, rest) = separate (== ' ') metadata - readmode = fst <$$> headMaybe . readOct + +parseStagedDetails :: S.ByteString -> StagedDetails +parseStagedDetails s + | S.null file = (s, Nothing, Nothing) + | otherwise = (file, extractSha sha, readmode mode) + where + (metadata, file) = separate' (== fromIntegral (ord '\t')) s + (mode, metadata') = separate' (== fromIntegral (ord ' ')) metadata + (sha, _) = separate' (== fromIntegral (ord ' ')) metadata' + readmode = fst <$$> headMaybe . readOct . decodeBS' {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} @@ -181,7 +217,7 @@ typeChanged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged = typeChanged' [] typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) -typeChanged' ps l repo = do +typeChanged' ps l repo = guardSafeForLsFiles repo $ do (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files. @@ -221,7 +257,7 @@ data Unmerged = Unmerged - If a line is omitted, that side removed the file. -} unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool) -unmerged l repo = do +unmerged l repo = guardSafeForLsFiles repo $ do (fs, cleanup) <- pipeNullSplit params repo return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup) where @@ -249,7 +285,7 @@ parseUnmerged s then Nothing else do treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype) - sha <- extractSha rawsha + sha <- extractSha (encodeBS' rawsha) return $ InternalUnmerged (stage == 2) (toRawFilePath file) (Just treeitemtype) (Just sha) _ -> Nothing @@ -278,3 +314,53 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest , itreeitemtype = Nothing , isha = Nothing } + +{- Gets the InodeCache equivilant information stored in the git index. + - + - Note that this uses a --debug option whose output could change at some + - point in the future. If the output is not as expected, will use Nothing. + -} +inodeCaches :: [RawFilePath] -> Repo -> IO ([(FilePath, Maybe InodeCache)], IO Bool) +inodeCaches locs repo = guardSafeForLsFiles repo $ do + (ls, cleanup) <- pipeNullSplit params repo + return (parse Nothing (map decodeBL ls), cleanup) + where + params = + Param "ls-files" : + Param "--cached" : + Param "-z" : + Param "--debug" : + Param "--" : + map (File . fromRawFilePath) locs + + parse Nothing (f:ls) = parse (Just f) ls + parse (Just f) (s:[]) = + let i = parsedebug s + in (f, i) : [] + parse (Just f) (s:ls) = + let (d, f') = splitdebug s + i = parsedebug d + in (f, i) : parse (Just f') ls + parse _ _ = [] + + -- First 5 lines are --debug output, remainder is the next filename. + -- This assumes that --debug does not start outputting more lines. + splitdebug s = case splitc '\n' s of + (d1:d2:d3:d4:d5:rest) -> + ( intercalate "\n" [d1, d2, d3, d4, d5] + , intercalate "\n" rest + ) + _ -> ("", s) + + -- This parser allows for some changes to the --debug output, + -- including reordering, or adding more items. + parsedebug s = do + let l = words s + let iskey v = ":" `isSuffixOf` v + let m = M.fromList $ zip + (filter iskey l) + (filter (not . iskey) l) + mkInodeCache + <$> (readish =<< M.lookup "ino:" m) + <*> (readish =<< M.lookup "size:" m) + <*> (parsePOSIXTime =<< (replace ":" "." <$> M.lookup "mtime:" m)) -- cgit v1.2.3