4 import Data.List (isSuffixOf)
5 import Data.Maybe (fromJust)
6 import Data.String.Utils (split)
15 import Test.HUnit (Assertion, assertEqual)
16 import Test.Framework (Test, testGroup)
17 import Test.Framework.Providers.HUnit (testCase)
18 import Text.Regex.Posix ((=~))
20 -- Distinguish between URLs (Strings) and URIs as provided by the
21 -- Network.URI module.
25 -- | Is this URI's scheme plain HTTP?
27 http uri = (uriScheme uri) == "http:"
29 -- | Is this URI's scheme (secure) HTTPS?
31 https uri = (uriScheme uri) == "https:"
33 -- | Does this URI use an HTTP-compatible port?
34 http_port :: URI -> Bool
39 (uriPort auth) `elem` ["", ":80"]
41 parse_result = uriAuthority uri
44 make_https :: URL -> URL
47 Nothing -> url -- Shrug?
50 show $ uri { uriScheme = "https:" }
52 url -- Leave non-http URLs alone.
54 parse_result = parseURIReference url
57 add_trailing_slash :: URL -> URL
58 add_trailing_slash url =
60 Nothing -> url -- Shrug?
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.
68 show $ uri { uriPath = old_path ++ "/" }
70 parse_result = parseURIReference url
73 -- | Does this URI use an HTTPS-compatible port?
74 https_port :: URI -> Bool
79 (uriPort auth) `elem` ["", ":443"]
81 parse_result = uriAuthority uri
84 -- | Does this URL have one of the LWN hostnames?
85 lwn_host :: URI -> Bool
90 (uriRegName auth) `elem` ["lwn.net", "www.lwn.net"]
92 parse_result = uriAuthority uri
95 -- | Is the protocol portion of this URI one of the ones that LWN
97 lwn_proto :: URI -> Bool
99 ((http u) && (http_port u)) || ((https u) && (https_port u))
101 -- | Is the server/port to which we're connecting an LWN server?
102 lwn_server :: URI -> Bool
104 lwn_proto u && lwn_host u
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)?/?$"
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
118 query `elem` ["", "?format=printable"]
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
128 Just uri -> (lwn_server uri) && (lwn_article_path uri) && (lwn_query uri)
130 parse_result = parseAbsoluteURI s
134 -- Bug here, doesn't work on unicode paths!
135 filename :: URL -> Maybe String
140 let components = split "/" (uriPath uri) in
141 -- Reverse them so that the filename comes first for easier
143 let reverse_components = reverse components in
144 case reverse_components of
148 parse_result = parseURIReference url
152 make_absolute_uri :: URI -> Maybe URI
153 make_absolute_uri relative_uri =
154 relativeTo relative_uri base_uri
156 base_auth = URIAuth { uriUserInfo = "",
157 uriRegName = "lwn.net",
159 base_uri = URI { uriScheme = "https:",
160 uriAuthority = Just base_auth,
166 make_absolute_url :: URL -> Maybe URL
167 make_absolute_url relative_url =
171 let abs_result = make_absolute_uri relative_uri in
174 Just abs_uri -> Just $ show abs_uri
176 parse_result = parseURIReference relative_url
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
184 Just abs_url -> abs_url
186 -- | A List of LWN URLs to use during testing.
188 lwn_urls = [ proto ++ www ++ "lwn.net" ++ path ++ bigpage ++ query |
189 proto <- ["http://", "https://"],
191 bigpage <- ["", "/bigpage"],
192 query <- ["", "?format=printable"],
193 path <- [ "/current",
195 "/Articles/502371" ] ]
197 test_lwn_urls_matched :: Assertion
198 test_lwn_urls_matched =
199 assertEqual "All LWN URLs matched" True (all is_lwn_url lwn_urls)
201 test_http_uris_matched :: Assertion
202 test_http_uris_matched =
203 assertEqual (url ++ " is HTTP") True (http uri)
205 url = "http://lwn.net/Articles/500844/bigpage"
206 uri = fromJust $ parseAbsoluteURI url
208 test_https_uris_matched :: Assertion
209 test_https_uris_matched =
210 assertEqual (url ++ " is HTTPS") True (https uri)
212 url = "https://lwn.net/Articles/500844/bigpage"
213 uri = fromJust $ parseAbsoluteURI url
216 test_bare_filename_parsed :: Assertion
217 test_bare_filename_parsed =
218 assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
221 actual_result = fromJust $ filename url
223 test_absolute_filename_parsed :: Assertion
224 test_absolute_filename_parsed =
225 assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
227 url = "http://lwn.net/one/two/example.jpg"
228 actual_result = fromJust $ filename url
230 test_relative_filename_parsed :: Assertion
231 test_relative_filename_parsed =
232 assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
234 url = "/one/two/example.jpg"
235 actual_result = fromJust $ filename url
238 test_empty_url_conversion :: Assertion
239 test_empty_url_conversion =
240 assertEqual "'' converted to lwn.net" expected actual
242 expected = "https://lwn.net/"
243 actual = fromJust $ make_absolute_url ""
246 test_normal_url_conversion :: Assertion
247 test_normal_url_conversion =
248 assertEqual "Image URL is made absolute" expected actual
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
256 test_make_https :: Assertion
258 assertEqual "HTTP URL is made HTTPS" expected actual
260 url = "http://lwn.net/current"
261 expected = "https://lwn.net/current"
262 actual = make_https url
265 test_add_trailing_slash :: Assertion
266 test_add_trailing_slash =
267 assertEqual "Trailing slashes get added" expected actual
269 url = "https://lwn.net/current"
270 expected = "https://lwn.net/current/"
271 actual = add_trailing_slash url
276 testGroup "URI Tests" [
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 ],
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 ],
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 ],
292 testGroup "URL Mangling" [
293 testCase "HTTP URLs are made HTTPS" test_make_https,
294 testCase "Trailing slashes get added" test_add_trailing_slash ]