Whitespace cleanup.
[dead/lwn-epub.git] / 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 filename :: URL -> Maybe String
135 filename url =
136 case parse_result of
137 Nothing -> Nothing
138 Just uri ->
139 let components = split "/" (uriPath uri) in
140 -- Reverse them so that the filename comes first for easier
141 -- pattern-matching.
142 let reverse_components = reverse components in
143 case reverse_components of
144 [] -> Nothing
145 (x:_) -> Just x
146 where
147 parse_result = parseURIReference url
148
149
150
151 make_absolute_uri :: URI -> Maybe URI
152 make_absolute_uri relative_uri =
153 relativeTo relative_uri base_uri
154 where
155 base_auth = URIAuth { uriUserInfo = "",
156 uriRegName = "lwn.net",
157 uriPort = "" }
158 base_uri = URI { uriScheme = "https:",
159 uriAuthority = Just base_auth,
160 uriPath = "/",
161 uriQuery = "",
162 uriFragment = "" }
163
164
165 make_absolute_url :: URL -> Maybe URL
166 make_absolute_url relative_url =
167 case parse_result of
168 Nothing -> Nothing
169 Just relative_uri ->
170 let abs_result = make_absolute_uri relative_uri in
171 case abs_result of
172 Nothing -> Nothing
173 Just abs_uri -> Just $ show abs_uri
174 where
175 parse_result = parseURIReference relative_url
176
177 -- | Like 'make_absolute_url', except returns its input instead of
178 -- 'Nothing' if the absolution fails.
179 try_make_absolute_url :: URL -> URL
180 try_make_absolute_url url =
181 case make_absolute_url url of
182 Nothing -> url
183 Just abs_url -> abs_url
184
185 -- | A List of LWN URLs to use during testing.
186 lwn_urls :: [URL]
187 lwn_urls = [ proto ++ www ++ "lwn.net" ++ path ++ bigpage ++ query |
188 proto <- ["http://", "https://"],
189 www <- ["", "www."],
190 bigpage <- ["", "/bigpage"],
191 query <- ["", "?format=printable"],
192 path <- [ "/current",
193 "/Articles/500844",
194 "/Articles/502371" ] ]
195
196 test_lwn_urls_matched :: Assertion
197 test_lwn_urls_matched =
198 assertEqual "All LWN URLs matched" True (all is_lwn_url lwn_urls)
199
200 test_http_uris_matched :: Assertion
201 test_http_uris_matched =
202 assertEqual (url ++ " is HTTP") True (http uri)
203 where
204 url = "http://lwn.net/Articles/500844/bigpage"
205 uri = fromJust $ parseAbsoluteURI url
206
207 test_https_uris_matched :: Assertion
208 test_https_uris_matched =
209 assertEqual (url ++ " is HTTPS") True (https uri)
210 where
211 url = "https://lwn.net/Articles/500844/bigpage"
212 uri = fromJust $ parseAbsoluteURI url
213
214
215 test_bare_filename_parsed :: Assertion
216 test_bare_filename_parsed =
217 assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
218 where
219 url = "example.jpg"
220 actual_result = fromJust $ filename url
221
222 test_absolute_filename_parsed :: Assertion
223 test_absolute_filename_parsed =
224 assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
225 where
226 url = "http://lwn.net/one/two/example.jpg"
227 actual_result = fromJust $ filename url
228
229 test_relative_filename_parsed :: Assertion
230 test_relative_filename_parsed =
231 assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
232 where
233 url = "/one/two/example.jpg"
234 actual_result = fromJust $ filename url
235
236
237 test_empty_url_conversion :: Assertion
238 test_empty_url_conversion =
239 assertEqual "'' converted to lwn.net" expected actual
240 where
241 expected = "https://lwn.net/"
242 actual = fromJust $ make_absolute_url ""
243
244
245 test_normal_url_conversion :: Assertion
246 test_normal_url_conversion =
247 assertEqual "Image URL is made absolute" expected actual
248 where
249 url = "/images/2012/lcj-coughlan-lattimer-sm.jpg"
250 expected = "https://lwn.net/images/2012/lcj-coughlan-lattimer-sm.jpg"
251 actual = fromJust $ make_absolute_url url
252
253
254
255 test_make_https :: Assertion
256 test_make_https =
257 assertEqual "HTTP URL is made HTTPS" expected actual
258 where
259 url = "http://lwn.net/current"
260 expected = "https://lwn.net/current"
261 actual = make_https url
262
263
264 test_add_trailing_slash :: Assertion
265 test_add_trailing_slash =
266 assertEqual "Trailing slashes get added" expected actual
267 where
268 url = "https://lwn.net/current"
269 expected = "https://lwn.net/current/"
270 actual = add_trailing_slash url
271
272
273 uri_tests :: Test
274 uri_tests =
275 testGroup "URI Tests" [
276
277 testGroup "URI Matching" [
278 testCase "HTTP URIs matched" test_http_uris_matched,
279 testCase "HTTPS URIs matched" test_https_uris_matched,
280 testCase "LWN URLs matched" test_lwn_urls_matched ],
281
282 testGroup "Filename Parsing" [
283 testCase "Bare filename parsed" test_bare_filename_parsed,
284 testCase "Absolute filename parsed" test_absolute_filename_parsed,
285 testCase "Relative filename parsed" test_relative_filename_parsed ],
286
287 testGroup "Relative -> Absolute Conversion" [
288 testCase "Empty URL converted to lwn.net" test_empty_url_conversion,
289 testCase "Normal URL made absolute" test_normal_url_conversion ],
290
291 testGroup "URL Mangling" [
292 testCase "HTTP URLs are made HTTPS" test_make_https,
293 testCase "Trailing slashes get added" test_add_trailing_slash ]
294 ]