improve GitRepos functions for pulling apart URL to repo

Command/Map.hs

@@ -161,7 +161,7 @@ absRepo reference r
 {- Checks if two repos are the same. -}
 same :: Git.Repo -> Git.Repo -> Bool
 same a b
-	| both Git.repoIsSsh = matching Git.urlHostFull && matching Git.workTree
+	| both Git.repoIsSsh = matching Git.urlAuthority && matching Git.workTree
 	| both Git.repoIsUrl && neither Git.repoIsSsh = matching show
 	| neither Git.repoIsSsh = matching Git.workTree
 	| otherwise = False
@@ -210,7 +210,7 @@ tryScan r
 				"git config --list"
 			liftIO $ pipedconfig "ssh" $ map Param $ 
 					words sshoptions ++
-					[Git.urlHostFull r, sshcmd]
+					[Git.urlAuthority r, sshcmd]
 
 		-- First, try sshing and running git config manually,
 		-- only fall back to git-annex-shell configlist if that

GitRepo.hs

@@ -24,7 +24,9 @@ module GitRepo (
 	relative,
 	urlPath,
 	urlHost,
-	urlHostFull,
+	urlPort,
+	urlHostUser,
+	urlAuthority,
 	urlScheme,
 	configGet,
 	configMap,
@@ -131,7 +133,7 @@ localToUrl reference r
 	where
 		absurl =
 			urlScheme reference ++ "//" ++
-			urlHostFull reference ++
+			urlAuthority reference ++
 			workTree r
 
 {- User-visible description of a git repo. -}
@@ -235,29 +237,45 @@ relative repo@(Repo { location = Dir d }) file = do
 			Nothing -> error $ file ++ " is not located inside git repository " ++ absrepo
 relative repo _ = assertLocal repo $ error "internal"
 
+{- Path of an URL repo. -}
+urlPath :: Repo -> String
+urlPath Repo { location = Url u } = uriPath u
+urlPath repo = assertUrl repo $ error "internal"
+
 {- Scheme of an URL repo. -}
 urlScheme :: Repo -> String
 urlScheme Repo { location = Url u } = uriScheme u
 urlScheme repo = assertUrl repo $ error "internal"
 
-{- Hostname of an URL repo. (May include a username and/or port too.) -}
+{- Hostname of an URL repo. -}
 urlHost :: Repo -> String
-urlHost Repo { location = Url u } = uriRegName a
+urlHost = urlAuthPart uriRegName
+
+{- Port of an URL repo, if it has a nonstandard one. -}
+urlPort :: Repo -> Maybe Integer
+urlPort r = 
+	case urlAuthPart uriPort r of
+		":" -> Nothing
+		(':':p) -> Just (read p)
+		_ -> Nothing
+
+{- Hostname of an URL repo, including any username (ie, "user@host") -}
+urlHostUser :: Repo -> String
+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
 	where
 		a = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
-urlHost repo = assertUrl repo $ error "internal"
+urlAuthority repo = assertUrl repo $ error "internal"
 
-{- Full hostname of an URL repo. (May include a username and/or port too.) -}
+{- Applies a function to extract part of the uriAuthority of an URL repo. -}
-urlHostFull :: Repo -> String
+urlAuthPart :: (URIAuth -> a) -> Repo -> a
-urlHostFull Repo { location = Url u } = uriUserInfo a ++ uriRegName a ++ uriPort a
+urlAuthPart a Repo { location = Url u } = a auth
 	where
-		a = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
+		auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
-urlHostFull repo = assertUrl repo $ error "internal"
+urlAuthPart _ repo = assertUrl repo $ error "internal"
-
-{- Path of an URL repo. -}
-urlPath :: Repo -> String
-urlPath Repo { location = Url u } = uriPath u
-urlPath repo = assertUrl repo $ error "internal"
 
 {- Constructs a git command line operating on the specified repo. -}
 gitCommandLine :: Repo -> [CommandParam] -> [CommandParam]

Remotes.hs

@@ -318,7 +318,7 @@ git_annex_shell r command params
 	| Git.repoIsSsh r = do
 		sshoptions <- repoConfig r "ssh-options" ""
 		return $ Just ("ssh", map Param (words sshoptions) ++ 
-			[Param (Git.urlHostFull r), Param sshcmd])
+			[Param (Git.urlAuthority r), Param sshcmd])
 	| otherwise = return Nothing
 	where
 		dir = Git.workTree r