1 {-# LANGUAGE DoAndIfThenElse #-}
6 import Control.Concurrent.ParallelIO (parallel)
7 import qualified Data.Map as Map (lookup)
8 import Data.Time (getCurrentTime)
9 import qualified Data.ByteString.Lazy as B (ByteString, hPut)
10 import Data.String.Utils (split, strip)
11 import qualified Data.Map as Map (Map, empty, insert)
12 import Data.Maybe (catMaybes, fromJust, isNothing)
13 import Prelude hiding (readFile)
14 import System.IO (Handle, hClose, hFlush)
15 import Test.HUnit (Assertion, assertEqual)
16 import Test.Framework (Test, testGroup)
17 import Test.Framework.Providers.HUnit (testCase)
24 import Text.XML.HXT.Core (
43 import Text.HandsomeSoup (css, parseHtml)
45 import Configuration (Cfg, full_stories)
70 -- | An LWN page with one article on it.
71 ArticlePage { article :: Article } |
73 -- | An LWN page with more than one article on it. These require
74 -- different parsing and display functions than the single-article
76 FullPage { headline :: String,
77 articles :: [Article] }
80 instance XHTML Page where
81 to_xhtml (ArticlePage a) =
82 "<?xml version=\"1.0\" encoding=\"utf-8\" ?>" ++
83 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\"" ++
84 "\"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" ++
86 " <meta http-equiv=\"Content-Type\"" ++
87 " content=\"application/xhtml+xml; charset=utf-8\" />" ++
88 " <title>" ++ (show $ LWN.Article.title a) ++ "</title>" ++
95 to_xhtml (FullPage hl as) =
96 "<?xml version=\"1.0\" encoding=\"utf-8\" ?>" ++
97 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\"" ++
98 "\"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" ++
100 " <meta http-equiv=\"Content-Type\"" ++
101 " content=\"application/xhtml+xml; charset=utf-8\" />" ++
102 " <title>" ++ hl ++ "</title>" ++
106 "<h1>" ++ hl ++ "</h1>" ++
107 (concatMap to_xhtml as) ++
114 page_from_url :: Cfg -> URL -> IO (Maybe Page)
115 page_from_url cfg url = do
116 contents <- get_article_contents cfg url
117 case (xml_from_contents contents) of
118 Just html -> parse cfg html
119 Nothing -> return Nothing
123 insert_full_stories :: (ArrowXml a) => StoryMap -> a XmlTree XmlTree
124 insert_full_stories story_map =
125 processTopDown (article_xml `when` full_story_paragraph)
127 lookup_func :: (ArrowXml a) => URL -> a XmlTree XmlTree
129 case Map.lookup href story_map of
130 -- Leave it alone if we don't have the full story.
134 article_xml :: (ArrowXml a) => a XmlTree XmlTree
137 $< -- From HXT's Control.Arrow.ArrowList
138 (this /> full_story_link >>> getAttrValue "href")
140 replace_remote_img_srcs :: (ArrowXml a) => ImageMap -> a XmlTree XmlTree
141 replace_remote_img_srcs image_map =
142 processTopDown (make_srcs_local `when` is_image)
144 -- old_src -> new_src
145 change_src_func :: String -> String
146 change_src_func old_src =
147 case Map.lookup old_src image_map of
148 -- Leave it alone if we don't have the file locally
152 change_src :: (ArrowXml a) => a XmlTree XmlTree
154 changeAttrValue change_src_func
156 make_srcs_local :: (ArrowXml a) => a XmlTree XmlTree
158 processAttrl $ (change_src `when` (hasName "src"))
163 -- Should be called *after* preprocessing.
164 download_images :: IOSArrow XmlTree XmlTree -> IO ImageMap
165 download_images xml = do
166 image_urls <- runX $ xml >>> image_srcs
167 download_image_urls image_urls
171 type StoryMap = Map.Map URL Article
173 -- These come *before* preprocessing.
174 download_full_story_urls :: Cfg -> [URL] -> IO StoryMap
175 download_full_story_urls cfg story_urls = do
176 pages <- parallel $ map (page_from_url cfg) story_urls
177 let pairs = zip story_urls pages
178 return $ foldl my_insert empty_map pairs
180 empty_map = Map.empty :: StoryMap
182 my_insert :: StoryMap -> (URL, Maybe Page) -> StoryMap
183 my_insert dict (k, Just (ArticlePage v)) = Map.insert k v dict
184 my_insert dict (_, _) = dict
187 download_full_stories :: Cfg -> IOSArrow XmlTree XmlTree -> IO StoryMap
188 download_full_stories cfg xml = do
189 story_urls <- runX $ xml >>> full_story_urls
190 download_full_story_urls cfg story_urls
193 parse :: Cfg -> IOSArrow XmlTree XmlTree -> IO (Maybe Page)
195 fs_xml <- if (full_stories cfg) then do
196 story_map <- download_full_stories cfg xml
197 return $ xml >>> insert_full_stories story_map
201 let clean_xml = fs_xml >>> preprocess
202 image_map <- download_images clean_xml
203 let local_xml = clean_xml >>> replace_remote_img_srcs image_map
205 appr <- ap_parse local_xml
206 fppr <- fp_parse local_xml
208 if (isNothing appr) then
215 parse_headline :: IOSArrow XmlTree XmlTree -> IO (Maybe String)
216 parse_headline xml = do
217 let element_filter = xml >>> css "div.PageHeadline h1"
218 let element_text_filter = element_filter /> getText
219 element_text <- runX element_text_filter
222 [x] -> Just $ strip x
224 _ -> error "Found more than one headline."
227 parse_byline :: IOSArrow XmlTree XmlTree -> IO (Maybe String)
228 parse_byline xml = do
229 let element_filter = xml >>> css "div.FeatureByLine"
230 let element_text_filter = element_filter /> getText
231 element_text <- runX element_text_filter
234 [x] -> Just $ strip x
236 _ -> error "Found more than one article byline."
242 ap_parse :: IOSArrow XmlTree XmlTree -> IO (Maybe Page)
244 arts <- ap_parse_articles xml
246 [x] -> return $ Just $ ArticlePage x
250 ap_parse_body :: IOSArrow XmlTree XmlTree -> IO (Maybe String)
251 ap_parse_body xml = do
252 let element_filter = xml >>> css "div.ArticleText"
253 let element_html_filter = xshow element_filter
254 element_html <- runX element_html_filter
255 return $ case element_html of
258 _ -> error "Found more than one article."
261 ap_parse_articles :: IOSArrow XmlTree XmlTree -> IO [Article]
262 ap_parse_articles xml = do
263 parsed_headline <- parse_headline xml
264 parsed_byline <- parse_byline xml
265 parsed_body <- ap_parse_body xml
267 if (isNothing parsed_headline) || (isNothing parsed_body)
270 let title' = Title $ fromJust parsed_headline
271 let byline' = Byline parsed_byline
272 let body' = BodyHtml $ fromJust parsed_body
274 return $ [Article title' byline' body']
282 fp_parse :: IOSArrow XmlTree XmlTree -> IO (Maybe Page)
284 hl <- parse_headline xml
285 parsed_articles <- fp_parse_articles xml
286 case parsed_articles of
288 x -> return $ Just $ FullPage (fromJust hl) x
292 fp_parse_article_title :: IOSArrow XmlTree XmlTree -> IO (Maybe String)
293 fp_parse_article_title xml = do
294 let element_filter = xml >>> css "h2.SummaryHL"
295 let element_text_filter = element_filter //> getText
296 element_text <- runX element_text_filter
297 return $ case element_text of
298 [x] -> Just $ strip x
300 _ -> error "Found more than one article title."
305 fp_parse_article_body :: IOSArrow XmlTree XmlTree -> IO (Maybe String)
306 fp_parse_article_body xml = do
307 -- First, delete the article title and byline.
308 let clean_xml' = xml >>> remove_title >>> remove_byline
309 -- The only child of the body element should be a div.lwn-article
310 -- since we wrapped the article's HTML in that.
311 let clean_xml = clean_xml' >>> css "body" >>> getChildren
312 clean_html <- runX . xshow $ clean_xml
313 return $ case clean_html of
316 _ -> error "Found more than one article body."
318 fp_parse_article :: IOSArrow XmlTree XmlTree -> IO (Maybe Article)
319 fp_parse_article xml = do
320 parsed_article_title <- fp_parse_article_title xml
321 parsed_article_byline <- parse_byline xml
322 parsed_article_body <- fp_parse_article_body xml
324 if (isNothing parsed_article_title) || (isNothing parsed_article_body)
328 let title' = Title $ fromJust parsed_article_title
329 let byline' = Byline parsed_article_byline
330 let body' = BodyHtml $ fromJust parsed_article_body
331 return $ Just $ Article title' byline' body'
333 parse_html_article :: String -> IO (Maybe Article)
334 parse_html_article html = do
335 let xml = parseHtml $ wrap_in_body_div html
339 -- | In the full page, all of the article titles and bodies are
340 -- wrapped in one big div.ArticleText.
341 parse_bodies :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
343 xml >>> css "div.ArticleText"
346 fp_parse_articles :: IOSArrow XmlTree XmlTree -> IO [Article]
347 fp_parse_articles xml = do
348 bodies <- runX . xshow $ parse_bodies xml
349 let article_separator = "<h2 class=\"SummaryHL\">"
350 let split_articles'' = split article_separator (concat bodies)
351 -- The first element will contain the crap before the first <h2...>.
352 let split_articles' = case split_articles'' of
353 (_:_) -> tail split_articles''
355 -- Put the separator back, it was lost during the split.
356 let split_articles = map (article_separator ++) split_articles'
357 real_articles <- mapM parse_html_article split_articles
358 let just_articles = catMaybes real_articles
362 -- | This makes it easy to select otherwise-random chunks of html
364 wrap_in_body_div :: String -> String
366 "<body><div class=\"lwn-article\">" ++ s ++ "</div></body>"
372 -- Epublishable stuff
375 title :: Page -> String
376 title (ArticlePage a) = getTitle $ LWN.Article.title a
377 title (FullPage hl _) = hl
380 metadata :: Page -> IO String
382 date <- getCurrentTime
384 "<dc:creator>http://lwn.net/</dc:creator>\n" ++
385 "<dc:date>" ++ (show date) ++ "</dc:date>\n" ++
386 "<dc:language>en-US</dc:language>\n" ++
387 "<dc:rights>Copyright Eklektix, Inc.</dc:rights>\n" ++
388 "<dc:title>" ++ (LWN.Page.title obj) ++ "</dc:title>\n"
391 epublish :: Page -> Handle -> IO ()
392 epublish obj handle = do
393 let xhtml = to_xhtml obj
395 epub <- xhtml_to_epub epmd xhtml
400 xhtml_to_epub :: String -> String -> IO B.ByteString
402 write_epub . read_html
404 my_writer_options = defaultWriterOptions { writerEPUBMetadata = epmd }
405 write_epub = writeEPUB Nothing [] my_writer_options
406 read_html = readHtml defaultParserState
413 test_preprocess_links :: Assertion
414 test_preprocess_links = do
415 actual_xml' <- runX $ input_xml >>> preprocess >>> css "body"
416 let actual_xml = actual_xml' !! 0
418 expected_xml' <- runX $ expected_xml'' >>> css "body"
419 let expected_xml = expected_xml' !! 0
422 "Links are replaced with spans"
426 input_html = "<body><a href=\"#\">Hello, world!</a></body>"
427 input_xml = parseHtml input_html
428 expected_html = "<body><span>Hello, world!</span></body>"
429 expected_xml'' = parseHtml expected_html
432 test_absolve_images :: Assertion
433 test_absolve_images = do
434 actual_xml' <- runX $ input_xml >>> preprocess >>> css "body"
435 let actual_xml = actual_xml' !! 0
437 expected_xml' <- runX $ expected_xml'' >>> css "body"
438 let expected_xml = expected_xml' !! 0
441 "Image srcs are made absolute"
447 "<img src=\"/images/2012/example.jpg\" />" ++
449 input_xml = parseHtml input_html
452 "<img src=\"https://lwn.net/images/2012/example.jpg\" />" ++
454 expected_xml'' = parseHtml expected_html
457 test_comments_removed :: Assertion
458 test_comments_removed = do
459 actual_xml' <- runX $ input_xml >>> preprocess >>> css "body"
460 let actual_xml = actual_xml' !! 0
462 expected_xml' <- runX $ expected_xml'' >>> css "body"
463 let expected_xml = expected_xml' !! 0
466 "Comment links are removed"
472 "<a href=\"/Articles/501490/#Comments\">Comments (6 posted)</a>" ++
474 input_xml = parseHtml input_html
476 expected_html = "<body><p></p></body>"
477 expected_xml'' = parseHtml expected_html
480 test_full_story_urls_parsed :: Assertion
481 test_full_story_urls_parsed = do
482 actual <- runX $ actual'
485 "Full Story URLs are parsed"
489 expected = ["/Articles/500738/", "/Articles/501837/"]
493 "<a href=\"/Articles/500738/\">Full Story</a> ",
494 "(<a href=\"/Articles/500738/#Comments\">comments: 49</a>)",
496 "<a href=\"/Articles/501837/\">Full Story</a> ",
497 "(<a href=\"/Articles/501837/#Comments\">comments: none</a>)",
500 xml = parseHtml full_story_html
501 actual' = xml >>> full_story_urls
505 testGroup "Page Tests" [
506 testCase "Links are replaced with spans" test_preprocess_links,
507 testCase "Image srcs are made absolute" test_absolve_images,
508 testCase "Comment links are removed" test_comments_removed,
509 testCase "Full Story URLs are parsed" test_full_story_urls_parsed ]