4 import Data.Maybe (fromJust)
5 import Data.String.Utils (split)
17 import Test.HUnit (Assertion, assertEqual)
18 import Test.Framework (Test, testGroup)
19 import Test.Framework.Providers.HUnit (testCase)
20 import Text.Regex.Posix
22 -- Distinguish between URLs (Strings) and URIs as provided by the
23 -- Network.URI module.
27 -- | Is this URI's scheme plain HTTP?
29 http uri = (uriScheme uri) == "http:"
31 -- | Is this URI's scheme (secure) HTTPS?
33 https uri = (uriScheme uri) == "https:"
35 -- | Does this URI use an HTTP-compatible port?
36 http_port :: URI -> Bool
41 (uriPort auth) `elem` ["", ":80"]
43 parse_result = uriAuthority uri
46 -- | Does this URI use an HTTPS-compatible port?
47 https_port :: URI -> Bool
52 (uriPort auth) `elem` ["", ":443"]
54 parse_result = uriAuthority uri
57 -- | Does this URL have one of the LWN hostnames?
58 lwn_host :: URI -> Bool
63 (uriRegName auth) `elem` ["lwn.net", "www.lwn.net"]
65 parse_result = uriAuthority uri
68 -- | Is the protocol portion of this URI one of the ones that LWN
70 lwn_proto :: URI -> Bool
72 ((http u) && (http_port u)) || ((https u) && (https_port u))
74 -- | Is the server/port to which we're connecting an LWN server?
75 lwn_server :: URI -> Bool
77 lwn_proto u && lwn_host u
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)?/?$"
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
91 query `elem` ["", "?format=printable"]
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
101 Just uri -> (lwn_server uri) && (lwn_article_path uri) && (lwn_query uri)
103 parse_result = parseAbsoluteURI s
107 filename :: URL -> Maybe String
112 let components = split "/" (uriPath uri) in
113 -- Reverse them so that the filename comes first for easier
115 let reverse_components = reverse components in
116 case reverse_components of
120 parse_result = parseURIReference url
123 -- | A List of LWN URLs to use during testing.
125 lwn_urls = [ proto ++ www ++ "lwn.net" ++ path ++ bigpage ++ query |
126 proto <- ["http://", "https://"],
128 bigpage <- ["", "/bigpage"],
129 query <- ["", "?format=printable"],
130 path <- [ "/current",
132 "/Articles/502371" ] ]
134 test_lwn_urls_matched :: Assertion
135 test_lwn_urls_matched =
136 assertEqual "All LWN URLs matched" True (all is_lwn_url lwn_urls)
138 test_http_uris_matched :: Assertion
139 test_http_uris_matched =
140 assertEqual (url ++ " is HTTP") True (http uri)
142 url = "http://lwn.net/Articles/500844/bigpage"
143 uri = fromJust $ parseAbsoluteURI url
145 test_https_uris_matched :: Assertion
146 test_https_uris_matched =
147 assertEqual (url ++ " is HTTPS") True (https uri)
149 url = "https://lwn.net/Articles/500844/bigpage"
150 uri = fromJust $ parseAbsoluteURI url
153 test_bare_filename_parsed :: Assertion
154 test_bare_filename_parsed =
155 assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
158 actual_result = fromJust $ filename url
160 test_absolute_filename_parsed :: Assertion
161 test_absolute_filename_parsed =
162 assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
164 url = "http://lwn.net/one/two/example.jpg"
165 actual_result = fromJust $ filename url
167 test_relative_filename_parsed :: Assertion
168 test_relative_filename_parsed =
169 assertEqual "Filename is 'example.jpg'" "example.jpg" actual_result
171 url = "/one/two/example.jpg"
172 actual_result = fromJust $ filename url
177 testGroup "URI Tests" [
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 ],
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 ] ]