module LWN.URI
where
+import Data.List (isSuffixOf)
import Data.Maybe (fromJust)
import Data.String.Utils (split)
import Network.URI (
URI(..),
+ URIAuth(..),
parseAbsoluteURI,
parseURIReference,
relativeTo,
- uriRegName,
+ uriRegName
)
import Test.HUnit (Assertion, assertEqual)
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
-import Text.Regex.Posix
+import Text.Regex.Posix ((=~))
-- Distinguish between URLs (Strings) and URIs as provided by the
-- Network.URI module.
parse_result = uriAuthority uri
+make_https :: URL -> URL
+make_https url =
+ case parse_result of
+ Nothing -> url -- Shrug?
+ Just uri ->
+ if http uri then
+ show $ uri { uriScheme = "https:" }
+ else
+ url -- Leave non-http URLs alone.
+ where
+ parse_result = parseURIReference url
+
+
+add_trailing_slash :: URL -> URL
+add_trailing_slash url =
+ case parse_result of
+ Nothing -> url -- Shrug?
+ Just uri ->
+ let old_path = uriPath uri in
+ if (isSuffixOf "/" old_path) || (isSuffixOf "bigpage" old_path) then
+ -- It already had a trailing slash, or it's a 'bigpage' URL.
+ -- Trailing slashes after 'bigpage' don't work.
+ url
+ else
+ show $ uri { uriPath = old_path ++ "/" }
+ where
+ parse_result = parseURIReference url
+
+
-- | Does this URI use an HTTPS-compatible port?
https_port :: URI -> Bool
https_port uri =
let reverse_components = reverse components in
case reverse_components of
[] -> Nothing
- (x:xs) -> Just x
+ (x:_) -> Just x
where
parse_result = parseURIReference url
make_absolute_uri relative_uri =
relativeTo relative_uri base_uri
where
- base_uri = URI { uriScheme = "https://",
- uriAuthority = "lwn.net",
+ base_auth = URIAuth { uriUserInfo = "",
+ uriRegName = "lwn.net",
+ uriPort = "" }
+ base_uri = URI { uriScheme = "https:",
+ uriAuthority = Just base_auth,
uriPath = "/",
uriQuery = "",
uriFragment = "" }
make_absolute_url :: URL -> Maybe URL
-make_absolute_url relative_url =
+make_absolute_url relative_url =
case parse_result of
Nothing -> Nothing
Just relative_uri ->
let abs_result = make_absolute_uri relative_uri in
case abs_result of
Nothing -> Nothing
- Just abs_uri -> show abs_uri
+ Just abs_uri -> Just $ show abs_uri
where
- parse_result = parseURIReference url
-
+ parse_result = parseURIReference relative_url
+-- | Like 'make_absolute_url', except returns its input instead of
+-- 'Nothing' if the absolution fails.
+try_make_absolute_url :: URL -> URL
+try_make_absolute_url url =
+ case make_absolute_url url of
+ Nothing -> url
+ Just abs_url -> abs_url
-- | A List of LWN URLs to use during testing.
lwn_urls :: [URL]
actual = fromJust $ make_absolute_url url
+
+test_make_https :: Assertion
+test_make_https =
+ assertEqual "HTTP URL is made HTTPS" expected actual
+ where
+ url = "http://lwn.net/current"
+ expected = "https://lwn.net/current"
+ actual = make_https url
+
+
+test_add_trailing_slash :: Assertion
+test_add_trailing_slash =
+ assertEqual "Trailing slashes get added" expected actual
+ where
+ url = "https://lwn.net/current"
+ expected = "https://lwn.net/current/"
+ actual = add_trailing_slash url
+
+
uri_tests :: Test
uri_tests =
testGroup "URI Tests" [
testGroup "Relative -> Absolute Conversion" [
testCase "Empty URL converted to lwn.net" test_empty_url_conversion,
- testCase "Normal URL made absolute" test_normal_url_conversion ]]
+ testCase "Normal URL made absolute" test_normal_url_conversion ],
+
+ testGroup "URL Mangling" [
+ testCase "HTTP URLs are made HTTPS" test_make_https,
+ testCase "Trailing slashes get added" test_add_trailing_slash ]
+ ]