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