map: Work when there are gcrypt remotes.
This commit is contained in:
parent
832598d1d9
commit
58db042033
5 changed files with 25 additions and 21 deletions
23
Git/Url.hs
23
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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue