0d01e1900852c71dce82e7f75c754fb717be9b76
[dead/lwn-epub.git] / src / LWN / 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 parseAbsoluteURI,
9 parseURIReference,
10 uriAuthority,
11 uriPath,
12 uriPort,
13 uriQuery,
14 uriRegName,
15 uriScheme
16 )
17 import Test.HUnit (Assertion, assertEqual)
18 import Test.Framework (Test, testGroup)
19 import Test.Framework.Providers.HUnit (testCase)
20 import Text.Regex.Posix
21
22 -- Distinguish between URLs (Strings) and URIs as provided by the
23 -- Network.URI module.
24 type URL = String
25
26
27 -- | Is this URI's scheme plain HTTP?
28 http :: URI -> Bool
29 http uri = (uriScheme uri) == "http:"
30
31 -- | Is this URI's scheme (secure) HTTPS?
32 https :: URI -> Bool
33 https uri = (uriScheme uri) == "https:"
34
35 -- | Does this URI use an HTTP-compatible port?
36 http_port :: URI -> Bool
37 http_port uri =
38 case parse_result of
39 Nothing -> False
40 Just auth ->
41 (uriPort auth) `elem` ["", ":80"]
42 where
43 parse_result = uriAuthority uri
44
45
46 -- | Does this URI use an HTTPS-compatible port?
47 https_port :: URI -> Bool
48 https_port uri =
49 case parse_result of
50 Nothing -> False
51 Just auth ->
52 (uriPort auth) `elem` ["", ":443"]
53 where
54 parse_result = uriAuthority uri
55
56
57 -- | Does this URL have one of the LWN hostnames?
58 lwn_host :: URI -> Bool
59 lwn_host uri =
60 case parse_result of
61 Nothing -> False
62 Just auth ->
63 (uriRegName auth) `elem` ["lwn.net", "www.lwn.net"]
64 where
65 parse_result = uriAuthority uri
66
67
68 -- | Is the protocol portion of this URI one of the ones that LWN
69 -- uses?
70 lwn_proto :: URI -> Bool
71 lwn_proto u =
72 ((http u) && (http_port u)) || ((https u) && (https_port u))
73
74 -- | Is the server/port to which we're connecting an LWN server?
75 lwn_server :: URI -> Bool
76 lwn_server u =
77 lwn_proto u && lwn_host u
78
79 -- | Is this URI's path for an LWN article?
80 lwn_article_path :: URI -> Bool
81 lwn_article_path uri =
82 path =~ "^/current(/bigpage)?/?$" ||
83 path =~ "^/Articles/[0-9]+(/bigpage)?/?$"
84 where
85 path = uriPath uri
86
87 -- | Is this URI's query one that the LWN uses? The only query string
88 -- that the LWN articles use is the printable page one.
89 lwn_query :: URI -> Bool
90 lwn_query uri =
91 query `elem` ["", "?format=printable"]
92 where
93 query = uriQuery uri
94
95 -- | Combine all of the other URI tests to determine if this 'URL'
96 -- belongs to an LWN article.
97 is_lwn_url :: URL -> Bool
98 is_lwn_url s =
99 case parse_result of
100 Nothing -> False
101 Just uri -> (lwn_server uri) && (lwn_article_path uri) && (lwn_query uri)
102 where
103 parse_result = parseAbsoluteURI s
104
105
106
107 filename :: URL -> Maybe String
108 filename url =
109 case parse_result of
110 Nothing -> Nothing
111 Just uri ->
112 let components = split "/" (uriPath uri) in
113 -- Reverse them so that the filename comes first for easier
114 -- pattern-matching.
115 let reverse_components = reverse components in
116 case reverse_components of
117 [] -> Nothing
118 (x:xs) -> Just x
119 where
120 parse_result = parseURIReference url
121
122
123 -- | A List of LWN URLs to use during testing.
124 lwn_urls :: [URL]
125 lwn_urls = [ proto ++ www ++ "lwn.net" ++ path ++ bigpage ++ query |
126 proto <- ["http://", "https://"],
127 www <- ["", "www."],
128 bigpage <- ["", "/bigpage"],
129 query <- ["", "?format=printable"],
130 path <- [ "/current",
131 "/Articles/500844",
132 "/Articles/502371" ] ]
133
134 test_lwn_urls_matched :: Assertion
135 test_lwn_urls_matched =
136 assertEqual "All LWN URLs matched" True (all is_lwn_url lwn_urls)
137
138 test_http_uris_matched :: Assertion
139 test_http_uris_matched =
140 assertEqual (url ++ " is HTTP") True (http uri)
141 where
142 url = "http://lwn.net/Articles/500844/bigpage"
143 uri = fromJust $ parseAbsoluteURI url
144
145 test_https_uris_matched :: Assertion
146 test_https_uris_matched =
147 assertEqual (url ++ " is HTTPS") True (https uri)
148 where
149 url = "https://lwn.net/Articles/500844/bigpage"
150 uri = fromJust $ parseAbsoluteURI url
151
152
153 test_bare_filename_parsed :: Assertion
154 test_bare_filename_parsed =
155 assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
156 where
157 url = "example.jpg"
158 actual_result = fromJust $ filename url
159
160 test_absolute_filename_parsed :: Assertion
161 test_absolute_filename_parsed =
162 assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
163 where
164 url = "http://lwn.net/one/two/example.jpg"
165 actual_result = fromJust $ filename url
166
167 test_relative_filename_parsed :: Assertion
168 test_relative_filename_parsed =
169 assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
170 where
171 url = "/one/two/example.jpg"
172 actual_result = fromJust $ filename url
173
174
175 uri_tests :: Test
176 uri_tests =
177 testGroup "URI Tests" [
178
179 testGroup "URI Matching" [
180 testCase "HTTP URIs matched" test_http_uris_matched,
181 testCase "HTTPS URIs matched" test_https_uris_matched,
182 testCase "LWN URLs matched" test_lwn_urls_matched ],
183
184 testGroup "Filename Parsing" [
185 testCase "Bare filename parsed" test_bare_filename_parsed,
186 testCase "Absolute filename parsed" test_absolute_filename_parsed,
187 testCase "Relative filename parsed" test_relative_filename_parsed ] ]