summaryrefslogtreecommitdiff
path: root/Git
diff options
context:
space:
mode:
Diffstat (limited to 'Git')
-rw-r--r--Git/Construct.hs50
-rw-r--r--Git/Remote.hs59
2 files changed, 63 insertions, 46 deletions
diff --git a/Git/Construct.hs b/Git/Construct.hs
index 35c77e9d2..377ddeeae 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -23,8 +23,6 @@ module Git.Construct (
checkForRepo,
) where
-{-# LANGUAGE CPP #-}
-
#ifndef mingw32_HOST_OS
import System.Posix.User
#else
@@ -36,6 +34,7 @@ import Network.URI
import Common
import Git.Types
import Git
+import Git.Remote
import qualified Git.Url as Url
import Utility.UserInfo
@@ -143,51 +142,10 @@ remoteNamedFromKey k = remoteNamed basename
{- Constructs a new Repo for one of a Repo's remotes using a given
- location (ie, an url). -}
fromRemoteLocation :: String -> Repo -> IO Repo
-fromRemoteLocation s repo = gen $ calcloc s
+fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
where
- gen v
-#ifdef mingw32_HOST_OS
- | dosstyle v = fromRemotePath (dospath v) repo
-#endif
- | scpstyle v = fromUrl $ scptourl v
- | urlstyle v = fromUrl v
- | otherwise = fromRemotePath v repo
- -- 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
+ gen (RemotePath p) = fromRemotePath p repo
+ gen (RemoteUrl u) = fromUrl u
{- Constructs a Repo from the path specified in the git remotes of
- another Repo. -}
diff --git a/Git/Remote.hs b/Git/Remote.hs
index e853e53cb..3dc6d9e45 100644
--- a/Git/Remote.hs
+++ b/Git/Remote.hs
@@ -5,6 +5,8 @@
- Licensed under the GNU GPL version 3 or higher.
-}
+{-# LANGUAGE CPP #-}
+
module Git.Remote where
import Common
@@ -13,6 +15,8 @@ import qualified Git.Command
import qualified Git.BuildVersion
import Data.Char
+import qualified Data.Map as M
+import Network.URI
type RemoteName = String
@@ -48,3 +52,58 @@ remove remotename = Git.Command.run
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