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