2011-12-13 19:05:07 +00:00
|
|
|
{- Construction of Git Repo objects
|
|
|
|
-
|
2020-08-28 19:08:14 +00:00
|
|
|
- Copyright 2010-2020 Joey Hess <id@joeyh.name>
|
2011-12-13 19:05:07 +00:00
|
|
|
-
|
2019-03-13 19:48:14 +00:00
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
2011-12-13 19:05:07 +00:00
|
|
|
-}
|
|
|
|
|
2013-05-10 21:29:59 +00:00
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
|
2011-12-13 19:05:07 +00:00
|
|
|
module Git.Construct (
|
|
|
|
fromCwd,
|
|
|
|
fromAbsPath,
|
2012-01-26 00:42:01 +00:00
|
|
|
fromPath,
|
2011-12-13 19:05:07 +00:00
|
|
|
fromUrl,
|
|
|
|
fromUnknown,
|
|
|
|
localToUrl,
|
2011-12-14 19:30:14 +00:00
|
|
|
remoteNamed,
|
|
|
|
remoteNamedFromKey,
|
2011-12-13 19:05:07 +00:00
|
|
|
fromRemotes,
|
|
|
|
fromRemoteLocation,
|
|
|
|
repoAbsPath,
|
2013-03-12 12:09:31 +00:00
|
|
|
checkForRepo,
|
2015-02-12 19:33:05 +00:00
|
|
|
newFrom,
|
2011-12-13 19:05:07 +00:00
|
|
|
) where
|
|
|
|
|
2013-08-02 16:27:32 +00:00
|
|
|
#ifndef mingw32_HOST_OS
|
2011-12-13 19:05:07 +00:00
|
|
|
import System.Posix.User
|
2013-05-10 21:29:59 +00:00
|
|
|
#endif
|
2017-01-31 22:40:42 +00:00
|
|
|
import qualified Data.Map as M
|
2011-12-13 19:05:07 +00:00
|
|
|
import Network.URI
|
|
|
|
|
|
|
|
import Common
|
|
|
|
import Git.Types
|
|
|
|
import Git
|
2013-09-26 21:26:13 +00:00
|
|
|
import Git.Remote
|
2014-02-08 19:31:03 +00:00
|
|
|
import Git.FilePath
|
2011-12-14 19:30:14 +00:00
|
|
|
import qualified Git.Url as Url
|
2012-10-25 22:17:32 +00:00
|
|
|
import Utility.UserInfo
|
2011-12-13 19:05:07 +00:00
|
|
|
|
2012-09-16 02:40:04 +00:00
|
|
|
{- Finds the git repository used for the cwd, which may be in a parent
|
2012-01-13 16:52:09 +00:00
|
|
|
- directory. -}
|
Additional GIT_DIR support bugfixes. May actually work now.
Two fixes. First, and most importantly, relax the isLinkToAnnex check
to only look for /annex/objects/, not [^|/].git/annex/objects. If
GIT_DIR is used with a detached work tree, the git directory is
not necessarily named .git.
There are important caveats with doing that at all, since git-annex will
make symlinks that point at GIT_DIR, which means that the relative path
between GIT_DIR and GIT_WORK_TREE needs to remain stable across all clones
of the repository.
----
The other fix is just fixing crazy and wrong code that, when GIT_DIR is
set, expects to still find a git repository in the path below the work
tree, and uses some of its configuration, and some of GIT_DIR. What was I
thinking, and why can't I seem to get this code right?
2013-02-23 16:32:09 +00:00
|
|
|
fromCwd :: IO (Maybe Repo)
|
|
|
|
fromCwd = getCurrentDirectory >>= seekUp
|
2012-12-13 04:24:19 +00:00
|
|
|
where
|
Additional GIT_DIR support bugfixes. May actually work now.
Two fixes. First, and most importantly, relax the isLinkToAnnex check
to only look for /annex/objects/, not [^|/].git/annex/objects. If
GIT_DIR is used with a detached work tree, the git directory is
not necessarily named .git.
There are important caveats with doing that at all, since git-annex will
make symlinks that point at GIT_DIR, which means that the relative path
between GIT_DIR and GIT_WORK_TREE needs to remain stable across all clones
of the repository.
----
The other fix is just fixing crazy and wrong code that, when GIT_DIR is
set, expects to still find a git repository in the path below the work
tree, and uses some of its configuration, and some of GIT_DIR. What was I
thinking, and why can't I seem to get this code right?
2013-02-23 16:32:09 +00:00
|
|
|
seekUp dir = do
|
|
|
|
r <- checkForRepo dir
|
2012-12-13 04:24:19 +00:00
|
|
|
case r of
|
2015-01-09 18:26:52 +00:00
|
|
|
Nothing -> case upFrom dir of
|
|
|
|
Nothing -> return Nothing
|
|
|
|
Just d -> seekUp d
|
2015-02-12 19:33:05 +00:00
|
|
|
Just loc -> pure $ Just $ newFrom loc
|
2011-12-13 19:05:07 +00:00
|
|
|
|
2012-01-13 18:40:36 +00:00
|
|
|
{- Local Repo constructor, accepts a relative or absolute path. -}
|
|
|
|
fromPath :: FilePath -> IO Repo
|
|
|
|
fromPath dir = fromAbsPath =<< absPath dir
|
|
|
|
|
2011-12-13 19:05:07 +00:00
|
|
|
{- Local Repo constructor, requires an absolute path to the repo be
|
|
|
|
- specified. -}
|
|
|
|
fromAbsPath :: FilePath -> IO Repo
|
|
|
|
fromAbsPath dir
|
2019-11-25 20:18:19 +00:00
|
|
|
| absoluteGitPath (encodeBS dir) = hunt
|
2012-03-16 05:59:07 +00:00
|
|
|
| otherwise =
|
|
|
|
error $ "internal error, " ++ dir ++ " is not absolute"
|
2012-12-13 04:24:19 +00:00
|
|
|
where
|
2019-12-09 17:49:05 +00:00
|
|
|
ret = pure . newFrom . LocalUnknown . toRawFilePath
|
2012-12-13 04:24:19 +00:00
|
|
|
canondir = dropTrailingPathSeparator dir
|
|
|
|
{- When dir == "foo/.git", git looks for "foo/.git/.git",
|
|
|
|
- and failing that, uses "foo" as the repository. -}
|
|
|
|
hunt
|
2013-05-14 19:44:49 +00:00
|
|
|
| (pathSeparator:".git") `isSuffixOf` canondir =
|
2012-12-13 04:24:19 +00:00
|
|
|
ifM (doesDirectoryExist $ dir </> ".git")
|
|
|
|
( ret dir
|
2015-10-26 19:35:55 +00:00
|
|
|
, ret (takeDirectory canondir)
|
2012-12-13 04:24:19 +00:00
|
|
|
)
|
2015-10-26 19:35:55 +00:00
|
|
|
| otherwise = ifM (doesDirectoryExist dir)
|
2020-08-28 19:08:14 +00:00
|
|
|
( gitDirFile dir >>= maybe (ret dir) (pure . newFrom)
|
2015-10-26 19:35:55 +00:00
|
|
|
-- 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
|
|
|
|
)
|
2011-12-13 19:05:07 +00:00
|
|
|
|
2012-01-05 18:32:20 +00:00
|
|
|
{- Remote Repo constructor. Throws exception on invalid url.
|
|
|
|
-
|
|
|
|
- Git is somewhat forgiving about urls to repositories, allowing
|
|
|
|
- eg spaces that are not normally allowed unescaped in urls.
|
|
|
|
-}
|
2011-12-13 19:05:07 +00:00
|
|
|
fromUrl :: String -> IO Repo
|
|
|
|
fromUrl url
|
2012-01-05 18:32:20 +00:00
|
|
|
| not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url
|
|
|
|
| otherwise = fromUrlStrict url
|
|
|
|
|
|
|
|
fromUrlStrict :: String -> IO Repo
|
|
|
|
fromUrlStrict url
|
2017-05-16 03:32:17 +00:00
|
|
|
| "file://" `isPrefixOf` url = fromAbsPath $ unEscapeString $ uriPath u
|
2015-02-12 19:33:05 +00:00
|
|
|
| otherwise = pure $ newFrom $ Url u
|
2012-12-13 04:24:19 +00:00
|
|
|
where
|
|
|
|
u = fromMaybe bad $ parseURI url
|
|
|
|
bad = error $ "bad url " ++ url
|
2011-12-13 19:05:07 +00:00
|
|
|
|
|
|
|
{- Creates a repo that has an unknown location. -}
|
2015-02-12 19:33:05 +00:00
|
|
|
fromUnknown :: Repo
|
2012-01-14 01:06:00 +00:00
|
|
|
fromUnknown = newFrom Unknown
|
2011-12-13 19:05:07 +00:00
|
|
|
|
|
|
|
{- Converts a local Repo into a remote repo, using the reference repo
|
|
|
|
- which is assumed to be on the same host. -}
|
|
|
|
localToUrl :: Repo -> Repo -> Repo
|
|
|
|
localToUrl reference r
|
|
|
|
| not $ repoIsUrl reference = error "internal error; reference repo not url"
|
|
|
|
| repoIsUrl r = r
|
2013-11-04 18:14:44 +00:00
|
|
|
| otherwise = case Url.authority reference of
|
|
|
|
Nothing -> r
|
|
|
|
Just auth ->
|
|
|
|
let absurl = concat
|
|
|
|
[ Url.scheme reference
|
|
|
|
, "//"
|
|
|
|
, auth
|
2019-12-09 17:49:05 +00:00
|
|
|
, fromRawFilePath (repoPath r)
|
2013-11-04 18:14:44 +00:00
|
|
|
]
|
|
|
|
in r { location = Url $ fromJust $ parseURI absurl }
|
2011-12-13 19:05:07 +00:00
|
|
|
|
|
|
|
{- Calculates a list of a repo's configured remotes, by parsing its config. -}
|
|
|
|
fromRemotes :: Repo -> IO [Repo]
|
|
|
|
fromRemotes repo = mapM construct remotepairs
|
2012-12-13 04:24:19 +00:00
|
|
|
where
|
|
|
|
filterconfig f = filter f $ M.toList $ config repo
|
|
|
|
filterkeys f = filterconfig (\(k,_) -> f k)
|
2018-01-09 19:36:56 +00:00
|
|
|
remotepairs = filterkeys isRemoteKey
|
2019-12-05 18:36:43 +00:00
|
|
|
construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo)
|
2011-12-14 19:30:14 +00:00
|
|
|
|
|
|
|
{- Sets the name of a remote when constructing the Repo to represent it. -}
|
|
|
|
remoteNamed :: String -> IO Repo -> IO Repo
|
|
|
|
remoteNamed n constructor = do
|
|
|
|
r <- constructor
|
|
|
|
return $ r { remoteName = Just n }
|
|
|
|
|
|
|
|
{- Sets the name of a remote based on the git config key, such as
|
2012-12-13 04:45:27 +00:00
|
|
|
- "remote.foo.url". -}
|
2019-12-02 14:57:09 +00:00
|
|
|
remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo
|
2018-01-09 19:36:56 +00:00
|
|
|
remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName
|
2011-12-13 19:05:07 +00:00
|
|
|
|
|
|
|
{- Constructs a new Repo for one of a Repo's remotes using a given
|
|
|
|
- location (ie, an url). -}
|
|
|
|
fromRemoteLocation :: String -> Repo -> IO Repo
|
2013-09-26 21:26:13 +00:00
|
|
|
fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
|
2012-12-13 04:24:19 +00:00
|
|
|
where
|
2013-09-26 21:26:13 +00:00
|
|
|
gen (RemotePath p) = fromRemotePath p repo
|
|
|
|
gen (RemoteUrl u) = fromUrl u
|
2011-12-13 19:05:07 +00:00
|
|
|
|
|
|
|
{- Constructs a Repo from the path specified in the git remotes of
|
|
|
|
- another Repo. -}
|
|
|
|
fromRemotePath :: FilePath -> Repo -> IO Repo
|
|
|
|
fromRemotePath dir repo = do
|
|
|
|
dir' <- expandTilde dir
|
2019-12-09 17:49:05 +00:00
|
|
|
fromPath $ fromRawFilePath (repoPath repo) </> dir'
|
2011-12-13 19:05:07 +00:00
|
|
|
|
|
|
|
{- 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 d = do
|
|
|
|
d' <- expandTilde d
|
|
|
|
h <- myHomeDir
|
|
|
|
return $ h </> d'
|
|
|
|
|
|
|
|
expandTilde :: FilePath -> IO FilePath
|
2013-08-02 16:27:32 +00:00
|
|
|
#ifdef mingw32_HOST_OS
|
2013-05-11 20:03:00 +00:00
|
|
|
expandTilde = return
|
|
|
|
#else
|
2011-12-13 19:05:07 +00:00
|
|
|
expandTilde = expandt True
|
2012-12-13 04:24:19 +00:00
|
|
|
where
|
|
|
|
expandt _ [] = return ""
|
|
|
|
expandt _ ('/':cs) = do
|
|
|
|
v <- expandt True cs
|
|
|
|
return ('/':v)
|
|
|
|
expandt True ('~':'/':cs) = do
|
|
|
|
h <- myHomeDir
|
|
|
|
return $ h </> cs
|
|
|
|
expandt True ('~':cs) = do
|
|
|
|
let (name, rest) = findname "" cs
|
|
|
|
u <- getUserEntryForName name
|
|
|
|
return $ homeDirectory u </> rest
|
|
|
|
expandt _ (c:cs) = do
|
|
|
|
v <- expandt False cs
|
|
|
|
return (c:v)
|
|
|
|
findname n [] = (n, "")
|
|
|
|
findname n (c:cs)
|
|
|
|
| c == '/' = (n, cs)
|
|
|
|
| otherwise = findname (n++[c]) cs
|
2013-05-11 20:03:00 +00:00
|
|
|
#endif
|
2011-12-13 19:05:07 +00:00
|
|
|
|
2013-03-12 12:09:31 +00:00
|
|
|
{- Checks if a git repository exists in a directory. Does not find
|
|
|
|
- git repositories in parent directories. -}
|
2012-09-16 02:40:04 +00:00
|
|
|
checkForRepo :: FilePath -> IO (Maybe RepoLocation)
|
|
|
|
checkForRepo dir =
|
|
|
|
check isRepo $
|
2020-08-28 19:08:14 +00:00
|
|
|
check (gitDirFile dir) $
|
2012-09-16 02:40:04 +00:00
|
|
|
check isBareRepo $
|
|
|
|
return Nothing
|
2012-12-13 04:24:19 +00:00
|
|
|
where
|
|
|
|
check test cont = maybe cont (return . Just) =<< test
|
|
|
|
checkdir c = ifM c
|
2019-12-09 17:49:05 +00:00
|
|
|
( return $ Just $ LocalUnknown $ toRawFilePath dir
|
2012-12-13 04:24:19 +00:00
|
|
|
, return Nothing
|
|
|
|
)
|
2018-07-18 18:25:03 +00:00
|
|
|
isRepo = checkdir $
|
|
|
|
gitSignature (".git" </> "config")
|
|
|
|
<||>
|
|
|
|
-- A git-worktree lacks .git/config, but has .git/commondir.
|
|
|
|
-- (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")
|
2012-12-13 04:24:19 +00:00
|
|
|
isBareRepo = checkdir $ gitSignature "config"
|
|
|
|
<&&> doesDirectoryExist (dir </> "objects")
|
|
|
|
gitSignature file = doesFileExist $ dir </> file
|
2011-12-13 19:05:07 +00:00
|
|
|
|
2020-08-28 19:08:14 +00:00
|
|
|
-- 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.
|
|
|
|
gitDirFile :: FilePath -> IO (Maybe RepoLocation)
|
|
|
|
gitDirFile dir = do
|
|
|
|
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)
|
|
|
|
}
|
|
|
|
else Nothing
|
|
|
|
where
|
|
|
|
gitdirprefix = "gitdir: "
|
|
|
|
|
2015-02-12 19:33:05 +00:00
|
|
|
newFrom :: RepoLocation -> Repo
|
|
|
|
newFrom l = Repo
|
2012-01-14 01:06:00 +00:00
|
|
|
{ location = l
|
|
|
|
, config = M.empty
|
|
|
|
, fullconfig = M.empty
|
|
|
|
, remoteName = Nothing
|
2012-08-25 00:50:39 +00:00
|
|
|
, gitEnv = Nothing
|
2016-04-08 18:24:00 +00:00
|
|
|
, gitEnvOverridesGitDir = False
|
2013-11-05 17:38:37 +00:00
|
|
|
, gitGlobalOpts = []
|
2011-12-13 19:05:07 +00:00
|
|
|
}
|
2012-05-18 22:20:53 +00:00
|
|
|
|