112 lines
3.2 KiB
Haskell
112 lines
3.2 KiB
Haskell
{- git remote stuff
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Git.Remote where
|
|
|
|
import Common
|
|
import Git
|
|
import qualified Git.Command
|
|
import qualified Git.BuildVersion
|
|
|
|
import Data.Char
|
|
import qualified Data.Map as M
|
|
import Network.URI
|
|
#ifdef mingw32_HOST_OS
|
|
import Git.FilePath
|
|
#endif
|
|
|
|
type RemoteName = String
|
|
|
|
{- 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 certian
|
|
- 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
|
|
|
|
remove :: RemoteName -> Repo -> IO ()
|
|
remove remotename = Git.Command.run
|
|
[ Param "remote"
|
|
-- name of this subcommand changed
|
|
, Param $
|
|
if Git.BuildVersion.older "1.8.0"
|
|
then "rm"
|
|
else "remove"
|
|
, Param remotename
|
|
]
|
|
|
|
data RemoteLocation = RemoteUrl String | RemotePath FilePath
|
|
|
|
remoteLocationIsUrl :: RemoteLocation -> Bool
|
|
remoteLocationIsUrl (RemoteUrl _) = True
|
|
remoteLocationIsUrl _ = False
|
|
|
|
{- Determines if a given remote location is an url, or a local
|
|
- path. Takes the repository's insteadOf configuration into account. -}
|
|
parseRemoteLocation :: String -> Repo -> RemoteLocation
|
|
parseRemoteLocation s repo = ret $ calcloc s
|
|
where
|
|
ret v
|
|
#ifdef mingw32_HOST_OS
|
|
| dosstyle v = RemotePath (dospath v)
|
|
#endif
|
|
| scpstyle v = RemoteUrl (scptourl v)
|
|
| urlstyle v = RemoteUrl v
|
|
| otherwise = RemotePath v
|
|
-- insteadof config can rewrite remote location
|
|
calcloc l
|
|
| null insteadofs = l
|
|
| otherwise = replacement ++ drop (length bestvalue) l
|
|
where
|
|
replacement = drop (length prefix) $
|
|
take (length bestkey - length suffix) bestkey
|
|
(bestkey, bestvalue) = maximumBy longestvalue insteadofs
|
|
longestvalue (_, a) (_, b) = compare b a
|
|
insteadofs = filterconfig $ \(k, v) ->
|
|
startswith prefix k &&
|
|
endswith suffix k &&
|
|
startswith v l
|
|
filterconfig f = filter f $
|
|
concatMap splitconfigs $ M.toList $ fullconfig repo
|
|
splitconfigs (k, vs) = map (\v -> (k, v)) vs
|
|
(prefix, suffix) = ("url." , ".insteadof")
|
|
urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` 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) = 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 = fromInternalGitPath
|
|
#endif
|