diff options
| -rw-r--r-- | Command/Map.hs | 2 | ||||
| -rw-r--r-- | Git/Construct.hs | 18 | ||||
| -rw-r--r-- | Git/Url.hs | 23 | ||||
| -rw-r--r-- | Remote/Helper/Ssh.hs | 2 | ||||
| -rw-r--r-- | debian/changelog | 1 |
5 files changed, 25 insertions, 21 deletions
diff --git a/Command/Map.hs b/Command/Map.hs index 41beb4b92..91f4a0251 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 6514b80bc..cd998591e 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 7befc4669..d383a6aca 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 35655f00b..8cf9275a0 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 1a8e31718..f8d49df09 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 |