Work around a bug in Network.URI's handling of bracketed ipv6 addresses.

3 files changed, 37 insertions, 3 deletions

diff --git a/GitRepo.hs b/GitRepo.hs
index 9ecaa8ffc..49024abe0 100644
--- a/GitRepo.hs
+++ b/GitRepo.hs
@@ -280,9 +280,21 @@ urlScheme :: Repo -> String
 urlScheme Repo { location = Url u } = uriScheme u
 urlScheme repo = assertUrl repo $ error "internal"
 
+{- Work around a bug in the real uriRegName
+ - <http://trac.haskell.org/network/ticket/40> -}
+uriRegName' :: URIAuth -> String
+uriRegName' a = fixup $ uriRegName a
+	where
+		fixup x@('[':rest)
+			| rest !! len == ']' = take len rest
+			| otherwise = x
+			where
+				len  = (length rest) - 1
+		fixup x = x
+
 {- Hostname of an URL repo. -}
 urlHost :: Repo -> String
-urlHost = urlAuthPart uriRegName
+urlHost = urlAuthPart uriRegName'
 
 {- Port of an URL repo, if it has a nonstandard one. -}
 urlPort :: Repo -> Maybe Integer
@@ -294,11 +306,11 @@ urlPort r =
 
 {- Hostname of an URL repo, including any username (ie, "user@host") -}
 urlHostUser :: Repo -> String
-urlHostUser r = urlAuthPart uriUserInfo r ++ urlAuthPart uriRegName r
+urlHostUser r = urlAuthPart uriUserInfo r ++ urlAuthPart uriRegName' r
 
 {- The full authority portion an URL repo. (ie, "user@host:port") -}
 urlAuthority :: Repo -> String
-urlAuthority Repo { location = Url u } = uriUserInfo a ++ uriRegName a ++ uriPort a
+urlAuthority Repo { location = Url u } = uriUserInfo a ++ uriRegName' a ++ uriPort a
 	where
 		a = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
 urlAuthority repo = assertUrl repo $ error "internal"
diff --git a/debian/changelog b/debian/changelog
index 73f5924a9..09dde346c 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+git-annex (0.20110504) UNRELEASED; urgency=low
+
+  * Work around a bug in Network.URI's handling of bracketed ipv6 addresses.
+
+ -- Joey Hess <joeyh@debian.org>  Fri, 06 May 2011 15:20:38 -0400
+
 git-annex (0.20110503) unstable; urgency=low
 
   * Fix hasKeyCheap setting for bup and rsync special remotes.
diff --git a/doc/bugs/git-annex_incorrectly_parses_bare_IPv6_addresses.mdwn b/doc/bugs/git-annex_incorrectly_parses_bare_IPv6_addresses.mdwn
index fdaf5d5d1..c94952b49 100644
--- a/doc/bugs/git-annex_incorrectly_parses_bare_IPv6_addresses.mdwn
+++ b/doc/bugs/git-annex_incorrectly_parses_bare_IPv6_addresses.mdwn
@@ -41,3 +41,19 @@ git-annex: bad url ssh://[2001/~/0:53aa:64c:24ef:5ce4:2ef9:cdda]:/home/paulprote
 (Note that both these .git/config entries work fine with "git fetch".)
 
 -- Asheesh.
+
+> Technically, this seems to be a bug in the haskell URI library; it honors
+> the `[]` in parsing, but does not remove them when the URI is queried for
+> the host part. 
+
+<pre>
+Prelude Network.URI> let (Just u) = parseURI "http://foo@[2001:0:53aa:64c:24ef:5ce4:2ef9:cdda]/bar"
+Prelude Network.URI> let (Just a) = uriAuthority u
+Prelude Network.URI> uriRegName a
+"[2001:0:53aa:64c:24ef:5ce4:2ef9:cdda]"
+Prelude Network.URI> isIPv6address $ uriRegName a
+False
+</pre>
+
+> I have filed a [bug upstream](http://trac.haskell.org/network/ticket/40), and put a workaround in git-annex. [[done]]
+> --[[Joey]]