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