1{- Construction of Git Repo objects
2 -
3 - Copyright 2010-2021 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE CPP #-}
10
11module Git.Construct (
12	fromCwd,
13	fromAbsPath,
14	fromPath,
15	fromUrl,
16	fromUnknown,
17	localToUrl,
18	remoteNamed,
19	remoteNamedFromKey,
20	fromRemotes,
21	fromRemoteLocation,
22	repoAbsPath,
23	checkForRepo,
24	newFrom,
25	adjustGitDirFile,
26) where
27
28#ifndef mingw32_HOST_OS
29import System.Posix.User
30#endif
31import qualified Data.Map as M
32import Network.URI
33
34import Common
35import Git.Types
36import Git
37import Git.Remote
38import Git.FilePath
39import qualified Git.Url as Url
40import Utility.UserInfo
41
42import qualified Data.ByteString as B
43import qualified System.FilePath.ByteString as P
44
45{- Finds the git repository used for the cwd, which may be in a parent
46 - directory. -}
47fromCwd :: IO (Maybe Repo)
48fromCwd = getCurrentDirectory >>= seekUp
49  where
50	seekUp dir = do
51		r <- checkForRepo dir
52		case r of
53			Nothing -> case upFrom (toRawFilePath dir) of
54				Nothing -> return Nothing
55				Just d -> seekUp (fromRawFilePath d)
56			Just loc -> pure $ Just $ newFrom loc
57
58{- Local Repo constructor, accepts a relative or absolute path. -}
59fromPath :: RawFilePath -> IO Repo
60fromPath dir
61	-- When dir == "foo/.git", git looks for "foo/.git/.git",
62	-- and failing that, uses "foo" as the repository.
63	| (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir =
64		ifM (doesDirectoryExist $ fromRawFilePath dir </> ".git")
65			( ret dir
66			, ret (P.takeDirectory canondir)
67			)
68	| otherwise = ifM (doesDirectoryExist (fromRawFilePath dir))
69		( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom)
70		-- git falls back to dir.git when dir doesn't
71		-- exist, as long as dir didn't end with a
72		-- path separator
73		, if dir == canondir
74			then ret (dir <> ".git")
75			else ret dir
76		)
77  where
78	ret = pure . newFrom . LocalUnknown
79	canondir = P.dropTrailingPathSeparator dir
80
81{- Local Repo constructor, requires an absolute path to the repo be
82 - specified. -}
83fromAbsPath :: RawFilePath -> IO Repo
84fromAbsPath dir
85	| absoluteGitPath dir = fromPath dir
86	| otherwise =
87		error $ "internal error, " ++ show dir ++ " is not absolute"
88
89{- Construct a Repo for a remote's url.
90 -
91 - Git is somewhat forgiving about urls to repositories, allowing
92 - eg spaces that are not normally allowed unescaped in urls. Such
93 - characters get escaped.
94 -
95 - This will always succeed, even if the url cannot be parsed
96 - or is invalid, because git can also function despite remotes having
97 - such urls, only failing if such a remote is used.
98 -}
99fromUrl :: String -> IO Repo
100fromUrl url
101	| not (isURI url) = fromUrl' $ escapeURIString isUnescapedInURI url
102	| otherwise = fromUrl' url
103
104fromUrl' :: String -> IO Repo
105fromUrl' url
106	| "file://" `isPrefixOf` url = case parseURI url of
107		Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u
108		Nothing -> pure $ newFrom $ UnparseableUrl url
109	| otherwise = case parseURI url of
110		Just u -> pure $ newFrom $ Url u
111		Nothing -> pure $ newFrom $ UnparseableUrl url
112
113{- Creates a repo that has an unknown location. -}
114fromUnknown :: Repo
115fromUnknown = newFrom Unknown
116
117{- Converts a local Repo into a remote repo, using the reference repo
118 - which is assumed to be on the same host. -}
119localToUrl :: Repo -> Repo -> Repo
120localToUrl reference r
121	| not $ repoIsUrl reference = error "internal error; reference repo not url"
122	| repoIsUrl r = r
123	| otherwise = case (Url.authority reference, Url.scheme reference) of
124		(Just auth, Just s) ->
125			let absurl = concat
126				[ s
127				, "//"
128				, auth
129				, fromRawFilePath (repoPath r)
130				]
131			in r { location = Url $ fromJust $ parseURI absurl }
132		_ -> r
133
134{- Calculates a list of a repo's configured remotes, by parsing its config. -}
135fromRemotes :: Repo -> IO [Repo]
136fromRemotes repo = catMaybes <$> mapM construct remotepairs
137  where
138	filterconfig f = filter f $ M.toList $ config repo
139	filterkeys f = filterconfig (\(k,_) -> f k)
140	remotepairs = filterkeys isRemoteUrlKey
141	construct (k,v) = remoteNamedFromKey k $
142		fromRemoteLocation (fromConfigValue v) repo
143
144{- Sets the name of a remote when constructing the Repo to represent it. -}
145remoteNamed :: String -> IO Repo -> IO Repo
146remoteNamed n constructor = do
147	r <- constructor
148	return $ r { remoteName = Just n }
149
150{- Sets the name of a remote based on the git config key, such as
151 - "remote.foo.url". -}
152remoteNamedFromKey :: ConfigKey -> IO Repo -> IO (Maybe Repo)
153remoteNamedFromKey k r = case remoteKeyToRemoteName k of
154	Nothing -> pure Nothing
155	Just n -> Just <$> remoteNamed n r
156
157{- Constructs a new Repo for one of a Repo's remotes using a given
158 - location (ie, an url). -}
159fromRemoteLocation :: String -> Repo -> IO Repo
160fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
161  where
162	gen (RemotePath p) = fromRemotePath p repo
163	gen (RemoteUrl u) = fromUrl u
164
165{- Constructs a Repo from the path specified in the git remotes of
166 - another Repo. -}
167fromRemotePath :: FilePath -> Repo -> IO Repo
168fromRemotePath dir repo = do
169	dir' <- expandTilde dir
170	fromPath $ repoPath repo P.</> toRawFilePath dir'
171
172{- Git remotes can have a directory that is specified relative
173 - to the user's home directory, or that contains tilde expansions.
174 - This converts such a directory to an absolute path.
175 - Note that it has to run on the system where the remote is.
176 -}
177repoAbsPath :: RawFilePath -> IO RawFilePath
178repoAbsPath d = do
179	d' <- expandTilde (fromRawFilePath d)
180	h <- myHomeDir
181	return $ toRawFilePath $ h </> d'
182
183expandTilde :: FilePath -> IO FilePath
184#ifdef mingw32_HOST_OS
185expandTilde = return
186#else
187expandTilde = expandt True
188  where
189	expandt _ [] = return ""
190	expandt _ ('/':cs) = do
191		v <- expandt True cs
192		return ('/':v)
193	expandt True ('~':'/':cs) = do
194		h <- myHomeDir
195		return $ h </> cs
196	expandt True "~" = myHomeDir
197	expandt True ('~':cs) = do
198		let (name, rest) = findname "" cs
199		u <- getUserEntryForName name
200		return $ homeDirectory u </> rest
201	expandt _ (c:cs) = do
202		v <- expandt False cs
203		return (c:v)
204	findname n [] = (n, "")
205	findname n (c:cs)
206		| c == '/' = (n, cs)
207		| otherwise = findname (n++[c]) cs
208#endif
209
210{- Checks if a git repository exists in a directory. Does not find
211 - git repositories in parent directories. -}
212checkForRepo :: FilePath -> IO (Maybe RepoLocation)
213checkForRepo dir =
214	check isRepo $
215		check (checkGitDirFile (toRawFilePath dir)) $
216			check isBareRepo $
217				return Nothing
218  where
219	check test cont = maybe cont (return . Just) =<< test
220	checkdir c = ifM c
221		( return $ Just $ LocalUnknown $ toRawFilePath dir
222		, return Nothing
223		)
224	isRepo = checkdir $
225		gitSignature (".git" </> "config")
226			<||>
227		-- A git-worktree lacks .git/config, but has .git/commondir.
228		-- (Normally the .git is a file, not a symlink, but it can
229		-- be converted to a symlink and git will still work;
230		-- this handles that case.)
231		gitSignature (".git" </> "gitdir")
232	isBareRepo = checkdir $ gitSignature "config"
233		<&&> doesDirectoryExist (dir </> "objects")
234	gitSignature file = doesFileExist $ dir </> file
235
236-- Check for a .git file.
237checkGitDirFile :: RawFilePath -> IO (Maybe RepoLocation)
238checkGitDirFile dir = adjustGitDirFile' $ Local
239	{ gitdir = dir P.</> ".git"
240	, worktree = Just dir
241	}
242
243-- git-submodule, git-worktree, and --separate-git-dir
244-- make .git be a file pointing to the real git directory.
245-- Detect that, and return a RepoLocation with gitdir pointing
246-- to the real git directory.
247adjustGitDirFile :: RepoLocation -> IO RepoLocation
248adjustGitDirFile loc = fromMaybe loc <$> adjustGitDirFile' loc
249
250adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation)
251adjustGitDirFile' loc = do
252	let gd = gitdir loc
253	c <- firstLine <$> catchDefaultIO "" (readFile (fromRawFilePath gd))
254	if gitdirprefix `isPrefixOf` c
255		then do
256			top <- fromRawFilePath . P.takeDirectory <$> absPath gd
257			return $ Just $ loc
258				{ gitdir = absPathFrom
259					(toRawFilePath top)
260					(toRawFilePath
261						(drop (length gitdirprefix) c))
262				}
263		else return Nothing
264 where
265	gitdirprefix = "gitdir: "
266
267
268newFrom :: RepoLocation -> Repo
269newFrom l = Repo
270	{ location = l
271	, config = M.empty
272	, fullconfig = M.empty
273	, remoteName = Nothing
274	, gitEnv = Nothing
275	, gitEnvOverridesGitDir = False
276	, gitGlobalOpts = []
277	}
278
279