1{- git repository urls
2 -
3 - Copyright 2010-2021 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8module Git.Url (
9	scheme,
10	host,
11	port,
12	hostuser,
13	authority,
14	path,
15) where
16
17import Network.URI hiding (scheme, authority, path)
18
19import Common
20import Git.Types
21
22{- Scheme of an URL repo. -}
23scheme :: Repo -> Maybe String
24scheme Repo { location = Url u } = Just (uriScheme u)
25scheme _ = Nothing
26
27{- Work around a bug in the real uriRegName
28 - <http://trac.haskell.org/network/ticket/40> -}
29uriRegName' :: URIAuth -> String
30uriRegName' a = fixup $ uriRegName a
31  where
32	fixup x@('[':rest)
33		| rest !! len == ']' = take len rest
34		| otherwise = x
35	  where
36		len  = length rest - 1
37	fixup x = x
38
39{- Hostname of an URL repo. -}
40host :: Repo -> Maybe String
41host = authpart uriRegName'
42
43{- Port of an URL repo, if it has a nonstandard one. -}
44port :: Repo -> Maybe Integer
45port r =
46	case authpart uriPort r of
47		Nothing -> Nothing
48		Just ":" -> Nothing
49		Just (':':p) -> readish p
50		Just _ -> Nothing
51
52{- Hostname of an URL repo, including any username (ie, "user@host") -}
53hostuser :: Repo -> Maybe String
54hostuser r = (++)
55	<$> authpart uriUserInfo r
56	<*> authpart uriRegName' r
57
58{- The full authority portion an URL repo. (ie, "user@host:port") -}
59authority :: Repo -> Maybe String
60authority = authpart assemble
61  where
62	assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
63
64{- Applies a function to extract part of the uriAuthority of an URL repo. -}
65authpart :: (URIAuth -> a) -> Repo -> Maybe a
66authpart a Repo { location = Url u } = a <$> uriAuthority u
67authpart _ _ = Nothing
68
69{- Path part of an URL repo. -}
70path :: Repo -> Maybe FilePath
71path Repo { location = Url u } = Just (uriPath u)
72path _ = Nothing
73