map: Work when there are gcrypt remotes.

This commit is contained in:
Joey Hess 2013-11-04 14:14:44 -04:00
parent 832598d1d9
commit 58db042033
5 changed files with 25 additions and 21 deletions

View file

@ -74,7 +74,7 @@ drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others
hostname :: Git.Repo -> String hostname :: Git.Repo -> String
hostname r hostname r
| Git.repoIsUrl r = Git.Url.host r | Git.repoIsUrl r = fromMaybe (Git.repoLocation r) (Git.Url.host r)
| otherwise = "localhost" | otherwise = "localhost"
basehostname :: Git.Repo -> String basehostname :: Git.Repo -> String

View file

@ -104,14 +104,16 @@ localToUrl :: Repo -> Repo -> Repo
localToUrl reference r localToUrl reference r
| not $ repoIsUrl reference = error "internal error; reference repo not url" | not $ repoIsUrl reference = error "internal error; reference repo not url"
| repoIsUrl r = r | repoIsUrl r = r
| otherwise = r { location = Url $ fromJust $ parseURI absurl } | otherwise = case Url.authority reference of
where Nothing -> r
absurl = concat Just auth ->
let absurl = concat
[ Url.scheme reference [ Url.scheme reference
, "//" , "//"
, Url.authority reference , auth
, repoPath r , repoPath r
] ]
in r { location = Url $ fromJust $ parseURI absurl }
{- Calculates a list of a repo's configured remotes, by parsing its config. -} {- Calculates a list of a repo's configured remotes, by parsing its config. -}
fromRemotes :: Repo -> IO [Repo] fromRemotes :: Repo -> IO [Repo]

View file

@ -37,32 +37,33 @@ uriRegName' a = fixup $ uriRegName a
fixup x = x fixup x = x
{- Hostname of an URL repo. -} {- Hostname of an URL repo. -}
host :: Repo -> String host :: Repo -> Maybe String
host = authpart uriRegName' host = authpart uriRegName'
{- Port of an URL repo, if it has a nonstandard one. -} {- Port of an URL repo, if it has a nonstandard one. -}
port :: Repo -> Maybe Integer port :: Repo -> Maybe Integer
port r = port r =
case authpart uriPort r of case authpart uriPort r of
":" -> Nothing Nothing -> Nothing
(':':p) -> readish p Just ":" -> Nothing
_ -> Nothing Just (':':p) -> readish p
Just _ -> Nothing
{- Hostname of an URL repo, including any username (ie, "user@host") -} {- Hostname of an URL repo, including any username (ie, "user@host") -}
hostuser :: Repo -> String hostuser :: Repo -> Maybe String
hostuser r = authpart uriUserInfo r ++ authpart uriRegName' r hostuser r = (++)
<$> authpart uriUserInfo r
<*> authpart uriRegName' r
{- The full authority portion an URL repo. (ie, "user@host:port") -} {- The full authority portion an URL repo. (ie, "user@host:port") -}
authority :: Repo -> String authority :: Repo -> Maybe String
authority = authpart assemble authority = authpart assemble
where where
assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
{- Applies a function to extract part of the uriAuthority of an URL repo. -} {- Applies a function to extract part of the uriAuthority of an URL repo. -}
authpart :: (URIAuth -> a) -> Repo -> a authpart :: (URIAuth -> a) -> Repo -> Maybe a
authpart a Repo { location = Url u } = a auth authpart a Repo { location = Url u } = a <$> uriAuthority u
where
auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
authpart _ repo = notUrl repo authpart _ repo = notUrl repo
notUrl :: Repo -> a notUrl :: Repo -> a

View file

@ -30,7 +30,7 @@ toRepo r sshcmd = do
g <- fromRepo id g <- fromRepo id
let c = extractRemoteGitConfig g (Git.repoDescribe r) let c = extractRemoteGitConfig g (Git.repoDescribe r)
let opts = map Param $ remoteAnnexSshOptions c 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 params <- sshCachingOptions (host, Git.Url.port r) opts
return $ params ++ Param host : sshcmd return $ params ++ Param host : sshcmd

1
debian/changelog vendored
View file

@ -11,6 +11,7 @@ git-annex (4.20131102) UNRELEASED; urgency=low
with permission denied. with permission denied.
* Fix zombie process that occurred when switching between repository * Fix zombie process that occurred when switching between repository
views in the webapp. views in the webapp.
* map: Work when there are gcrypt remotes.
-- Joey Hess <joeyh@debian.org> Sat, 02 Nov 2013 14:54:36 -0400 -- Joey Hess <joeyh@debian.org> Sat, 02 Nov 2013 14:54:36 -0400