module LWN.Article (
Article(..),
Byline(..),
Title(..),
BodyHtml(..),
article_tests,
real_article_path
)
where
import Data.List (isPrefixOf)
import System.Directory (doesFileExist)
import Test.HUnit (Assertion, assertEqual)
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Text.Regex.Posix ((=~))
import Text.XML.HXT.Core (
(>>>),
arr,
hread,
selem,
none,
runX,
txt,
xshow)
import LWN.URI (
add_trailing_slash,
is_lwn_url,
try_make_absolute_url,
make_https)
import LWN.XHTML (XHTML, XML, to_xhtml, to_xml)
newtype Title = Title { getTitle :: String }
newtype Byline = Byline { getByline :: Maybe String }
newtype BodyHtml = BodyHtml { getBodyHtml :: String }
instance Show Title where
show = getTitle
instance Show Byline where
show (Byline (Just bl)) = bl
show (Byline Nothing ) = ""
instance Show BodyHtml where
show = getBodyHtml
instance XHTML Title where
to_xhtml (Title t) = "
" ++ t ++ "
"
instance XHTML Byline where
to_xhtml (Byline (Just bl)) = "" ++ bl ++ "
"
to_xhtml (Byline Nothing) = ""
instance XHTML BodyHtml where
to_xhtml = getBodyHtml
instance XML Title where
to_xml (Title t) =
selem "h2" [ txt t ]
instance XML Byline where
to_xml (Byline (Just bl)) =
selem "p" [ selem "em" [ txt bl ] ]
to_xml (Byline Nothing) = none
instance XML BodyHtml where
to_xml (BodyHtml bh) =
(arr $ const bh) >>> hread
data Article = Article { title :: Title,
byline :: Byline,
body_html :: BodyHtml }
instance XHTML Article where
to_xhtml (Article t bl b) =
"" ++
(to_xhtml t) ++
(to_xhtml bl) ++
(to_xhtml b) ++
"
"
instance XML Article where
to_xml (Article t bl b) =
selem "div" [to_xml t, to_xml bl, to_xml b]
-- | Convert the given article to either a URL or a filesystem
-- path. If the given article exists on the filesystem, we assume
-- it's a file. Otherwise, we check to see if it's a URL. Failing
-- that, we try to construct a URL from what we're given and do our
-- best.
real_article_path :: String -> IO String
real_article_path path = do
is_file <- doesFileExist path
return $ if is_file then path else add_trailing_slash check_cases
where
abs_current = try_make_absolute_url ("/" ++ path)
abs_article = try_make_absolute_url ("Articles/" ++ path)
abs_full_article = try_make_absolute_url path
check_cases :: String
check_cases
| is_lwn_url path = make_https path
| isPrefixOf "current" path = abs_current
| path =~ "^[0-9]+$" = abs_article
| path =~ "^/Articles/[0-9]+/?$" = abs_full_article
| otherwise = path -- Give up
test_current_article_path :: Assertion
test_current_article_path = do
let expected = "https://lwn.net/current/"
actual <- real_article_path "current"
assertEqual "Current article path constructed" expected actual
test_current_bigpage_article_path :: Assertion
test_current_bigpage_article_path = do
let expected = "https://lwn.net/current/bigpage"
actual <- real_article_path "current/bigpage"
assertEqual "Current bigpage article path constructed" expected actual
test_numbered_article_path :: Assertion
test_numbered_article_path = do
let expected = "https://lwn.net/Articles/69/"
actual <- real_article_path "69" -- I'm twelve
assertEqual "Numbered article path constructed" expected actual
test_full_article_path :: Assertion
test_full_article_path = do
let expected = "https://lwn.net/Articles/502979/"
actual <- real_article_path "https://lwn.net/Articles/502979/"
assertEqual "Full article path left alone" expected actual
test_non_https_article_path :: Assertion
test_non_https_article_path = do
let expected = "https://lwn.net/Articles/502979/"
actual <- real_article_path "http://lwn.net/Articles/502979/"
assertEqual "Non-https URL made https" expected actual
-- | Compares the output of (xshow . to_xml) and to_xhtml; they should
-- match.
test_to_xml :: Assertion
test_to_xml = do
actual_xml' <- runX . xshow $ to_xml input_article
let actual_xml = actual_xml' !! 0
let expected_xml = to_xhtml input_article
assertEqual
"The to_xml function works on a trivial example"
expected_xml
actual_xml
where
t = Title "Hello, world!"
bl = Byline $ Just "Breaking News"
b = BodyHtml "Hello, world!
"
input_article = Article t bl b
article_tests :: Test
article_tests =
testGroup "Article Tests" [
testCase "Current article path constructed" test_current_article_path,
testCase
"Current bigpage article path constructed"
test_current_bigpage_article_path,
testCase "Numbered article path constructed" test_numbered_article_path,
testCase "Full article path left alone" test_full_article_path,
testCase "Non-https URL made https" test_non_https_article_path,
testCase "The to_xml function works on a trivial example" test_to_xml ]