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

diff --git a/src/LWN/URI.hs b/src/LWN/URI.hs
index 61ea6ca..7aa4240 100644
--- a/src/LWN/URI.hs
+++ b/src/LWN/URI.hs
@@ -2,20 +2,19 @@ module LWN.URI
 where
 
 import Data.Maybe (fromJust)
+import Data.String.Utils (split)
 import Network.URI (
-  URI,
+  URI(..),
+  URIAuth(..),
   parseAbsoluteURI,
-  uriAuthority,
-  uriPath,
-  uriPort,
-  uriQuery,
-  uriRegName,
-  uriScheme
+  parseURIReference,
+  relativeTo,
+  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.
@@ -41,6 +40,19 @@ 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
+
+
 -- | Does this URI use an HTTPS-compatible port?
 https_port :: URI -> Bool
 https_port uri =
@@ -101,6 +113,58 @@ is_lwn_url s =
     parse_result = parseAbsoluteURI s
 
 
+
+filename :: URL -> Maybe String
+filename url =
+  case parse_result of
+    Nothing -> Nothing
+    Just uri ->
+      let components = split "/" (uriPath uri) in
+      -- Reverse them so that the filename comes first for easier
+      -- pattern-matching.
+      let reverse_components = reverse components in
+      case reverse_components of
+        []     -> Nothing
+        (x:_) -> Just x
+  where
+    parse_result = parseURIReference url
+
+
+
+make_absolute_uri :: URI -> Maybe URI
+make_absolute_uri relative_uri =
+  relativeTo relative_uri base_uri
+  where
+    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 =    
+  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
+  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]
 lwn_urls = [ proto ++ www ++ "lwn.net" ++ path ++ bigpage ++ query |
@@ -130,9 +194,60 @@ test_https_uris_matched =
     url = "https://lwn.net/Articles/500844/bigpage"
     uri = fromJust $ parseAbsoluteURI url
 
+
+test_bare_filename_parsed :: Assertion
+test_bare_filename_parsed =
+  assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
+  where
+    url = "example.jpg"
+    actual_result = fromJust $ filename url
+
+test_absolute_filename_parsed :: Assertion
+test_absolute_filename_parsed =
+  assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
+  where
+    url = "http://lwn.net/one/two/example.jpg"
+    actual_result = fromJust $ filename url
+
+test_relative_filename_parsed :: Assertion
+test_relative_filename_parsed =
+  assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
+  where
+    url = "/one/two/example.jpg"
+    actual_result = fromJust $ filename url
+
+
+test_empty_url_conversion :: Assertion
+test_empty_url_conversion =
+  assertEqual "'' converted to lwn.net" expected actual
+  where
+    expected = "https://lwn.net/"
+    actual = fromJust $ make_absolute_url ""
+
+
+test_normal_url_conversion :: Assertion
+test_normal_url_conversion =
+  assertEqual "Image URL is made absolute" expected actual
+  where
+    url = "/images/2012/lcj-coughlan-lattimer-sm.jpg"
+    expected = "https://lwn.net/images/2012/lcj-coughlan-lattimer-sm.jpg"
+    actual = fromJust $ make_absolute_url url
+
+
 uri_tests :: Test
 uri_tests =
   testGroup "URI Tests" [
-    testCase "HTTP URIs matched" test_http_uris_matched,
-    testCase "HTTPS URIs matched" test_https_uris_matched,
-    testCase "LWN URLs matched" test_lwn_urls_matched ]
+
+    testGroup "URI Matching" [
+      testCase "HTTP URIs matched" test_http_uris_matched,
+      testCase "HTTPS URIs matched" test_https_uris_matched,
+      testCase "LWN URLs matched" test_lwn_urls_matched ],
+
+    testGroup "Filename Parsing" [
+      testCase "Bare filename parsed" test_bare_filename_parsed,
+      testCase "Absolute filename parsed" test_absolute_filename_parsed,
+      testCase "Relative filename parsed" test_relative_filename_parsed ],
+
+    testGroup "Relative -> Absolute Conversion" [
+      testCase "Empty URL converted to lwn.net" test_empty_url_conversion,
+      testCase "Normal URL made absolute" test_normal_url_conversion ]]