summaryrefslogtreecommitdiff
path: root/Git/Url.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2011-12-14 15:30:14 -0400
committerGravatar Joey Hess <joey@kitenet.net>2011-12-14 15:43:13 -0400
commit02f1bd2bf47d3ff49a222e9428ec27708ef55f64 (patch)
tree456548530c65850a829a1a85609070bc111de1b9 /Git/Url.hs
parent2b24e16a633575703a43e1fb991f34b290a1d7e4 (diff)
split more stuff out of Git.hs
Diffstat (limited to 'Git/Url.hs')
-rw-r--r--Git/Url.hs70
1 files changed, 70 insertions, 0 deletions
diff --git a/Git/Url.hs b/Git/Url.hs
new file mode 100644
index 000000000..6a893d92f
--- /dev/null
+++ b/Git/Url.hs
@@ -0,0 +1,70 @@
+{- git repository urls
+ -
+ - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.Url (
+ scheme,
+ host,
+ port,
+ hostuser,
+ authority,
+) where
+
+import Network.URI hiding (scheme, authority)
+
+import Common
+import Git.Types
+import Git
+
+{- Scheme of an URL repo. -}
+scheme :: Repo -> String
+scheme Repo { location = Url u } = uriScheme u
+scheme repo = notUrl repo
+
+{- Work around a bug in the real uriRegName
+ - <http://trac.haskell.org/network/ticket/40> -}
+uriRegName' :: URIAuth -> String
+uriRegName' a = fixup $ uriRegName a
+ where
+ fixup x@('[':rest)
+ | rest !! len == ']' = take len rest
+ | otherwise = x
+ where
+ len = length rest - 1
+ fixup x = x
+
+{- Hostname of an URL repo. -}
+host :: Repo -> 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) -> readMaybe p
+ _ -> Nothing
+
+{- Hostname of an URL repo, including any username (ie, "user@host") -}
+hostuser :: Repo -> String
+hostuser r = authpart uriUserInfo r ++ authpart uriRegName' r
+
+{- The full authority portion an URL repo. (ie, "user@host:port") -}
+authority :: Repo -> 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 _ repo = notUrl repo
+
+notUrl :: Repo -> a
+notUrl repo = error $
+ "acting on local git repo " ++ repoDescribe repo ++ " not supported"