From 0b27e6baa0bd6ed61e2369bd5452d61f3e63e545 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 5 Jan 2012 14:32:20 -0400
Subject: Support unescaped repository urls, like git does.

Turns out that git will accept a .git/config containing an url with eg,
spaces in its name. Handle this by escaping the url if it's not valid.

This also fixes support for urls containing escaped characters like %20
for space. Before, the path from the url was not unescaped properly.
---
 Git/Construct.hs | 20 +++++++++++++++-----
 1 file changed, 15 insertions(+), 5 deletions(-)

(limited to 'Git')

diff --git a/Git/Construct.hs b/Git/Construct.hs
index 2cc965b4e..51fa656bc 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -60,14 +60,23 @@ fromAbsPath dir
 	where
 		ret = return . newFrom . Dir
 
-{- Remote Repo constructor. Throws exception on invalid url. -}
+{- Remote Repo constructor. Throws exception on invalid url.
+ -
+ - Git is somewhat forgiving about urls to repositories, allowing
+ - eg spaces that are not normally allowed unescaped in urls.
+ -}
 fromUrl :: String -> IO Repo
 fromUrl url
+	| not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url
+	| otherwise = fromUrlStrict url
+
+fromUrlStrict :: String -> IO Repo
+fromUrlStrict url
 	| startswith "file://" url = fromAbsPath $ uriPath u
 	| otherwise = return $ newFrom $ Url u
-		where
-			u = fromMaybe bad $ parseURI url
-			bad = error $ "bad url " ++ url
+	where
+		u = fromMaybe bad $ parseURI url
+		bad = error $ "bad url " ++ url
 
 {- Creates a repo that has an unknown location. -}
 fromUnknown :: IO Repo
@@ -117,7 +126,7 @@ fromRemoteLocation s repo = gen $ calcloc s
 	where
 		gen v	
 			| scpstyle v = fromUrl $ scptourl v
-			| isURI v = fromUrl v
+			| urlstyle v = fromUrl v
 			| otherwise = fromRemotePath v repo
 		-- insteadof config can rewrite remote location
 		calcloc l
@@ -137,6 +146,7 @@ fromRemoteLocation s repo = gen $ calcloc s
 						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
 		scpstyle v = ":" `isInfixOf` v && not ("//" `isInfixOf` v)
 		scptourl v = "ssh://" ++ host ++ slash dir
-- 
cgit v1.2.3