src/LWN/URI.hs

   1 module LWN.URI
   2 where
   3
   4 import Data.List (isSuffixOf)
   5 import Data.Maybe (fromJust)
   6 import Data.String.Utils (split)
   7 import Network.URI (
   8   URI(..),
   9   URIAuth(..),
  10   parseAbsoluteURI,
  11   parseURIReference,
  12   relativeTo,
  13   uriRegName
  14   )
  15 import Test.HUnit (Assertion, assertEqual)
  16 import Test.Framework (Test, testGroup)
  17 import Test.Framework.Providers.HUnit (testCase)
  18 import Text.Regex.Posix ((=~))
  19
  20 -- Distinguish between URLs (Strings) and URIs as provided by the
  21 -- Network.URI module.
  22 type URL = String
  23
  24
  25 -- | Is this URI's scheme plain HTTP?
  26 http :: URI -> Bool
  27 http uri = (uriScheme uri) == "http:"
  28
  29 -- | Is this URI's scheme (secure) HTTPS?
  30 https :: URI -> Bool
  31 https uri = (uriScheme uri) == "https:"
  32
  33 -- | Does this URI use an HTTP-compatible port?
  34 http_port :: URI -> Bool
  35 http_port uri =
  36   case parse_result of
  37     Nothing -> False
  38     Just auth ->
  39       (uriPort auth) `elem` ["", ":80"]
  40   where
  41     parse_result = uriAuthority uri
  42
  43
  44 make_https :: URL -> URL
  45 make_https url =
  46   case parse_result of
  47     Nothing -> url -- Shrug?
  48     Just uri ->
  49       if http uri then
  50         show $ uri { uriScheme = "https:" }
  51       else
  52         url -- Leave non-http URLs alone.
  53   where
  54     parse_result = parseURIReference url
  55
  56
  57 add_trailing_slash :: URL -> URL
  58 add_trailing_slash url =
  59   case parse_result of
  60     Nothing -> url -- Shrug?
  61     Just uri ->
  62       let old_path = uriPath uri in
  63         if (isSuffixOf "/" old_path) || (isSuffixOf "bigpage" old_path) then
  64           -- It already had a trailing slash, or it's a 'bigpage' URL.
  65           -- Trailing slashes after 'bigpage' don't work.
  66           url
  67         else
  68           show $ uri { uriPath = old_path ++ "/" }
  69   where
  70     parse_result = parseURIReference url
  71
  72
  73 -- | Does this URI use an HTTPS-compatible port?
  74 https_port :: URI -> Bool
  75 https_port uri =
  76   case parse_result of
  77     Nothing -> False
  78     Just auth ->
  79       (uriPort auth) `elem` ["", ":443"]
  80   where
  81     parse_result = uriAuthority uri
  82
  83
  84 -- | Does this URL have one of the LWN hostnames?
  85 lwn_host :: URI -> Bool
  86 lwn_host uri =
  87   case parse_result of
  88     Nothing -> False
  89     Just auth ->
  90       (uriRegName auth) `elem` ["lwn.net", "www.lwn.net"]
  91   where
  92     parse_result = uriAuthority uri
  93
  94
  95 -- | Is the protocol portion of this URI one of the ones that LWN
  96 --   uses?
  97 lwn_proto :: URI -> Bool
  98 lwn_proto u =
  99   ((http u) && (http_port u)) || ((https u) && (https_port u))
 100
 101 -- | Is the server/port to which we're connecting an LWN server?
 102 lwn_server :: URI -> Bool
 103 lwn_server u =
 104   lwn_proto u && lwn_host u
 105
 106 -- | Is this URI's path for an LWN article?
 107 lwn_article_path :: URI -> Bool
 108 lwn_article_path uri =
 109   path =~ "^/current(/bigpage)?/?$" ||
 110   path =~ "^/Articles/[0-9]+(/bigpage)?/?$"
 111   where
 112     path = uriPath uri
 113
 114 -- | Is this URI's query one that the LWN uses? The only query string
 115 --   that the LWN articles use is the printable page one.
 116 lwn_query :: URI -> Bool
 117 lwn_query uri =
 118   query `elem` ["", "?format=printable"]
 119   where
 120     query = uriQuery uri
 121
 122 -- | Combine all of the other URI tests to determine if this 'URL'
 123 --   belongs to an LWN article.
 124 is_lwn_url :: URL -> Bool
 125 is_lwn_url s =
 126   case parse_result of
 127     Nothing -> False
 128     Just uri -> (lwn_server uri) && (lwn_article_path uri) && (lwn_query uri)
 129   where
 130     parse_result = parseAbsoluteURI s
 131
 132
 133
 134 -- Bug here, doesn't work on unicode paths!
 135 filename :: URL -> Maybe String
 136 filename url =
 137   case parse_result of
 138     Nothing -> Nothing
 139     Just uri ->
 140       let components = split "/" (uriPath uri) in
 141       -- Reverse them so that the filename comes first for easier
 142       -- pattern-matching.
 143       let reverse_components = reverse components in
 144       case reverse_components of
 145         []     -> Nothing
 146         (x:_) -> Just x
 147   where
 148     parse_result = parseURIReference url
 149
 150
 151
 152 make_absolute_uri :: URI -> Maybe URI
 153 make_absolute_uri relative_uri =
 154   relativeTo relative_uri base_uri
 155   where
 156     base_auth = URIAuth { uriUserInfo = "",
 157                           uriRegName = "lwn.net",
 158                           uriPort = "" }
 159     base_uri = URI { uriScheme = "https:",
 160                      uriAuthority = Just base_auth,
 161                      uriPath = "/",
 162                      uriQuery = "",
 163                      uriFragment = "" }
 164
 165
 166 make_absolute_url :: URL -> Maybe URL
 167 make_absolute_url relative_url =
 168   case parse_result of
 169     Nothing -> Nothing
 170     Just relative_uri ->
 171       let abs_result = make_absolute_uri relative_uri in
 172       case abs_result of
 173         Nothing -> Nothing
 174         Just abs_uri -> Just $ show abs_uri
 175   where
 176     parse_result = parseURIReference relative_url
 177
 178 -- | Like 'make_absolute_url', except returns its input instead of
 179 --   'Nothing' if the absolution fails.
 180 try_make_absolute_url :: URL -> URL
 181 try_make_absolute_url url =
 182   case make_absolute_url url of
 183     Nothing -> url
 184     Just abs_url -> abs_url
 185
 186 -- | A List of LWN URLs to use during testing.
 187 lwn_urls :: [URL]
 188 lwn_urls = [ proto ++ www ++ "lwn.net" ++ path ++ bigpage ++ query |
 189               proto   <- ["http://", "https://"],
 190               www     <- ["", "www."],
 191               bigpage <- ["", "/bigpage"],
 192               query   <- ["", "?format=printable"],
 193               path    <- [ "/current",
 194                           "/Articles/500844",
 195                           "/Articles/502371" ] ]
 196
 197 test_lwn_urls_matched :: Assertion
 198 test_lwn_urls_matched =
 199   assertEqual "All LWN URLs matched" True (all is_lwn_url lwn_urls)
 200
 201 test_http_uris_matched :: Assertion
 202 test_http_uris_matched =
 203   assertEqual (url ++ " is HTTP") True (http uri)
 204   where
 205     url = "http://lwn.net/Articles/500844/bigpage"
 206     uri = fromJust $ parseAbsoluteURI url
 207
 208 test_https_uris_matched :: Assertion
 209 test_https_uris_matched =
 210   assertEqual (url ++ " is HTTPS") True (https uri)
 211   where
 212     url = "https://lwn.net/Articles/500844/bigpage"
 213     uri = fromJust $ parseAbsoluteURI url
 214
 215
 216 test_bare_filename_parsed :: Assertion
 217 test_bare_filename_parsed =
 218   assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
 219   where
 220     url = "example.jpg"
 221     actual_result = fromJust $ filename url
 222
 223 test_absolute_filename_parsed :: Assertion
 224 test_absolute_filename_parsed =
 225   assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
 226   where
 227     url = "http://lwn.net/one/two/example.jpg"
 228     actual_result = fromJust $ filename url
 229
 230 test_relative_filename_parsed :: Assertion
 231 test_relative_filename_parsed =
 232   assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
 233   where
 234     url = "/one/two/example.jpg"
 235     actual_result = fromJust $ filename url
 236
 237
 238 test_empty_url_conversion :: Assertion
 239 test_empty_url_conversion =
 240   assertEqual "'' converted to lwn.net" expected actual
 241   where
 242     expected = "https://lwn.net/"
 243     actual = fromJust $ make_absolute_url ""
 244
 245
 246 test_normal_url_conversion :: Assertion
 247 test_normal_url_conversion =
 248   assertEqual "Image URL is made absolute" expected actual
 249   where
 250     url = "/images/2012/lcj-coughlan-lattimer-sm.jpg"
 251     expected = "https://lwn.net/images/2012/lcj-coughlan-lattimer-sm.jpg"
 252     actual = fromJust $ make_absolute_url url
 253
 254
 255
 256 test_make_https :: Assertion
 257 test_make_https =
 258   assertEqual "HTTP URL is made HTTPS" expected actual
 259   where
 260     url = "http://lwn.net/current"
 261     expected = "https://lwn.net/current"
 262     actual = make_https url
 263
 264
 265 test_add_trailing_slash :: Assertion
 266 test_add_trailing_slash =
 267   assertEqual "Trailing slashes get added" expected actual
 268   where
 269     url = "https://lwn.net/current"
 270     expected = "https://lwn.net/current/"
 271     actual = add_trailing_slash url
 272
 273
 274 uri_tests :: Test
 275 uri_tests =
 276   testGroup "URI Tests" [
 277
 278     testGroup "URI Matching" [
 279       testCase "HTTP URIs matched" test_http_uris_matched,
 280       testCase "HTTPS URIs matched" test_https_uris_matched,
 281       testCase "LWN URLs matched" test_lwn_urls_matched ],
 282
 283     testGroup "Filename Parsing" [
 284       testCase "Bare filename parsed" test_bare_filename_parsed,
 285       testCase "Absolute filename parsed" test_absolute_filename_parsed,
 286       testCase "Relative filename parsed" test_relative_filename_parsed ],
 287
 288     testGroup "Relative -> Absolute Conversion" [
 289       testCase "Empty URL converted to lwn.net" test_empty_url_conversion,
 290       testCase "Normal URL made absolute" test_normal_url_conversion ],
 291
 292     testGroup "URL Mangling" [
 293       testCase "HTTP URLs are made HTTPS" test_make_https,
 294       testCase "Trailing slashes get added" test_add_trailing_slash ]
 295     ]