From 58db0420338616def2875b35274dce8c58cade08 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Mon, 4 Nov 2013 14:14:44 -0400
Subject: [PATCH] map: Work when there are gcrypt remotes.

---
 Command/Map.hs       |  2 +-
 Git/Construct.hs     | 18 ++++++++++--------
 Git/Url.hs           | 23 ++++++++++++-----------
 Remote/Helper/Ssh.hs |  2 +-
 debian/changelog     |  1 +
 5 files changed, 25 insertions(+), 21 deletions(-)

diff --git a/Command/Map.hs b/Command/Map.hs
index 41beb4b92b..91f4a02510 100644
--- a/Command/Map.hs
+++ b/Command/Map.hs
@@ -74,7 +74,7 @@ drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others
 
 hostname :: Git.Repo -> String
 hostname r
-	| Git.repoIsUrl r = Git.Url.host r
+	| Git.repoIsUrl r = fromMaybe (Git.repoLocation r) (Git.Url.host r)
 	| otherwise = "localhost"
 
 basehostname :: Git.Repo -> String
diff --git a/Git/Construct.hs b/Git/Construct.hs
index 6514b80bce..cd998591e8 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -104,14 +104,16 @@ localToUrl :: Repo -> Repo -> Repo
 localToUrl reference r
 	| not $ repoIsUrl reference = error "internal error; reference repo not url"
 	| repoIsUrl r = r
-	| otherwise = r { location = Url $ fromJust $ parseURI absurl }
-  where
-	absurl = concat
-		[ Url.scheme reference
-		, "//"
-		, Url.authority reference
-		, repoPath r
-		]
+	| otherwise = case Url.authority reference of
+		Nothing -> r
+		Just auth -> 
+			let absurl = concat
+				[ Url.scheme reference
+				, "//"
+				, auth
+				, repoPath r
+				]
+			in r { location = Url $ fromJust $ parseURI absurl }
 
 {- Calculates a list of a repo's configured remotes, by parsing its config. -}
 fromRemotes :: Repo -> IO [Repo]
diff --git a/Git/Url.hs b/Git/Url.hs
index 7befc46690..d383a6acab 100644
--- a/Git/Url.hs
+++ b/Git/Url.hs
@@ -37,32 +37,33 @@ uriRegName' a = fixup $ uriRegName a
 	fixup x = x
 
 {- Hostname of an URL repo. -}
-host :: Repo -> String
+host :: Repo -> Maybe String
 host = authpart uriRegName'
 
 {- Port of an URL repo, if it has a nonstandard one. -}
 port :: Repo -> Maybe Integer
 port r = 
 	case authpart uriPort r of
-		":" -> Nothing
-		(':':p) -> readish p
-		_ -> Nothing
+		Nothing -> Nothing
+		Just ":" -> Nothing
+		Just (':':p) -> readish p
+		Just _ -> Nothing
 
 {- Hostname of an URL repo, including any username (ie, "user@host") -}
-hostuser :: Repo -> String
-hostuser r = authpart uriUserInfo r ++ authpart uriRegName' r
+hostuser :: Repo -> Maybe String
+hostuser r = (++)
+	<$> authpart uriUserInfo r
+	<*> authpart uriRegName' r
 
 {- The full authority portion an URL repo. (ie, "user@host:port") -}
-authority :: Repo -> String
+authority :: Repo -> Maybe String
 authority = authpart assemble
   where
 	assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
 
 {- Applies a function to extract part of the uriAuthority of an URL repo. -}
-authpart :: (URIAuth -> a) -> Repo -> a
-authpart a Repo { location = Url u } = a auth
-  where
-	auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
+authpart :: (URIAuth -> a) -> Repo -> Maybe a
+authpart a Repo { location = Url u } = a <$> uriAuthority u
 authpart _ repo = notUrl repo
 
 notUrl :: Repo -> a
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index 35655f00b2..8cf9275a0c 100644
--- a/Remote/Helper/Ssh.hs
+++ b/Remote/Helper/Ssh.hs
@@ -30,7 +30,7 @@ toRepo r sshcmd = do
 	g <- fromRepo id
 	let c = extractRemoteGitConfig g (Git.repoDescribe r)
 	let opts = map Param $ remoteAnnexSshOptions c
-	let host = Git.Url.hostuser r
+	let host = fromMaybe (error "bad ssh url") $ Git.Url.hostuser r
 	params <- sshCachingOptions (host, Git.Url.port r) opts
 	return $ params ++ Param host : sshcmd
 
diff --git a/debian/changelog b/debian/changelog
index 1a8e317186..f8d49df09f 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -11,6 +11,7 @@ git-annex (4.20131102) UNRELEASED; urgency=low
     with permission denied.
   * Fix zombie process that occurred when switching between repository
     views in the webapp.
+  * map: Work when there are gcrypt remotes.
 
  -- Joey Hess <joeyh@debian.org>  Sat, 02 Nov 2013 14:54:36 -0400