src/LWN/Article.hs

   1 module LWN.Article (
   2   Article(..),
   3   Byline(..),
   4   Title(..),
   5   BodyHtml(..),
   6   article_tests,
   7   real_article_path
   8   )
   9 where
  10
  11 import Data.List (isPrefixOf)
  12 import System.Directory (doesFileExist)
  13 import Test.HUnit (Assertion, assertEqual)
  14 import Test.Framework (Test, testGroup)
  15 import Test.Framework.Providers.HUnit (testCase)
  16 import Text.Regex.Posix ((=~))
  17 import Text.XML.HXT.Core (
  18   (>>>),
  19   arr,
  20   hread,
  21   selem,
  22   none,
  23   runX,
  24   txt,
  25   xshow)
  26
  27 import LWN.URI (
  28   add_trailing_slash,
  29   is_lwn_url,
  30   try_make_absolute_url,
  31   make_https)
  32
  33 import LWN.XHTML (XHTML, XML, to_xhtml, to_xml)
  34
  35 newtype Title    = Title    { getTitle    :: String }
  36 newtype Byline   = Byline   { getByline   :: Maybe String }
  37 newtype BodyHtml = BodyHtml { getBodyHtml :: String }
  38
  39 instance Show Title where
  40   show = getTitle
  41
  42 instance Show Byline where
  43   show (Byline (Just bl)) = bl
  44   show (Byline Nothing  ) = ""
  45
  46 instance Show BodyHtml where
  47   show = getBodyHtml
  48
  49 instance XHTML Title where
  50   to_xhtml (Title t) = "<h2>" ++ t ++ "</h2>"
  51
  52 instance XHTML Byline where
  53   to_xhtml (Byline (Just bl)) = "<p><em>" ++ bl ++ "</em></p>"
  54   to_xhtml (Byline Nothing)   = ""
  55
  56 instance XHTML BodyHtml where
  57   to_xhtml = getBodyHtml
  58
  59
  60 instance XML Title where
  61   to_xml (Title t) =
  62     selem "h2" [ txt t ]
  63
  64 instance XML Byline where
  65   to_xml (Byline (Just bl)) =
  66     selem "p" [ selem "em" [ txt bl ] ]
  67   to_xml (Byline   Nothing) = none
  68
  69 instance XML BodyHtml where
  70   to_xml (BodyHtml bh) =
  71     (arr $ const bh) >>> hread
  72
  73 data Article = Article { title     :: Title,
  74                          byline    :: Byline,
  75                          body_html :: BodyHtml }
  76
  77 instance XHTML Article where
  78   to_xhtml (Article t bl b) =
  79     "<div>"       ++
  80     (to_xhtml t)  ++
  81     (to_xhtml bl) ++
  82     (to_xhtml b)  ++
  83     "</div>"
  84
  85 instance XML Article where
  86   to_xml (Article t bl b) =
  87     selem "div" [to_xml t, to_xml bl, to_xml b]
  88
  89 -- | Convert the given article to either a URL or a filesystem
  90 --   path. If the given article exists on the filesystem, we assume
  91 --   it's a file. Otherwise, we check to see if it's a URL. Failing
  92 --   that, we try to construct a URL from what we're given and do our
  93 --   best.
  94 real_article_path :: String -> IO String
  95 real_article_path path = do
  96   is_file <- doesFileExist path
  97   return $ if is_file then path else add_trailing_slash check_cases
  98   where
  99     abs_current = try_make_absolute_url ("/" ++ path)
 100     abs_article = try_make_absolute_url ("Articles/" ++ path)
 101     abs_full_article = try_make_absolute_url path
 102
 103     check_cases :: String
 104     check_cases
 105       | is_lwn_url path = make_https path
 106       | isPrefixOf "current" path = abs_current
 107       | path =~ "^[0-9]+$" = abs_article
 108       | path =~ "^/Articles/[0-9]+/?$" = abs_full_article
 109       | otherwise = path -- Give up
 110
 111
 112
 113 test_current_article_path :: Assertion
 114 test_current_article_path = do
 115   let expected = "https://lwn.net/current/"
 116   actual <- real_article_path "current"
 117   assertEqual "Current article path constructed" expected actual
 118
 119 test_current_bigpage_article_path :: Assertion
 120 test_current_bigpage_article_path = do
 121   let expected = "https://lwn.net/current/bigpage"
 122   actual <- real_article_path "current/bigpage"
 123   assertEqual "Current bigpage article path constructed" expected actual
 124
 125 test_numbered_article_path :: Assertion
 126 test_numbered_article_path = do
 127   let expected = "https://lwn.net/Articles/69/"
 128   actual <- real_article_path "69" -- I'm twelve
 129   assertEqual "Numbered article path constructed" expected actual
 130
 131
 132 test_full_article_path :: Assertion
 133 test_full_article_path = do
 134   let expected = "https://lwn.net/Articles/502979/"
 135   actual <- real_article_path "https://lwn.net/Articles/502979/"
 136   assertEqual "Full article path left alone" expected actual
 137
 138 test_non_https_article_path :: Assertion
 139 test_non_https_article_path = do
 140   let expected = "https://lwn.net/Articles/502979/"
 141   actual <- real_article_path "http://lwn.net/Articles/502979/"
 142   assertEqual "Non-https URL made https" expected actual
 143
 144
 145
 146 -- | Compares the output of (xshow . to_xml) and to_xhtml; they should
 147 --   match.
 148 test_to_xml :: Assertion
 149 test_to_xml = do
 150   actual_xml' <- runX . xshow $ to_xml input_article
 151   let actual_xml = actual_xml' !! 0
 152
 153   let expected_xml = to_xhtml input_article
 154
 155   assertEqual
 156     "The to_xml function works on a trivial example"
 157     expected_xml
 158     actual_xml
 159   where
 160     t  = Title "Hello, world!"
 161     bl = Byline $ Just "Breaking News"
 162     b  = BodyHtml "<p>Hello, world!</p>"
 163     input_article = Article t bl b
 164
 165
 166
 167 article_tests :: Test
 168 article_tests =
 169   testGroup "Article Tests" [
 170     testCase "Current article path constructed" test_current_article_path,
 171     testCase
 172       "Current bigpage article path constructed"
 173       test_current_bigpage_article_path,
 174     testCase "Numbered article path constructed" test_numbered_article_path,
 175     testCase "Full article path left alone" test_full_article_path,
 176     testCase "Non-https URL made https" test_non_https_article_path,
 177     testCase "The to_xml function works on a trivial example" test_to_xml ]