X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Flwn-epub.git;a=blobdiff_plain;f=src%2FLWN%2FURI.hs;h=7a0a41f026a893881d90b546743e6624ede117c7;hp=7aa4240cf146eee312801881100ce43be087b6e5;hb=HEAD;hpb=b18c060e5cb708901eb29f1f27b25c467875a143

diff --git a/src/LWN/URI.hs b/src/LWN/URI.hs
index 7aa4240..7a0a41f 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 (
@@ -53,6 +54,22 @@ make_https url =
     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 =
@@ -114,6 +131,7 @@ is_lwn_url s =
 
 
 
+-- Bug here, doesn't work on unicode paths!
 filename :: URL -> Maybe String
 filename url =
   case parse_result of
@@ -131,7 +149,7 @@ filename url =
 
 
 
-make_absolute_uri :: URI -> Maybe URI
+make_absolute_uri :: URI -> URI
 make_absolute_uri relative_uri =
   relativeTo relative_uri base_uri
   where
@@ -146,14 +164,11 @@ make_absolute_uri relative_uri =
 
 
 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 -> Just $ show abs_uri
+      Just $ show $ make_absolute_uri relative_uri
   where
     parse_result = parseURIReference relative_url
 
@@ -234,6 +249,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" [
@@ -250,4 +284,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 ]
+    ]