From edf83982be214f3c839fab9b659f645de53a9100 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 14 Aug 2023 12:06:32 -0400 Subject: merge from git-annex Support building with unix-compat 0.7 --- Git/CatFile.hs | 4 +- Git/Config.hs | 95 ++++++++++++++++++++++++++++++++--------- Git/Construct.hs | 42 +++++++++++------- Git/CurrentRepo.hs | 7 +-- Git/Destroyer.hs | 14 +++--- Git/FilePath.hs | 10 ++--- Git/Filename.hs | 49 --------------------- Git/HashObject.hs | 43 ++++++++++++++----- Git/LsFiles.hs | 2 +- Git/LsTree.hs | 4 +- Git/Quote.hs | 122 +++++++++++++++++++++++++++++++++++++++++++++++++++++ Git/Remote.hs | 20 +++++---- Git/Repair.hs | 12 +++--- Git/Sha.hs | 2 +- Git/Types.hs | 2 + Git/UpdateIndex.hs | 40 +++++++++++------- 16 files changed, 323 insertions(+), 145 deletions(-) delete mode 100644 Git/Filename.hs create mode 100644 Git/Quote.hs (limited to 'Git') diff --git a/Git/CatFile.hs b/Git/CatFile.hs index f33ad49..daa41ad 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -120,7 +120,7 @@ catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \f content <- readObjectContent from r return $ Just (content, sha, objtype) Just DNE -> return Nothing - Nothing -> error $ "unknown response from git cat-file " ++ show (header, object) + Nothing -> giveup $ "unknown response from git cat-file " ++ show (header, object) where -- Slow fallback path for filenames containing newlines. newlinefallback = queryObjectType object (catFileGitRepo h) >>= \case @@ -144,7 +144,7 @@ readObjectContent h (ParsedResp _ _ size) = do eatchar expected = do c <- hGetChar h when (c /= expected) $ - error $ "missing " ++ (show expected) ++ " from git cat-file" + giveup $ "missing " ++ (show expected) ++ " from git cat-file" readObjectContent _ DNE = error "internal" {- Gets the size and type of an object, without reading its content. -} diff --git a/Git/Config.hs b/Git/Config.hs index 5deba6b..4ff3454 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -1,6 +1,6 @@ {- git repository configuration handling - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -22,6 +22,8 @@ import Git.Types import qualified Git.Command import qualified Git.Construct import Utility.UserInfo +import Utility.Process.Transcript +import Utility.Debug {- Returns a single git config setting, or a fallback value if not set. -} get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue @@ -55,12 +57,22 @@ reRead r = read' $ r read' :: Repo -> IO Repo read' repo = go repo where - go Repo { location = Local { gitdir = d } } = git_config d - go Repo { location = LocalUnknown d } = git_config d + -- Passing --git-dir changes git's behavior when run in a + -- repository belonging to another user. When the git directory + -- was explicitly specified, pass that in order to get the local + -- git config. + go Repo { location = Local { gitdir = d } } + | gitDirSpecifiedExplicitly repo = git_config ["--git-dir=."] d + -- Run in worktree when there is one, since running in the .git + -- directory will trigger safe.bareRepository=explicit, even + -- when not in a bare repository. + go Repo { location = Local { worktree = Just d } } = git_config [] d + go Repo { location = Local { gitdir = d } } = git_config [] d + go Repo { location = LocalUnknown d } = git_config [] d go _ = assertLocal repo $ error "internal" - git_config d = withCreateProcess p (git_config' p) + git_config addparams d = withCreateProcess p (git_config' p) where - params = ["config", "--null", "--list"] + params = addparams ++ ["config", "--null", "--list"] p = (proc "git" params) { cwd = Just (fromRawFilePath d) , env = gitEnv repo @@ -94,19 +106,23 @@ global = do hRead :: Repo -> ConfigStyle -> Handle -> IO Repo hRead repo st h = do val <- S.hGetContents h - store val st repo + let c = parse val st + debug (DebugSource "Git.Config") $ "git config read: " ++ + show (map (\(k, v) -> (show k, map show v)) (M.toList c)) + storeParsed c repo {- Stores a git config into a Repo, returning the new version of the Repo. - The git config may be multiple lines, or a single line. - Config settings can be updated incrementally. -} store :: S.ByteString -> ConfigStyle -> Repo -> IO Repo -store s st repo = do - let c = parse s st - updateLocation $ repo - { config = (M.map Prelude.head c) `M.union` config repo - , fullconfig = M.unionWith (++) c (fullconfig repo) - } +store s st = storeParsed (parse s st) + +storeParsed :: M.Map ConfigKey [ConfigValue] -> Repo -> IO Repo +storeParsed c repo = updateLocation $ repo + { config = (M.map Prelude.head c) `M.union` config repo + , fullconfig = M.unionWith (++) c (fullconfig repo) + } {- Stores a single config setting in a Repo, returning the new version of - the Repo. Config settings can be updated incrementally. -} @@ -123,14 +139,28 @@ store' k v repo = repo - based on the core.bare and core.worktree settings. -} updateLocation :: Repo -> IO Repo -updateLocation r@(Repo { location = LocalUnknown d }) - | isBare r = ifM (doesDirectoryExist (fromRawFilePath dotgit)) - ( updateLocation' r $ Local dotgit Nothing - , updateLocation' r $ Local d Nothing - ) - | otherwise = updateLocation' r $ Local dotgit (Just d) +updateLocation r@(Repo { location = LocalUnknown d }) = case isBare r of + Just True -> ifM (doesDirectoryExist (fromRawFilePath dotgit)) + ( updateLocation' r $ Local dotgit Nothing + , updateLocation' r $ Local d Nothing + ) + Just False -> mknonbare + {- core.bare not in config, probably because safe.directory + - did not allow reading the config -} + Nothing -> ifM (Git.Construct.isBareRepo (fromRawFilePath d)) + ( mkbare + , mknonbare + ) where dotgit = d P. ".git" + -- git treats eg ~/foo as a bare git repository located in + -- ~/foo/.git if ~/foo/.git/config has core.bare=true + mkbare = ifM (doesDirectoryExist (fromRawFilePath dotgit)) + ( updateLocation' r $ Local dotgit Nothing + , updateLocation' r $ Local d Nothing + ) + mknonbare = updateLocation' r $ Local dotgit (Just d) + updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l updateLocation r = return r @@ -202,8 +232,9 @@ boolConfig' :: Bool -> S.ByteString boolConfig' True = "true" boolConfig' False = "false" -isBare :: Repo -> Bool -isBare r = fromMaybe False $ isTrueFalse' =<< getMaybe coreBare r +{- Note that repoIsLocalBare is often better to use than this. -} +isBare :: Repo -> Maybe Bool +isBare r = isTrueFalse' =<< getMaybe coreBare r coreBare :: ConfigKey coreBare = "core.bare" @@ -273,3 +304,27 @@ unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r) ) where ps = [Param "config", Param "--unset-all", Param (decodeBS k)] + +{- git "fixed" CVE-2022-24765 by preventing git-config from + - listing per-repo configs when the repo is not owned by + - the current user. Detect if this fix is in effect for the + - repo. + -} +checkRepoConfigInaccessible :: Repo -> IO Bool +checkRepoConfigInaccessible r + -- When --git-dir or GIT_DIR is used to specify the git + -- directory, git does not check for CVE-2022-24765. + | gitDirSpecifiedExplicitly r = return False + | otherwise = do + -- Cannot use gitCommandLine here because specifying --git-dir + -- will bypass the git security check. + let p = (proc "git" ["config", "--local", "--list"]) + { cwd = Just (fromRawFilePath (repoPath r)) + , env = gitEnv r + } + (out, ok) <- processTranscript' p Nothing + if not ok + then do + debug (DebugSource "Git.Config") ("config output: " ++ out) + return True + else return False diff --git a/Git/Construct.hs b/Git/Construct.hs index a5e825e..bdab8ed 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -1,6 +1,6 @@ {- Construction of Git Repo objects - - - Copyright 2010-2021 Joey Hess + - Copyright 2010-2023 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -23,6 +23,7 @@ module Git.Construct ( checkForRepo, newFrom, adjustGitDirFile, + isBareRepo, ) where #ifndef mingw32_HOST_OS @@ -38,6 +39,7 @@ import Git.Remote import Git.FilePath import qualified Git.Url as Url import Utility.UserInfo +import Utility.Url.Parse import qualified Data.ByteString as B import qualified System.FilePath.ByteString as P @@ -84,7 +86,7 @@ fromAbsPath :: RawFilePath -> IO Repo fromAbsPath dir | absoluteGitPath dir = fromPath dir | otherwise = - error $ "internal error, " ++ show dir ++ " is not absolute" + giveup $ "internal error, " ++ show dir ++ " is not absolute" {- Construct a Repo for a remote's url. - @@ -103,10 +105,10 @@ fromUrl url fromUrl' :: String -> IO Repo fromUrl' url - | "file://" `isPrefixOf` url = case parseURI url of + | "file://" `isPrefixOf` url = case parseURIPortable url of Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u Nothing -> pure $ newFrom $ UnparseableUrl url - | otherwise = case parseURI url of + | otherwise = case parseURIPortable url of Just u -> pure $ newFrom $ Url u Nothing -> pure $ newFrom $ UnparseableUrl url @@ -128,7 +130,7 @@ localToUrl reference r , auth , fromRawFilePath (repoPath r) ] - in r { location = Url $ fromJust $ parseURI absurl } + in r { location = Url $ fromJust $ parseURIPortable absurl } _ -> r {- Calculates a list of a repo's configured remotes, by parsing its config. -} @@ -139,7 +141,7 @@ fromRemotes repo = catMaybes <$> mapM construct remotepairs filterkeys f = filterconfig (\(k,_) -> f k) remotepairs = filterkeys isRemoteUrlKey construct (k,v) = remoteNamedFromKey k $ - fromRemoteLocation (fromConfigValue v) repo + fromRemoteLocation (fromConfigValue v) False repo {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo @@ -155,9 +157,15 @@ remoteNamedFromKey k r = case remoteKeyToRemoteName k of Just n -> Just <$> remoteNamed n r {- Constructs a new Repo for one of a Repo's remotes using a given - - location (ie, an url). -} -fromRemoteLocation :: String -> Repo -> IO Repo -fromRemoteLocation s repo = gen $ parseRemoteLocation s repo + - location (ie, an url). + - + - knownurl can be true if the location is known to be an url. This allows + - urls that don't parse as urls to be used, returning UnparseableUrl. + - If knownurl is false, the location may still be an url, if it parses as + - one. + -} +fromRemoteLocation :: String -> Bool -> Repo -> IO Repo +fromRemoteLocation s knownurl repo = gen $ parseRemoteLocation s knownurl repo where gen (RemotePath p) = fromRemotePath p repo gen (RemoteUrl u) = fromUrl u @@ -216,7 +224,7 @@ checkForRepo :: FilePath -> IO (Maybe RepoLocation) checkForRepo dir = check isRepo $ check (checkGitDirFile (toRawFilePath dir)) $ - check isBareRepo $ + check (checkdir (isBareRepo dir)) $ return Nothing where check test cont = maybe cont (return . Just) =<< test @@ -225,16 +233,17 @@ checkForRepo dir = , return Nothing ) isRepo = checkdir $ - gitSignature (".git" "config") + doesFileExist (dir ".git" "config") <||> - -- A git-worktree lacks .git/config, but has .git/commondir. + -- A git-worktree lacks .git/config, but has .git/gitdir. -- (Normally the .git is a file, not a symlink, but it can -- be converted to a symlink and git will still work; -- this handles that case.) - gitSignature (".git" "gitdir") - isBareRepo = checkdir $ gitSignature "config" - <&&> doesDirectoryExist (dir "objects") - gitSignature file = doesFileExist $ dir file + doesFileExist (dir ".git" "gitdir") + +isBareRepo :: FilePath -> IO Bool +isBareRepo dir = doesFileExist (dir "config") + <&&> doesDirectoryExist (dir "objects") -- Check for a .git file. checkGitDirFile :: RawFilePath -> IO (Maybe RepoLocation) @@ -277,5 +286,6 @@ newFrom l = Repo , gitEnv = Nothing , gitEnvOverridesGitDir = False , gitGlobalOpts = [] + , gitDirSpecifiedExplicitly = False } diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index 9261eab..54e05f4 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -1,6 +1,6 @@ {- The current git repository. - - - Copyright 2012-2020 Joey Hess + - Copyright 2012-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -79,8 +79,9 @@ get = do { gitdir = absd , worktree = Just curr } - r <- Git.Config.read $ newFrom loc - return $ if Git.Config.isBare r + r <- Git.Config.read $ (newFrom loc) + { gitDirSpecifiedExplicitly = True } + return $ if fromMaybe False (Git.Config.isBare r) then r { location = (location r) { worktree = Nothing } } else r configure Nothing Nothing = giveup "Not in a git repository." diff --git a/Git/Destroyer.hs b/Git/Destroyer.hs index 4d84eec..9b75178 100644 --- a/Git/Destroyer.hs +++ b/Git/Destroyer.hs @@ -18,7 +18,9 @@ import Git import Utility.QuickCheck import Utility.FileMode import Utility.Tmp +import qualified Utility.RawFilePath as R +import System.PosixCompat.Files import qualified Data.ByteString as B import Data.Word @@ -95,12 +97,12 @@ applyDamage ds r = do case d of Empty s -> withfile s $ \f -> withSaneMode f $ do - removeWhenExistsWith removeLink f + removeWhenExistsWith R.removeLink (toRawFilePath f) writeFile f "" Reverse s -> withfile s $ \f -> withSaneMode f $ B.writeFile f =<< B.reverse <$> B.readFile f - Delete s -> withfile s $ removeWhenExistsWith removeLink + Delete s -> withfile s $ removeWhenExistsWith R.removeLink . toRawFilePath AppendGarbage s garbage -> withfile s $ \f -> withSaneMode f $ @@ -127,15 +129,15 @@ applyDamage ds r = do ] ScrambleFileMode s mode -> withfile s $ \f -> - setFileMode f mode + R.setFileMode (toRawFilePath f) mode SwapFiles a b -> withfile a $ \fa -> withfile b $ \fb -> unless (fa == fb) $ withTmpFile "swap" $ \tmp _ -> do - moveFile fa tmp - moveFile fb fa - moveFile tmp fa + moveFile (toRawFilePath fa) (toRawFilePath tmp) + moveFile (toRawFilePath fb) (toRawFilePath fa) + moveFile (toRawFilePath tmp) (toRawFilePath fa) where -- A broken .git/config is not recoverable. -- Don't damage hook scripts, to avoid running arbitrary code. ;) diff --git a/Git/FilePath.hs b/Git/FilePath.hs index feed8f6..b27c0c7 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -5,7 +5,7 @@ - top of the repository even when run in a subdirectory. Adding some - types helps keep that straight. - - - Copyright 2012-2019 Joey Hess + - Copyright 2012-2023 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -30,12 +30,12 @@ module Git.FilePath ( import Common import Git +import Git.Quote import qualified System.FilePath.ByteString as P import qualified System.FilePath.Posix.ByteString import GHC.Generics import Control.DeepSeq -import qualified Data.ByteString as S {- A RawFilePath, relative to the top of the git repository. -} newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath } @@ -46,11 +46,11 @@ instance NFData TopFilePath {- A file in a branch or other treeish. -} data BranchFilePath = BranchFilePath Ref TopFilePath deriving (Show, Eq, Ord) - + {- Git uses the branch:file form to refer to a BranchFilePath -} -descBranchFilePath :: BranchFilePath -> S.ByteString +descBranchFilePath :: BranchFilePath -> StringContainingQuotedPath descBranchFilePath (BranchFilePath b f) = - fromRef' b <> ":" <> getTopFilePath f + UnquotedByteString (fromRef' b) <> ":" <> QuotedPath (getTopFilePath f) {- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath diff --git a/Git/Filename.hs b/Git/Filename.hs deleted file mode 100644 index 2fa4c59..0000000 --- a/Git/Filename.hs +++ /dev/null @@ -1,49 +0,0 @@ -{- Some git commands output encoded filenames, in a rather annoyingly complex - - C-style encoding. - - - - Copyright 2010, 2011 Joey Hess - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -module Git.Filename where - -import Common -import Utility.Format (decode_c, encode_c) -import Utility.QuickCheck - -import Data.Char -import Data.Word -import qualified Data.ByteString as S - --- encoded filenames will be inside double quotes -decode :: S.ByteString -> RawFilePath -decode b = case S.uncons b of - Nothing -> b - Just (h, t) - | h /= q -> b - | otherwise -> case S.unsnoc t of - Nothing -> b - Just (i, l) - | l /= q -> b - | otherwise -> - encodeBS $ decode_c $ decodeBS i - where - q :: Word8 - q = fromIntegral (ord '"') - -{- Should not need to use this, except for testing decode. -} -encode :: RawFilePath -> S.ByteString -encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\"" - --- Encoding and then decoding roundtrips only when the string does not --- contain high unicode, because eg, both "\12345" and "\227\128\185" --- are encoded to "\343\200\271". --- --- That is not a real-world problem, and using TestableFilePath --- limits what's tested to ascii, so avoids running into it. -prop_encode_decode_roundtrip :: TestableFilePath -> Bool -prop_encode_decode_roundtrip ts = - s == fromRawFilePath (decode (encode (toRawFilePath s))) - where - s = fromTestableFilePath ts diff --git a/Git/HashObject.hs b/Git/HashObject.hs index 98bd440..1474c57 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -1,6 +1,6 @@ {- git hash-object interface - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2023 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -21,26 +21,47 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder +import Data.Char -type HashObjectHandle = CoProcess.CoProcessHandle +data HashObjectHandle = HashObjectHandle CoProcess.CoProcessHandle Repo [CommandParam] hashObjectStart :: Bool -> Repo -> IO HashObjectHandle -hashObjectStart writeobject = gitCoProcessStart True $ catMaybes - [ Just (Param "hash-object") - , if writeobject then Just (Param "-w") else Nothing - , Just (Param "--stdin-paths") - , Just (Param "--no-filters") - ] +hashObjectStart writeobject repo = do + h <- gitCoProcessStart True (ps ++ [Param "--stdin-paths"]) repo + return (HashObjectHandle h repo ps) + where + ps = catMaybes + [ Just (Param "hash-object") + , if writeobject then Just (Param "-w") else Nothing + , Just (Param "--no-filters") + ] hashObjectStop :: HashObjectHandle -> IO () -hashObjectStop = CoProcess.stop +hashObjectStop (HashObjectHandle h _ _) = CoProcess.stop h {- Injects a file into git, returning the Sha of the object. -} hashFile :: HashObjectHandle -> RawFilePath -> IO Sha -hashFile h file = CoProcess.query h send receive +hashFile hdl@(HashObjectHandle h _ _) file = do + -- git hash-object chdirs to the top of the repository on + -- start, so if the filename is relative, it will + -- not work. This seems likely to be a git bug. + -- So, make the filename absolute, which will work now + -- and also if git's behavior later changes. + file' <- absPath file + if newline `S.elem` file' + then hashFile' hdl file + else CoProcess.query h (send file') receive where - send to = S8.hPutStrLn to =<< absPath file + send file' to = S8.hPutStrLn to file' receive from = getSha "hash-object" $ S8.hGetLine from + newline = fromIntegral (ord '\n') + +{- Runs git hash-object once per call, rather than using a running + - one, so is slower. But, is able to handle newlines in the filepath, + - which --stdin-paths cannot. -} +hashFile' :: HashObjectHandle -> RawFilePath -> IO Sha +hashFile' (HashObjectHandle _ repo ps) file = getSha "hash-object" $ + pipeReadStrict (ps ++ [File (fromRawFilePath file)]) repo class HashableBlob t where hashableBlobToHandle :: Handle -> t -> IO () diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index cc824f2..4eea395 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -325,7 +325,7 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest && isus x || isus y && not (isus x && isus y) -{- Gets the InodeCache equivilant information stored in the git index. +{- Gets the InodeCache equivalent 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. diff --git a/Git/LsTree.hs b/Git/LsTree.hs index fb3b3e1..9129d18 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -23,7 +23,7 @@ import Common import Git import Git.Command import Git.FilePath -import qualified Git.Filename +import qualified Git.Quote import Utility.Attoparsec import Numeric @@ -137,7 +137,7 @@ parserLsTree long = case long of -- sha <*> (Ref <$> A8.takeTill A8.isSpace) - fileparser = asTopFilePath . Git.Filename.decode <$> A.takeByteString + fileparser = asTopFilePath . Git.Quote.unquote <$> A.takeByteString sizeparser = fmap Just A8.decimal diff --git a/Git/Quote.hs b/Git/Quote.hs new file mode 100644 index 0000000..2ca442e --- /dev/null +++ b/Git/Quote.hs @@ -0,0 +1,122 @@ +{- Some git commands output quoted filenames, in a rather annoyingly complex + - C-style encoding. + - + - Copyright 2010-2023 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-} + +module Git.Quote ( + unquote, + quote, + noquote, + QuotePath(..), + StringContainingQuotedPath(..), + quotedPaths, + prop_quote_unquote_roundtrip, +) where + +import Common +import Utility.Format (decode_c, encode_c, encode_c', isUtf8Byte) +import Utility.QuickCheck +import Utility.SafeOutput + +import Data.Char +import Data.Word +import Data.String +import qualified Data.ByteString as S +import qualified Data.Semigroup as Sem +import Prelude + +unquote :: S.ByteString -> RawFilePath +unquote b = case S.uncons b of + Nothing -> b + Just (h, t) + | h /= q -> b + | otherwise -> case S.unsnoc t of + Nothing -> b + Just (i, l) + | l /= q -> b + | otherwise -> decode_c i + where + q :: Word8 + q = fromIntegral (ord '"') + +-- always encodes and double quotes, even in cases that git does not +quoteAlways :: RawFilePath -> S.ByteString +quoteAlways s = "\"" <> encode_c needencode s <> "\"" + where + needencode c = isUtf8Byte c || c == fromIntegral (ord '"') + +-- git config core.quotePath controls whether to quote unicode characters +newtype QuotePath = QuotePath Bool + +class Quoteable t where + -- double quotes and encodes when git would + quote :: QuotePath -> t -> S.ByteString + + noquote :: t -> S.ByteString + +instance Quoteable RawFilePath where + quote (QuotePath qp) s = case encode_c' needencode s of + Nothing -> s + Just s' -> "\"" <> s' <> "\"" + where + needencode c + | c == fromIntegral (ord '"') = True + | qp = isUtf8Byte c + | otherwise = False + + noquote = id + +-- Allows building up a string that contains paths, which will get quoted. +-- With OverloadedStrings, strings are passed through without quoting. +-- Eg: QuotedPath f <> ": not found" +data StringContainingQuotedPath + = UnquotedString String + | UnquotedByteString S.ByteString + | QuotedPath RawFilePath + | StringContainingQuotedPath :+: StringContainingQuotedPath + deriving (Show, Eq) + +quotedPaths :: [RawFilePath] -> StringContainingQuotedPath +quotedPaths [] = mempty +quotedPaths (p:ps) = QuotedPath p <> if null ps + then mempty + else " " <> quotedPaths ps + +instance Quoteable StringContainingQuotedPath where + quote _ (UnquotedString s) = safeOutput (encodeBS s) + quote _ (UnquotedByteString s) = safeOutput s + quote qp (QuotedPath p) = quote qp p + quote qp (a :+: b) = quote qp a <> quote qp b + + noquote (UnquotedString s) = encodeBS s + noquote (UnquotedByteString s) = s + noquote (QuotedPath p) = p + noquote (a :+: b) = noquote a <> noquote b + +instance IsString StringContainingQuotedPath where + fromString = UnquotedByteString . encodeBS + +instance Sem.Semigroup StringContainingQuotedPath where + UnquotedString a <> UnquotedString b = UnquotedString (a <> b) + UnquotedByteString a <> UnquotedByteString b = UnquotedByteString (a <> b) + a <> b = a :+: b + +instance Monoid StringContainingQuotedPath where + mempty = UnquotedByteString mempty + +-- Encoding and then decoding roundtrips only when the string does not +-- contain high unicode, because eg, both "\12345" and "\227\128\185" +-- are encoded to "\343\200\271". +-- +-- That is not a real-world problem, and using TestableFilePath +-- limits what's tested to ascii, so avoids running into it. +prop_quote_unquote_roundtrip :: TestableFilePath -> Bool +prop_quote_unquote_roundtrip ts = + s == fromRawFilePath (unquote (quoteAlways (toRawFilePath s))) + where + s = fromTestableFilePath ts diff --git a/Git/Remote.hs b/Git/Remote.hs index 80accca..9cdaad6 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -43,7 +43,7 @@ remoteKeyToRemoteName (ConfigKey k) {- Construct a legal git remote name out of an arbitrary input string. - - There seems to be no formal definition of this in the git source, - - just some ad-hoc checks, and some other things that fail with certian + - just some ad-hoc checks, and some other things that fail with certain - types of names (like ones starting with '-'). -} makeLegalName :: String -> RemoteName @@ -63,7 +63,7 @@ makeLegalName s = case filter legal $ replace "/" "_" s of legal c = isAlphaNum c data RemoteLocation = RemoteUrl String | RemotePath FilePath - deriving (Eq) + deriving (Eq, Show) remoteLocationIsUrl :: RemoteLocation -> Bool remoteLocationIsUrl (RemoteUrl _) = True @@ -75,16 +75,18 @@ remoteLocationIsSshUrl _ = False {- Determines if a given remote location is an url, or a local - path. Takes the repository's insteadOf configuration into account. -} -parseRemoteLocation :: String -> Repo -> RemoteLocation -parseRemoteLocation s repo = ret $ calcloc s +parseRemoteLocation :: String -> Bool -> Repo -> RemoteLocation +parseRemoteLocation s knownurl repo = go where - ret v + s' = calcloc s + go #ifdef mingw32_HOST_OS - | dosstyle v = RemotePath (dospath v) + | dosstyle s' = RemotePath (dospath s') #endif - | scpstyle v = RemoteUrl (scptourl v) - | urlstyle v = RemoteUrl v - | otherwise = RemotePath v + | scpstyle s' = RemoteUrl (scptourl s') + | urlstyle s' = RemoteUrl s' + | knownurl && s' == s = RemoteUrl s' + | otherwise = RemotePath s' -- insteadof config can rewrite remote location calcloc l | null insteadofs = l diff --git a/Git/Repair.hs b/Git/Repair.hs index 7d47f84..cea57df 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -30,6 +30,7 @@ import Git.Types import Git.Fsck import Git.Index import Git.Env +import Git.FilePath import qualified Git.Config as Config import qualified Git.Construct as Construct import qualified Git.LsTree as LsTree @@ -95,7 +96,7 @@ explodePacks r = go =<< listPackFiles r let dest = objectsDir r P. f createDirectoryIfMissing True (fromRawFilePath (parentDir dest)) - moveFile objfile (fromRawFilePath dest) + moveFile (toRawFilePath objfile) dest forM_ packs $ \packfile -> do let f = toRawFilePath packfile removeWhenExistsWith R.removeLink f @@ -103,7 +104,7 @@ explodePacks r = go =<< listPackFiles r return True {- Try to retrieve a set of missing objects, from the remotes of a - - repository. Returns any that could not be retreived. + - repository. Returns any that could not be retrieved. - - If another clone of the repository exists locally, which might not be a - remote of the repo being repaired, its path can be passed as a reference @@ -252,7 +253,8 @@ getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) "refs") getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do let topsegs = length (splitPath refdir) - 1 - let toref = Ref . encodeBS . joinPath . drop topsegs . splitPath + let toref = Ref . toInternalGitPath . encodeBS + . joinPath . drop topsegs . splitPath map toref <$> dirContentsRecursive refdir explodePackedRefsFile :: Repo -> IO () @@ -269,7 +271,7 @@ explodePackedRefsFile r = do let gitd = localGitDir r let dest = gitd P. fromRef' ref let dest' = fromRawFilePath dest - createDirectoryUnder gitd (parentDir dest) + createDirectoryUnder [gitd] (parentDir dest) unlessM (doesFileExist dest') $ writeFile dest' (fromRef sha) @@ -433,7 +435,7 @@ rewriteIndex r reinject (file, sha, mode, _) = case toTreeItemType mode of Nothing -> return Nothing Just treeitemtype -> Just <$> - UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r + UpdateIndex.stageFile sha treeitemtype file r newtype GoodCommits = GoodCommits (S.Set Sha) diff --git a/Git/Sha.hs b/Git/Sha.hs index a66c34e..389bcc0 100644 --- a/Git/Sha.hs +++ b/Git/Sha.hs @@ -20,7 +20,7 @@ import Data.Char getSha :: String -> IO S.ByteString -> IO Sha getSha subcommand a = maybe bad return =<< extractSha <$> a where - bad = error $ "failed to read sha from git " ++ subcommand + bad = giveup $ "failed to read sha from git " ++ subcommand {- Extracts the Sha from a ByteString. - diff --git a/Git/Types.hs b/Git/Types.hs index 68045fc..ce1818e 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -51,6 +51,8 @@ data Repo = Repo , gitEnvOverridesGitDir :: Bool -- global options to pass to git when running git commands , gitGlobalOpts :: [CommandParam] + -- True only when --git-dir or GIT_DIR was used + , gitDirSpecifiedExplicitly :: Bool } deriving (Show, Eq, Ord) newtype ConfigKey = ConfigKey S.ByteString diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 74816a6..f56bc86 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -1,6 +1,6 @@ {- git-update-index library - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -99,15 +99,15 @@ updateIndexLine sha treeitemtype file = L.fromStrict $ <> "\t" <> indexPath file -stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer +stageFile :: Sha -> TreeItemType -> RawFilePath -> Repo -> IO Streamer stageFile sha treeitemtype file repo = do - p <- toTopFilePath (toRawFilePath file) repo + p <- toTopFilePath file repo return $ pureStreamer $ updateIndexLine sha treeitemtype p {- A streamer that removes a file from the index. -} -unstageFile :: FilePath -> Repo -> IO Streamer +unstageFile :: RawFilePath -> Repo -> IO Streamer unstageFile file repo = do - p <- toTopFilePath (toRawFilePath file) repo + p <- toTopFilePath file repo return $ unstageFile' p unstageFile' :: TopFilePath -> Streamer @@ -135,9 +135,17 @@ stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of indexPath :: TopFilePath -> InternalGitPath indexPath = toInternalGitPath . getTopFilePath -{- Refreshes the index, by checking file stat information. -} -refreshIndex :: Repo -> ((RawFilePath -> IO ()) -> IO ()) -> IO Bool -refreshIndex repo feeder = withCreateProcess p go +{- Refreshes the index, by checking file stat information. + - + - The action is passed a callback that it can use to send filenames to + - update-index. Sending Nothing will wait for update-index to finish + - updating the index. + -} +refreshIndex :: (MonadIO m, MonadMask m) => Repo -> ((Maybe RawFilePath -> IO ()) -> m ()) -> m () +refreshIndex repo feeder = bracket + (liftIO $ createProcess p) + (liftIO . cleanupProcess) + go where params = [ Param "update-index" @@ -150,10 +158,12 @@ refreshIndex repo feeder = withCreateProcess p go p = (gitCreateProcess params repo) { std_in = CreatePipe } - go (Just h) _ _ pid = do - feeder $ \f -> - S.hPut h (S.snoc f 0) - hFlush h - hClose h - checkSuccessProcess pid - go _ _ _ _ = error "internal" + go (Just h, _, _, pid) = do + let closer = do + hClose h + forceSuccessProcess p pid + feeder $ \case + Just f -> S.hPut h (S.snoc f 0) + Nothing -> closer + liftIO $ closer + go _ = error "internal" -- cgit v1.2.3