Clean up some types now that I know what I'm doing.
[dead/lwn-epub.git] / src / LWN / Page.hs
1 {-# LANGUAGE DoAndIfThenElse #-}
2
3 module LWN.Page
4 where
5
6 import qualified Data.Map as Map
7 import Data.Time (getCurrentTime)
8 import System.IO (Handle, hClose, hFlush)
9 import qualified Data.ByteString.Lazy as B (ByteString, hPut)
10 import Data.String.Utils (split, strip)
11 import Data.Maybe (catMaybes, fromJust, isNothing)
12 import Test.HUnit (Assertion, assertEqual)
13 import Test.Framework (Test, testGroup)
14 import Test.Framework.Providers.HUnit (testCase)
15 import Text.Pandoc
16 import Text.XML.HXT.Core (
17 ArrowXml,
18 IOSArrow,
19 XmlTree,
20 (>>>),
21 (/>),
22 (//>),
23 changeAttrValue,
24 getAttrValue,
25 getChildren,
26 getText,
27 hasAttrValue,
28 hasName,
29 isElem,
30 mkName,
31 none,
32 processAttrl,
33 processTopDown,
34 runX,
35 setElemName,
36 xshow,
37 when
38 )
39 import Text.HandsomeSoup (css, parseHtml)
40
41 import LWN.Article
42 import LWN.HTTP (save_image)
43 import LWN.URI (URL, try_make_absolute_url)
44 import Misc (contains)
45 import XHTML
46
47 -- Map absolute image URLs to local system file paths where the image
48 -- referenced by the URL is stored.
49 type ImageMap = Map.Map URL FilePath
50
51 download_image_urls :: [URL] -> IO ImageMap
52 download_image_urls image_urls = do
53 files <- mapM save_image image_urls
54 let pairs = zip image_urls files
55 return $ foldl my_insert empty_map pairs
56 where
57 empty_map = Map.empty :: ImageMap
58
59 my_insert :: ImageMap -> (URL, Maybe FilePath) -> ImageMap
60 my_insert dict (_, Nothing) = dict
61 my_insert dict (k, Just v) = Map.insert k v dict
62
63 -- Should be called *after* preprocessing.
64 download_images :: IOSArrow XmlTree XmlTree -> IO ImageMap
65 download_images xml = do
66 image_urls <- runX $ xml >>> image_srcs
67 download_image_urls image_urls
68
69
70 data Page =
71 -- | An LWN page with one article on it.
72 ArticlePage { article :: Article } |
73
74 -- | An LWN page with more than one article on it. These require
75 -- different parsing and display functions than the single-article
76 -- pages.
77 FullPage { headline :: String,
78 articles :: [Article] }
79
80
81 instance XHTML Page where
82 to_xhtml (ArticlePage a) =
83 "<?xml version=\"1.0\" encoding=\"utf-8\" ?>" ++
84 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\"" ++
85 "\"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" ++
86 "<head>" ++
87 " <meta http-equiv=\"Content-Type\"" ++
88 " content=\"application/xhtml+xml; charset=utf-8\" />" ++
89 " <title>" ++ (show $ LWN.Article.title a) ++ "</title>" ++
90 "</head>" ++
91 "<body>" ++
92 "<div>" ++
93 (to_xhtml a) ++
94 "</div>" ++
95 "</body>" ++
96 "</html>"
97
98 to_xhtml (FullPage hl as) =
99 "<?xml version=\"1.0\" encoding=\"utf-8\" ?>" ++
100 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\"" ++
101 "\"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" ++
102 "<head>" ++
103 " <meta http-equiv=\"Content-Type\"" ++
104 " content=\"application/xhtml+xml; charset=utf-8\" />" ++
105 " <title>" ++ hl ++ "</title>" ++
106 "</head>" ++
107 "<body>" ++
108 "<div>" ++
109 "<h1>" ++ hl ++ "</h1>" ++
110 (concatMap to_xhtml as) ++
111 "</div>" ++
112 "</body>" ++
113 "</html>"
114
115
116
117 is_link :: (ArrowXml a) => a XmlTree XmlTree
118 is_link =
119 isElem >>> hasName "a"
120
121
122 remove_comment_links :: (ArrowXml a) => a XmlTree XmlTree
123 remove_comment_links =
124 processTopDown $ kill_comments `when` is_link
125 where
126 is_comment_link =
127 hasAttrValue "href" (contains "#Comments")
128
129 kill_comments =
130 none `when` is_comment_link
131
132 replace_links_with_spans :: (ArrowXml a) => a XmlTree XmlTree
133 replace_links_with_spans =
134 processTopDown $ (make_span >>> remove_attrs) `when` is_link
135 where
136 make_span = setElemName $ mkName "span"
137 remove_attrs = processAttrl none
138
139
140 -- | Preprocessing common to both page types.
141 preprocess :: (ArrowXml a) => a XmlTree XmlTree
142 preprocess =
143 make_image_srcs_absolute
144 >>>
145 remove_comment_links
146 >>>
147 replace_links_with_spans
148
149
150 replace_remote_img_srcs :: (ArrowXml a) => ImageMap -> a XmlTree XmlTree
151 replace_remote_img_srcs image_map =
152 processTopDown (make_srcs_local `when` is_image)
153 where
154 -- old_src -> new_src
155 change_src_func :: String -> String
156 change_src_func old_src =
157 case Map.lookup old_src image_map of
158 -- Leave it alone if we don't have the file locally
159 Nothing -> old_src
160 Just v -> v
161
162 change_src :: (ArrowXml a) => a XmlTree XmlTree
163 change_src =
164 changeAttrValue change_src_func
165
166 make_srcs_local :: (ArrowXml a) => a XmlTree XmlTree
167 make_srcs_local =
168 processAttrl $ (change_src `when` (hasName "src"))
169
170
171 parse :: IOSArrow XmlTree XmlTree -> IO (Maybe Page)
172 parse xml = do
173 let clean_xml = xml >>> preprocess
174 image_map <- download_images clean_xml
175 let local_xml = clean_xml >>> replace_remote_img_srcs image_map
176 appr <- ap_parse local_xml
177 fppr <- fp_parse local_xml
178 return $
179 if (isNothing appr) then
180 fppr
181 else
182 appr
183
184
185
186 parse_headline :: IOSArrow XmlTree XmlTree -> IO (Maybe String)
187 parse_headline xml = do
188 let element_filter = xml >>> css "div.PageHeadline h1"
189 let element_text_filter = element_filter /> getText
190 element_text <- runX element_text_filter
191 return $
192 case element_text of
193 [x] -> Just $ strip x
194 [] -> Nothing
195 _ -> error "Found more than one headline."
196
197
198 parse_byline :: IOSArrow XmlTree XmlTree -> IO (Maybe String)
199 parse_byline xml = do
200 let element_filter = xml >>> css "div.FeatureByLine"
201 let element_text_filter = element_filter /> getText
202 element_text <- runX element_text_filter
203 return $
204 case element_text of
205 [x] -> Just $ strip x
206 [] -> Nothing
207 _ -> error "Found more than one article byline."
208
209
210 --
211 -- ArticlePage Stuff
212 --
213 ap_parse :: IOSArrow XmlTree XmlTree -> IO (Maybe Page)
214 ap_parse xml = do
215 arts <- ap_parse_articles xml
216 case arts of
217 [x] -> return $ Just $ ArticlePage x
218 _ -> return Nothing
219
220
221 ap_parse_body :: IOSArrow XmlTree XmlTree -> IO (Maybe String)
222 ap_parse_body xml = do
223 let element_filter = xml >>> css "div.ArticleText"
224 let element_html_filter = xshow element_filter
225 element_html <- runX element_html_filter
226 return $ case element_html of
227 [x] -> Just x
228 [] -> Nothing
229 _ -> error "Found more than one article."
230
231
232 ap_parse_articles :: IOSArrow XmlTree XmlTree -> IO [Article]
233 ap_parse_articles xml = do
234 parsed_headline <- parse_headline xml
235 parsed_byline <- parse_byline xml
236 parsed_body <- ap_parse_body xml
237
238 putStrLn $ fromJust parsed_headline
239
240 if (isNothing parsed_headline) || (isNothing parsed_body)
241 then return []
242 else do
243 let title' = Title $ fromJust parsed_headline
244 let byline' = Byline parsed_byline
245 let body' = BodyHtml $ fromJust parsed_body
246
247 return $ [Article title' byline' body']
248
249
250
251 --
252 -- FullPage Stuff
253 --
254
255 fp_parse :: IOSArrow XmlTree XmlTree -> IO (Maybe Page)
256 fp_parse xml = do
257 hl <- parse_headline xml
258 parsed_articles <- fp_parse_articles xml
259 case parsed_articles of
260 [] -> return Nothing
261 x -> return $ Just $ FullPage (fromJust hl) x
262
263
264
265 fp_parse_article_title :: IOSArrow XmlTree XmlTree -> IO (Maybe String)
266 fp_parse_article_title xml = do
267 let element_filter = xml >>> css "h2.SummaryHL"
268 let element_text_filter = element_filter //> getText
269 element_text <- runX element_text_filter
270 return $ case element_text of
271 [x] -> Just $ strip x
272 [] -> Nothing
273 _ -> error "Found more than one article title."
274
275
276
277 is_title :: (ArrowXml a) => a XmlTree XmlTree
278 is_title =
279 (hasName "h2")
280 >>>
281 (hasAttrValue "class" (== "SummaryHL"))
282
283
284 is_byline :: (ArrowXml a) => a XmlTree XmlTree
285 is_byline =
286 (hasName "div")
287 >>>
288 (hasAttrValue "class" (== "FeatureByLine"))
289
290
291 is_image :: (ArrowXml a) => a XmlTree XmlTree
292 is_image = isElem >>> hasName "img"
293
294 remove_title :: (ArrowXml a) => a XmlTree XmlTree
295 remove_title =
296 processTopDown ((none) `when` is_title)
297
298
299 remove_byline :: (ArrowXml a) => a XmlTree XmlTree
300 remove_byline =
301 processTopDown ((none) `when` is_byline)
302
303
304
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
314 [x] -> Just x
315 [] -> Nothing
316 _ -> error "Found more than one article body."
317
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
323
324 if (isNothing parsed_article_title) || (isNothing parsed_article_body)
325 then
326 return Nothing
327 else do
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'
332
333 parse_html_article :: String -> IO (Maybe Article)
334 parse_html_article html = do
335 let xml = parseHtml $ wrap_in_body_div html
336 fp_parse_article xml
337
338
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
342 parse_bodies xml =
343 xml >>> css "div.ArticleText"
344
345
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''
354 [] -> []
355 -- Put the separator back, it was lost during the split.
356 let split_articles = map (article_separator ++) split_articles'
357 --_ <- mapM print_article split_articles
358 real_articles <- mapM parse_html_article split_articles
359 let just_articles = catMaybes real_articles
360 return just_articles
361
362
363 -- | This makes it easy to select otherwise-random chunks of html
364 -- using 'css'.
365 wrap_in_body_div :: String -> String
366 wrap_in_body_div s =
367 "<body><div class=\"lwn-article\">" ++ s ++ "</div></body>"
368
369
370
371
372 --
373 -- Epublishable stuff
374 --
375
376 title :: Page -> String
377 title (ArticlePage a) = getTitle $ LWN.Article.title a
378 title (FullPage hl _) = hl
379
380
381 metadata :: Page -> IO String
382 metadata obj = do
383 date <- getCurrentTime
384 return $
385 "<dc:creator>http://lwn.net/</dc:creator>\n" ++
386 "<dc:date>" ++ (show date) ++ "</dc:date>\n" ++
387 "<dc:language>en-US</dc:language>\n" ++
388 "<dc:rights>Copyright Eklektix, Inc.</dc:rights>\n" ++
389 "<dc:title>" ++ (LWN.Page.title obj) ++ "</dc:title>\n"
390
391
392 epublish :: Page -> Handle -> IO ()
393 epublish obj handle = do
394 let xhtml = to_xhtml obj
395 epmd <- metadata obj
396 epub <- xhtml_to_epub epmd xhtml
397 B.hPut handle epub
398 hFlush handle
399 hClose handle
400
401 xhtml_to_epub :: String -> String -> IO B.ByteString
402 xhtml_to_epub epmd =
403 write_epub . read_html
404 where
405 my_writer_options = defaultWriterOptions { writerEPUBMetadata = epmd }
406 write_epub = writeEPUB Nothing [] my_writer_options
407 read_html = readHtml defaultParserState
408
409
410
411 --
412 -- Misc
413 --
414
415 image_srcs :: (ArrowXml a) => a XmlTree URL
416 image_srcs =
417 css "img"
418 >>>
419 getAttrValue "src"
420
421 make_image_srcs_absolute :: (ArrowXml a) => a XmlTree XmlTree
422 make_image_srcs_absolute =
423 processTopDown (make_srcs_absolute `when` is_image)
424 where
425 change_src :: (ArrowXml a) => a XmlTree XmlTree
426 change_src =
427 changeAttrValue try_make_absolute_url
428
429 make_srcs_absolute :: (ArrowXml a) => a XmlTree XmlTree
430 make_srcs_absolute =
431 processAttrl $ change_src `when` hasName "src"
432
433
434 --
435 -- Tests
436 --
437
438 test_preprocess_links :: Assertion
439 test_preprocess_links = do
440 actual_xml' <- runX $ input_xml >>> preprocess >>> css "body"
441 let actual_xml = actual_xml' !! 0
442
443 expected_xml' <- runX $ expected_xml'' >>> css "body"
444 let expected_xml = expected_xml' !! 0
445
446 assertEqual
447 "Links are replaced with spans"
448 expected_xml
449 actual_xml
450 where
451 input_html = "<body><a href=\"#\">Hello, world!</a></body>"
452 input_xml = parseHtml input_html
453 expected_html = "<body><span>Hello, world!</span></body>"
454 expected_xml'' = parseHtml expected_html
455
456
457 test_absolve_images :: Assertion
458 test_absolve_images = do
459 actual_xml' <- runX $ input_xml >>> preprocess >>> css "body"
460 let actual_xml = actual_xml' !! 0
461
462 expected_xml' <- runX $ expected_xml'' >>> css "body"
463 let expected_xml = expected_xml' !! 0
464
465 assertEqual
466 "Image srcs are made absolute"
467 expected_xml
468 actual_xml
469 where
470 input_html =
471 "<body>" ++
472 "<img src=\"/images/2012/example.jpg\" />" ++
473 "</body>"
474 input_xml = parseHtml input_html
475 expected_html =
476 "<body>" ++
477 "<img src=\"https://lwn.net/images/2012/example.jpg\" />" ++
478 "</body>"
479 expected_xml'' = parseHtml expected_html
480
481
482 test_comments_removed :: Assertion
483 test_comments_removed = do
484 actual_xml' <- runX $ input_xml >>> preprocess >>> css "body"
485 let actual_xml = actual_xml' !! 0
486
487 expected_xml' <- runX $ expected_xml'' >>> css "body"
488 let expected_xml = expected_xml' !! 0
489
490 assertEqual
491 "Comment links are removed"
492 expected_xml
493 actual_xml
494 where
495 input_html =
496 "<body><p>" ++
497 "<a href=\"/Articles/501490/#Comments\">Comments (6 posted)</a>" ++
498 "</p></body>"
499 input_xml = parseHtml input_html
500
501 expected_html = "<body><p></p></body>"
502 expected_xml'' = parseHtml expected_html
503
504
505
506 page_tests :: Test
507 page_tests =
508 testGroup "Page Tests" [
509 testCase "Links are replaced with spans" test_preprocess_links,
510 testCase "Image srcs are made absolute" test_absolve_images,
511 testCase "Comment links are removed" test_comments_removed ]