X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Flwn-epub.git;a=blobdiff_plain;f=src%2FLWN%2FURI.hs;h=3a21413dbf3feab89967ada01da9e13c9bb61531;hp=5e61eb6272ad588a09105083bf0e08214db0d7ca;hb=03360100f3375abab128144b0851d043a96bacbc;hpb=7e8da46abac090b44726946d8e3275f7b9361953

diff --git a/src/LWN/URI.hs b/src/LWN/URI.hs
index 5e61eb6..3a21413 100644
--- a/src/LWN/URI.hs
+++ b/src/LWN/URI.hs
@@ -1,6 +1,7 @@
 module LWN.URI
 where
 
+import Data.List (isSuffixOf)
 import Data.Maybe (fromJust)
 import Data.String.Utils (split)
 import Network.URI (
@@ -14,7 +15,7 @@ import Network.URI (
 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.
@@ -40,6 +41,34 @@ http_port uri =
     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 then
+          url -- It already had a trailing slash
+        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 =
@@ -112,7 +141,7 @@ filename url =
       let reverse_components = reverse components in
       case reverse_components of
         []     -> Nothing
-        (x:xs) -> Just x
+        (x:_) -> Just x
   where
     parse_result = parseURIReference url
 
@@ -144,7 +173,13 @@ make_absolute_url relative_url =
   where
     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]
@@ -215,6 +250,25 @@ test_normal_url_conversion =
     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" [
@@ -231,4 +285,9 @@ 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 ]
+    ]