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