1{- git remote stuff
2 -
3 - Copyright 2012-2021 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE CPP #-}
9{-# LANGUAGE OverloadedStrings #-}
10
11module Git.Remote where
12
13import Common
14import Git
15import Git.Types
16
17import Data.Char
18import qualified Data.Map as M
19import qualified Data.ByteString as S
20import qualified Data.ByteString.Char8 as S8
21import Network.URI
22#ifdef mingw32_HOST_OS
23import Git.FilePath
24#endif
25
26{- Is a git config key one that specifies the url of a remote? -}
27isRemoteUrlKey :: ConfigKey -> Bool
28isRemoteUrlKey = isRemoteKey "url"
29
30isRemoteKey :: S.ByteString -> ConfigKey -> Bool
31isRemoteKey want (ConfigKey k) =
32	"remote." `S.isPrefixOf` k && ("." <> want) `S.isSuffixOf` k
33
34{- Get a remote's name from the a config key such as remote.name.url
35 - or any other per-remote config key. -}
36remoteKeyToRemoteName :: ConfigKey -> Maybe RemoteName
37remoteKeyToRemoteName (ConfigKey k)
38	| "remote." `S.isPrefixOf` k =
39		let n = S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k
40		in if S.null n then Nothing else Just (decodeBS n)
41	| otherwise = Nothing
42
43{- Construct a legal git remote name out of an arbitrary input string.
44 -
45 - There seems to be no formal definition of this in the git source,
46 - just some ad-hoc checks, and some other things that fail with certian
47 - types of names (like ones starting with '-').
48 -}
49makeLegalName :: String -> RemoteName
50makeLegalName s = case filter legal $ replace "/" "_" s of
51	-- it can't be empty
52	[] -> "unnamed"
53	-- it can't start with / or - or .
54	'.':s' -> makeLegalName s'
55	'/':s' -> makeLegalName s'
56	'-':s' -> makeLegalName s'
57	s' -> s'
58  where
59	{- Only alphanumerics, and a few common bits of punctuation common
60	 - in hostnames. -}
61	legal '_' = True
62	legal '.' = True
63	legal c = isAlphaNum c
64
65data RemoteLocation = RemoteUrl String | RemotePath FilePath
66	deriving (Eq)
67
68remoteLocationIsUrl :: RemoteLocation -> Bool
69remoteLocationIsUrl (RemoteUrl _) = True
70remoteLocationIsUrl _ = False
71
72remoteLocationIsSshUrl :: RemoteLocation -> Bool
73remoteLocationIsSshUrl (RemoteUrl u) = "ssh://" `isPrefixOf` u
74remoteLocationIsSshUrl _ = False
75
76{- Determines if a given remote location is an url, or a local
77 - path. Takes the repository's insteadOf configuration into account. -}
78parseRemoteLocation :: String -> Repo -> RemoteLocation
79parseRemoteLocation s repo = ret $ calcloc s
80  where
81	ret v
82#ifdef mingw32_HOST_OS
83		| dosstyle v = RemotePath (dospath v)
84#endif
85		| scpstyle v = RemoteUrl (scptourl v)
86		| urlstyle v = RemoteUrl v
87		| otherwise = RemotePath v
88	-- insteadof config can rewrite remote location
89	calcloc l
90		| null insteadofs = l
91		| otherwise = replacement ++ drop (S.length bestvalue) l
92	  where
93		replacement = decodeBS $ S.drop (S.length prefix) $
94			S.take (S.length bestkey - S.length suffix) bestkey
95		(bestkey, bestvalue) =
96			case maximumBy longestvalue insteadofs of
97				(ConfigKey k, ConfigValue v) -> (k, v)
98				(ConfigKey k, NoConfigValue) -> (k, mempty)
99		longestvalue (_, a) (_, b) = compare b a
100		insteadofs = filterconfig $ \case
101			(ConfigKey k, ConfigValue v) ->
102				prefix `S.isPrefixOf` k &&
103				suffix `S.isSuffixOf` k &&
104				v `S.isPrefixOf` encodeBS l
105			(_, NoConfigValue) -> False
106		filterconfig f = filter f $
107			concatMap splitconfigs $ M.toList $ fullconfig repo
108		splitconfigs (k, vs) = map (\v -> (k, v)) vs
109		(prefix, suffix) = ("url." , ".insteadof")
110	-- git supports URIs that contain unescaped characters such as
111	-- spaces. So to test if it's a (git) URI, escape those.
112	urlstyle v = isURI (escapeURIString isUnescapedInURI v)
113	-- git remotes can be written scp style -- [user@]host:dir
114	-- but foo::bar is a git-remote-helper location instead
115	scpstyle v = ":" `isInfixOf` v
116		&& not ("//" `isInfixOf` v)
117		&& not ("::" `isInfixOf` v)
118	scptourl v = "ssh://" ++ host ++ slash dir
119	  where
120		(host, dir)
121			-- handle ipv6 address inside []
122			| "[" `isPrefixOf` v = case break (== ']') v of
123				(h, ']':':':d) -> (h ++ "]", d)
124				(h, ']':d) -> (h ++ "]", d)
125				(h, d) -> (h, d)
126			| otherwise = separate (== ':') v
127		slash d	| d == "" = "/~/" ++ d
128			| "/" `isPrefixOf` d = d
129			| "~" `isPrefixOf` d = '/':d
130			| otherwise = "/~/" ++ d
131#ifdef mingw32_HOST_OS
132	-- git on Windows will write a path to .git/config with "drive:",
133	-- which is not to be confused with a "host:"
134	dosstyle = hasDrive
135	dospath = fromRawFilePath . fromInternalGitPath . toRawFilePath
136#endif
137