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

@ -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