From c244daa32328f478bbf38a79f2fcacb138a1049f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 4 May 2022 11:40:38 -0400 Subject: merge from git-annex --- Git/Branch.hs | 19 +++++++++++++----- Git/CatFile.hs | 57 +++++++++++++++++++++++++++++++++++------------------- Git/Command.hs | 2 +- Git/Config.hs | 16 +++++++++++---- Git/Construct.hs | 5 ++++- Git/LsFiles.hs | 32 +++++++++++++++++++++++------- Git/LsTree.hs | 2 +- Git/Ref.hs | 33 ++++++++++++++++++------------- Git/Remote.hs | 4 ++-- Git/Types.hs | 10 +++++----- Git/UpdateIndex.hs | 4 ++-- 11 files changed, 123 insertions(+), 61 deletions(-) (limited to 'Git') diff --git a/Git/Branch.hs b/Git/Branch.hs index 54af101..f30e357 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -121,6 +121,13 @@ fastForward branch (first:rest) repo = (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 @@ applyCommitModeForCommitTree commitmode ps r 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 @@ commitCommand' runner commitmode ps = runner $ - 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 diff --git a/Git/CatFile.hs b/Git/CatFile.hs index b9f8305..f33ad49 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,6 +1,6 @@ {- git cat-file interface - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2021 Joey Hess - - 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,8 +59,12 @@ import Utility.Tuple 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 @@ -64,22 +72,31 @@ catFileStart = catFileStart' True catFileStart' :: Bool -> Repo -> IO CatFileHandle catFileStart' restartable repo = CatFileHandle - <$> startp "--batch" - <*> startp ("--batch-check=" ++ batchFormat) + <$> startcat restartable repo "--batch" + <*> pure 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 - where - startp p = gitCoProcessStart restartable - [ Param "cat-file" - , Param p - ] 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 @@ -106,16 +123,16 @@ catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \f 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 h (ParsedResp _ _ size) = do 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 @@ catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ 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 diff --git a/Git/Command.hs b/Git/Command.hs index 2358b17..894f6ae 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -39,7 +39,7 @@ runBool params repo = assertLocal repo $ 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 () diff --git a/Git/Config.hs b/Git/Config.hs index 20ddf79..5deba6b 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -170,7 +170,7 @@ parse s st {- 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 @@ fromFile r f = fromPipe r "git" , 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 @@ changeFile f (ConfigKey k) v = boolSystem "git" [ 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 @@ unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r) , return Nothing ) where - ps = [Param "config", Param "--unset-all", Param (decodeBS' k)] + ps = [Param "config", Param "--unset-all", Param (decodeBS k)] diff --git a/Git/Construct.hs b/Git/Construct.hs index c013eb2..a5e825e 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -184,7 +184,10 @@ expandTilde :: FilePath -> IO FilePath #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 diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 297c068..cc824f2 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.LsFiles ( Options(..), inRepo, @@ -66,7 +68,7 @@ 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 + | otherwise = giveup $ "git ls-files is unsafe to run on repository " ++ repoDescribe r data Options = ErrorUnmatch @@ -236,7 +238,14 @@ data Unmerged = Unmerged { 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 @@ data Unmerged = Unmerged - 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 @@ data InternalUnmerged = InternalUnmerged , ifile :: RawFilePath , itreeitemtype :: Maybe TreeItemType , isha :: Maybe Sha - } + } deriving (Show) parseUnmerged :: String -> Maybe InternalUnmerged parseUnmerged s @@ -277,7 +286,7 @@ parseUnmerged s 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 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest { 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~ 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. - diff --git a/Git/LsTree.hs b/Git/LsTree.hs index a49c4ea..fb3b3e1 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -149,7 +149,7 @@ parserLsTree long = case long of - 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))) diff --git a/Git/Ref.hs b/Git/Ref.hs index 6929a8e..2d2874a 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -64,17 +64,21 @@ branchRef = underBase "refs/heads" {- 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 @@ branchFileRef branch f = Ref $ fromRef' branch <> ":" <> toInternalGitPath f {- 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 @@ tree (Ref ref) = extractSha <$$> pipeReadStrict [ Param "rev-parse" , Param "--verify" , Param "--quiet" - , Param (decodeBS' ref') + , Param (decodeBS ref') ] where ref' = if ":" `S.isInfixOf` ref diff --git a/Git/Remote.hs b/Git/Remote.hs index 8f5d99f..80accca 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -37,7 +37,7 @@ remoteKeyToRemoteName :: ConfigKey -> Maybe RemoteName 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 @@ parseRemoteLocation s repo = ret $ calcloc s | 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 diff --git a/Git/Types.hs b/Git/Types.hs index db1c71b..68045fc 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -75,7 +75,7 @@ instance Default ConfigValue where 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 @@ instance FromConfigValue S.ByteString where 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 @@ newtype Ref = Ref S.ByteString deriving (Eq, Ord, Read, Show) fromRef :: Ref -> String -fromRef = decodeBS' . fromRef' +fromRef = decodeBS . fromRef' fromRef' :: Ref -> S.ByteString fromRef' (Ref s) = s diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 8e406b1..74816a6 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -80,14 +80,14 @@ lsTree (Ref x) repo streamer = do 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. -} -- cgit v1.2.3