From 14bff4a492037f8921a5993931d0fc4363207b20 Mon Sep 17 00:00:00 2001
From: Michael Orlitzky <michael@orlitzky.com>
Date: Mon, 25 Jun 2012 17:35:59 -0400
Subject: [PATCH] Create a test suite and add `make test` target. Add a new
 LWN.URI module and tests.

---
 makefile          |   3 +
 src/LWN/URI.hs    | 138 ++++++++++++++++++++++++++++++++++++++++++++++
 test/TestSuite.hs |  24 ++++++++
 3 files changed, 165 insertions(+)
 create mode 100644 src/LWN/URI.hs
 create mode 100644 test/TestSuite.hs

diff --git a/makefile b/makefile
index 1528ed3..15a2187 100644
--- a/makefile
+++ b/makefile
@@ -18,3 +18,6 @@ doc: src_html
 	runghc Setup.hs haddock --internal    \
 				--executables \
 				--hyperlink-source
+
+test:
+	runghc -i"src" test/TestSuite.hs
diff --git a/src/LWN/URI.hs b/src/LWN/URI.hs
new file mode 100644
index 0000000..55e4cb3
--- /dev/null
+++ b/src/LWN/URI.hs
@@ -0,0 +1,138 @@
+module LWN.URI
+where
+
+import Data.Maybe (fromJust)
+import Network.URI (
+  URI,
+  parseAbsoluteURI,
+  uriAuthority,
+  uriPath,
+  uriPort,
+  uriQuery,
+  uriRegName,
+  uriScheme
+  )
+import Test.HUnit (Assertion, assertEqual)
+import Test.Framework (Test, testGroup)
+import Test.Framework.Providers.HUnit (testCase)
+import Text.Regex.Posix
+
+-- Distinguish between URLs (Strings) and URIs as provided by the
+-- Network.URI module.
+type URL = String
+
+
+-- | Is this URI's scheme plain HTTP?
+http :: URI -> Bool
+http uri = (uriScheme uri) == "http:"
+
+-- | Is this URI's scheme (secure) HTTPS?
+https :: URI -> Bool
+https uri = (uriScheme uri) == "https:"
+
+-- | Does this URI use an HTTP-compatible port?
+http_port :: URI -> Bool
+http_port uri =
+  case parse_result of
+    Nothing -> False
+    Just auth ->
+      (uriPort auth) `elem` ["", ":80"]
+  where
+    parse_result = uriAuthority uri
+
+
+-- | Does this URI use an HTTPS-compatible port?
+https_port :: URI -> Bool
+https_port uri =
+  case parse_result of
+    Nothing -> False
+    Just auth ->
+      (uriPort auth) `elem` ["", ":443"]
+  where
+    parse_result = uriAuthority uri
+
+
+-- | Does this URL have one of the LWN hostnames?
+lwn_host :: URI -> Bool
+lwn_host uri =
+  case parse_result of
+    Nothing -> False
+    Just auth ->
+      (uriRegName auth) `elem` ["lwn.net", "www.lwn.net"]
+  where
+    parse_result = uriAuthority uri
+
+
+-- | Is the protocol portion of this URI one of the ones that LWN
+--   uses?
+lwn_proto :: URI -> Bool
+lwn_proto u =
+  ((http u) && (http_port u)) || ((https u) && (https_port u))
+
+-- | Is the server/port to which we're connecting an LWN server?
+lwn_server :: URI -> Bool
+lwn_server u =
+  lwn_proto u && lwn_host u
+
+-- | Is this URI's path for an LWN article?
+lwn_article_path :: URI -> Bool
+lwn_article_path uri =
+  path =~ "^/current(/bigpage)?/?$" ||
+  path =~ "^/Articles/[0-9]+(/bigpage)?/?$"
+  where
+    path = uriPath uri
+
+-- | Is this URI's query one that the LWN uses? The only query string
+--   that the LWN articles use is the printable page one.
+lwn_query :: URI -> Bool
+lwn_query uri =
+  query `elem` ["", "?format=printable"]
+  where
+    query = uriQuery uri
+
+-- | Combine all of the other URI tests to determine if this 'URL'
+--   belongs to an LWN article.
+is_lwn_url :: URL -> Bool
+is_lwn_url s =
+  case parse_result of
+    Nothing -> False
+    Just uri -> (lwn_server uri) && (lwn_article_path uri) && (lwn_query uri)
+  where
+    parse_result = parseAbsoluteURI s
+
+
+-- | A List of LWN URLs to use during testing.
+lwn_urls :: [URL]
+lwn_urls = [ proto ++ www ++ "lwn.net" ++ path ++ bigpage ++ query |
+              proto   <- ["http://", "https://"],
+              www     <- ["", "www."],
+              bigpage <- ["", "/bigpage"],
+              query   <- ["", "?format=printable"],
+              path    <- [ "/current",
+                          "/Articles/500844",
+                          "/Articles/502371" ] ]
+
+test_lwn_urls_matched :: Assertion
+test_lwn_urls_matched =
+  assertEqual "All LWN URLs matched" True (all is_lwn_url lwn_urls)
+
+test_http_uris_matched :: Assertion
+test_http_uris_matched =
+  assertEqual (url ++ " is HTTP") True (http uri)
+  where
+    url = "http://lwn.net/Articles/500844/bigpage"
+    uri = fromJust $ parseAbsoluteURI url
+
+test_https_uris_matched :: Assertion
+test_https_uris_matched =
+  assertEqual (url ++ " is HTTPS") True (https uri)
+  where
+    url = "https://lwn.net/Articles/500844/bigpage"
+    uri = fromJust $ parseAbsoluteURI url
+
+uri_tests :: Test
+uri_tests =
+  testGroup "URI Tests" [
+  testCase "HTTP URIs matched" test_http_uris_matched,
+  testCase "HTTPS URIs matched" test_https_uris_matched,
+  testCase "LWN URLs matched" test_lwn_urls_matched ]
diff --git a/test/TestSuite.hs b/test/TestSuite.hs
new file mode 100644
index 0000000..76503a3
--- /dev/null
+++ b/test/TestSuite.hs
@@ -0,0 +1,24 @@
+module TestSuite
+where
+
+import Test.Framework (
+  RunnerOptions(),
+  Test,
+  TestName,
+  TestOptions(),
+  defaultMain,
+  testGroup
+  )
+
+import Test.Framework.Options
+import Test.Framework.Runners.Options
+import Test.Framework.Providers.API (TestName)
+import Test.HUnit
+
+import LWN.URI (uri_tests)
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: [Test.Framework.Test]
+tests = [ uri_tests ]
-- 
2.44.2