diff options
Diffstat (limited to 'Git/Construct.hs')
| -rw-r--r-- | Git/Construct.hs | 201 |
1 files changed, 123 insertions, 78 deletions
diff --git a/Git/Construct.hs b/Git/Construct.hs index 5b656eb..bdab8ed 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -1,10 +1,11 @@ {- Construction of Git Repo objects - - - Copyright 2010-2012 Joey Hess <id@joeyh.name> + - Copyright 2010-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Git.Construct ( @@ -21,6 +22,8 @@ module Git.Construct ( repoAbsPath, checkForRepo, newFrom, + adjustGitDirFile, + isBareRepo, ) where #ifndef mingw32_HOST_OS @@ -36,6 +39,10 @@ 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 {- Finds the git repository used for the cwd, which may be in a parent - directory. -} @@ -45,60 +52,65 @@ fromCwd = getCurrentDirectory >>= seekUp seekUp dir = do r <- checkForRepo dir case r of - Nothing -> case upFrom dir of + Nothing -> case upFrom (toRawFilePath dir) of Nothing -> return Nothing - Just d -> seekUp d + Just d -> seekUp (fromRawFilePath d) Just loc -> pure $ Just $ newFrom loc {- Local Repo constructor, accepts a relative or absolute path. -} -fromPath :: FilePath -> IO Repo -fromPath dir = fromAbsPath =<< absPath dir +fromPath :: RawFilePath -> IO Repo +fromPath dir + -- When dir == "foo/.git", git looks for "foo/.git/.git", + -- and failing that, uses "foo" as the repository. + | (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir = + ifM (doesDirectoryExist $ fromRawFilePath dir </> ".git") + ( ret dir + , ret (P.takeDirectory canondir) + ) + | otherwise = ifM (doesDirectoryExist (fromRawFilePath dir)) + ( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom) + -- git falls back to dir.git when dir doesn't + -- exist, as long as dir didn't end with a + -- path separator + , if dir == canondir + then ret (dir <> ".git") + else ret dir + ) + where + ret = pure . newFrom . LocalUnknown + canondir = P.dropTrailingPathSeparator dir {- Local Repo constructor, requires an absolute path to the repo be - specified. -} -fromAbsPath :: FilePath -> IO Repo +fromAbsPath :: RawFilePath -> IO Repo fromAbsPath dir - | absoluteGitPath (encodeBS dir) = hunt + | absoluteGitPath dir = fromPath dir | otherwise = - error $ "internal error, " ++ dir ++ " is not absolute" - where - ret = pure . newFrom . LocalUnknown . toRawFilePath - canondir = dropTrailingPathSeparator dir - {- When dir == "foo/.git", git looks for "foo/.git/.git", - - and failing that, uses "foo" as the repository. -} - hunt - | (pathSeparator:".git") `isSuffixOf` canondir = - ifM (doesDirectoryExist $ dir </> ".git") - ( ret dir - , ret (takeDirectory canondir) - ) - | otherwise = ifM (doesDirectoryExist dir) - ( ret dir - -- git falls back to dir.git when dir doesn't - -- exist, as long as dir didn't end with a - -- path separator - , if dir == canondir - then ret (dir ++ ".git") - else ret dir - ) + giveup $ "internal error, " ++ show dir ++ " is not absolute" -{- Remote Repo constructor. Throws exception on invalid url. +{- Construct a Repo for a remote's url. - - Git is somewhat forgiving about urls to repositories, allowing - - eg spaces that are not normally allowed unescaped in urls. + - eg spaces that are not normally allowed unescaped in urls. Such + - characters get escaped. + - + - This will always succeed, even if the url cannot be parsed + - or is invalid, because git can also function despite remotes having + - such urls, only failing if such a remote is used. -} fromUrl :: String -> IO Repo fromUrl url - | not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url - | otherwise = fromUrlStrict url + | not (isURI url) = fromUrl' $ escapeURIString isUnescapedInURI url + | otherwise = fromUrl' url -fromUrlStrict :: String -> IO Repo -fromUrlStrict url - | "file://" `isPrefixOf` url = fromAbsPath $ unEscapeString $ uriPath u - | otherwise = pure $ newFrom $ Url u - where - u = fromMaybe bad $ parseURI url - bad = error $ "bad url " ++ url +fromUrl' :: String -> IO Repo +fromUrl' url + | "file://" `isPrefixOf` url = case parseURIPortable url of + Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u + Nothing -> pure $ newFrom $ UnparseableUrl url + | otherwise = case parseURIPortable url of + Just u -> pure $ newFrom $ Url u + Nothing -> pure $ newFrom $ UnparseableUrl url {- Creates a repo that has an unknown location. -} fromUnknown :: Repo @@ -110,25 +122,26 @@ localToUrl :: Repo -> Repo -> Repo localToUrl reference r | not $ repoIsUrl reference = error "internal error; reference repo not url" | repoIsUrl r = r - | otherwise = case Url.authority reference of - Nothing -> r - Just auth -> + | otherwise = case (Url.authority reference, Url.scheme reference) of + (Just auth, Just s) -> let absurl = concat - [ Url.scheme reference + [ s , "//" , 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. -} fromRemotes :: Repo -> IO [Repo] -fromRemotes repo = mapM construct remotepairs +fromRemotes repo = catMaybes <$> mapM construct remotepairs where filterconfig f = filter f $ M.toList $ config repo filterkeys f = filterconfig (\(k,_) -> f k) - remotepairs = filterkeys isRemoteKey - construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo) + remotepairs = filterkeys isRemoteUrlKey + construct (k,v) = remoteNamedFromKey k $ + fromRemoteLocation (fromConfigValue v) False repo {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo @@ -138,13 +151,21 @@ remoteNamed n constructor = do {- Sets the name of a remote based on the git config key, such as - "remote.foo.url". -} -remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo -remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName +remoteNamedFromKey :: ConfigKey -> IO Repo -> IO (Maybe Repo) +remoteNamedFromKey k r = case remoteKeyToRemoteName k of + Nothing -> pure Nothing + 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 @@ -154,24 +175,27 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromPath $ fromRawFilePath (repoPath repo) </> dir' + fromPath $ repoPath repo P.</> toRawFilePath dir' {- Git remotes can have a directory that is specified relative - to the user's home directory, or that contains tilde expansions. - This converts such a directory to an absolute path. - Note that it has to run on the system where the remote is. -} -repoAbsPath :: FilePath -> IO FilePath +repoAbsPath :: RawFilePath -> IO RawFilePath repoAbsPath d = do - d' <- expandTilde d + d' <- expandTilde (fromRawFilePath d) h <- myHomeDir - return $ h </> d' + return $ toRawFilePath $ h </> d' 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 @@ -180,6 +204,7 @@ expandTilde = expandt True expandt True ('~':'/':cs) = do h <- myHomeDir return $ h </> cs + expandt True "~" = myHomeDir expandt True ('~':cs) = do let (name, rest) = findname "" cs u <- getUserEntryForName name @@ -198,8 +223,8 @@ expandTilde = expandt True checkForRepo :: FilePath -> IO (Maybe RepoLocation) checkForRepo dir = check isRepo $ - check gitDirFile $ - check isBareRepo $ + check (checkGitDirFile (toRawFilePath dir)) $ + check (checkdir (isBareRepo dir)) $ return Nothing where check test cont = maybe cont (return . Just) =<< test @@ -208,30 +233,49 @@ 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") - gitDirFile = do - -- git-submodule, git-worktree, and --separate-git-dir - -- make .git be a file pointing to the real git directory. - c <- firstLine <$> - catchDefaultIO "" (readFile $ dir </> ".git") - return $ if gitdirprefix `isPrefixOf` c - then Just $ Local - { gitdir = toRawFilePath $ absPathFrom dir $ - drop (length gitdirprefix) c - , worktree = Just (toRawFilePath dir) + 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) +checkGitDirFile dir = adjustGitDirFile' $ Local + { gitdir = dir P.</> ".git" + , worktree = Just dir + } + +-- git-submodule, git-worktree, and --separate-git-dir +-- make .git be a file pointing to the real git directory. +-- Detect that, and return a RepoLocation with gitdir pointing +-- to the real git directory. +adjustGitDirFile :: RepoLocation -> IO RepoLocation +adjustGitDirFile loc = fromMaybe loc <$> adjustGitDirFile' loc + +adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation) +adjustGitDirFile' loc = do + let gd = gitdir loc + c <- firstLine <$> catchDefaultIO "" (readFile (fromRawFilePath gd)) + if gitdirprefix `isPrefixOf` c + then do + top <- fromRawFilePath . P.takeDirectory <$> absPath gd + return $ Just $ loc + { gitdir = absPathFrom + (toRawFilePath top) + (toRawFilePath + (drop (length gitdirprefix) c)) } - else Nothing - where - gitdirprefix = "gitdir: " - gitSignature file = doesFileExist $ dir </> file + else return Nothing + where + gitdirprefix = "gitdir: " + newFrom :: RepoLocation -> Repo newFrom l = Repo @@ -242,5 +286,6 @@ newFrom l = Repo , gitEnv = Nothing , gitEnvOverridesGitDir = False , gitGlobalOpts = [] + , gitDirSpecifiedExplicitly = False } |