Implement image download and replacement.

[dead/lwn-epub.git] / src / LWN / Page.hs

diff --git a/src/LWN/Page.hs b/src/LWN/Page.hs
index a4a56c222a8ebd1533fff5e9773efbf2dfe22acf..0307214176a82c469f1f555a056b553c05bd3b06 100644 (file)
--- a/src/LWN/Page.hs
+++ b/src/LWN/Page.hs
@@ -1,16 +1,20 @@
+{-# LANGUAGE DoAndIfThenElse #-}
+

 module LWN.Page
 where
 
 module LWN.Page
 where
 

-import Text.Pandoc
+import qualified Data.Map as Map

 import Data.Time (getCurrentTime)
 import System.IO (Handle)
 import qualified Data.ByteString.Lazy as B (ByteString, hPut)
 import Data.Time (getCurrentTime)
 import System.IO (Handle)
 import qualified Data.ByteString.Lazy as B (ByteString, hPut)

+import Data.List (isInfixOf)

 import Data.String.Utils (split, strip)
 import Data.Maybe (catMaybes, fromJust, isNothing)
 import Data.Tree.NTree.TypeDefs (NTree)
 import Test.HUnit (Assertion, assertEqual)
 import Test.Framework (Test, testGroup)
 import Test.Framework.Providers.HUnit (testCase)
 import Data.String.Utils (split, strip)
 import Data.Maybe (catMaybes, fromJust, isNothing)
 import Data.Tree.NTree.TypeDefs (NTree)
 import Test.HUnit (Assertion, assertEqual)
 import Test.Framework (Test, testGroup)
 import Test.Framework.Providers.HUnit (testCase)

+import Text.Pandoc

 import Text.XML.HXT.Core (
   ArrowXml,
   IOSArrow,
 import Text.XML.HXT.Core (
   ArrowXml,
   IOSArrow,


@@ -19,10 +23,13 @@ import Text.XML.HXT.Core (
   (>>>),
   (/>),
   (//>),
   (>>>),
   (/>),
   (//>),

+  changeAttrValue,
+  getAttrValue,

   getChildren,
   getText,
   hasAttrValue,
   hasName,
   getChildren,
   getText,
   hasAttrValue,
   hasName,

+  isElem,

   mkName,
   none,
   processAttrl,
   mkName,
   none,
   processAttrl,


@@ -35,8 +42,29 @@ import Text.XML.HXT.Core (
 import Text.HandsomeSoup (css, parseHtml)
 
 import LWN.Article
 import Text.HandsomeSoup (css, parseHtml)
 
 import LWN.Article

+import LWN.HTTP (save_image)
+import LWN.URI (URL, try_make_absolute_url)

 import XHTML
 
 import XHTML
 

+-- Map absolute image URLs to local system file paths where the image
+-- referenced by the URL is stored.
+type ImageMap = Map.Map URL FilePath
+
+-- Should be called *after* preprocessing.
+download_images :: IOSArrow XmlTree (NTree XNode) -> IO ImageMap
+download_images xml = do
+  image_urls <- runX $ xml >>> image_srcs
+  files <- mapM save_image image_urls
+  let pairs = zip image_urls files
+  return $ foldl my_insert empty_map pairs
+  where
+    empty_map = Map.empty :: ImageMap
+
+    my_insert :: ImageMap -> (URL, Maybe FilePath) -> ImageMap
+    my_insert dict (_, Nothing)  = dict
+    my_insert dict (k, Just v) = Map.insert k v dict
+
+

 data Page =
   -- | An LWN page with one article on it.
   ArticlePage { article :: Article } |
 data Page =
   -- | An LWN page with one article on it.
   ArticlePage { article :: Article } |


@@ -84,14 +112,22 @@ instance XHTML Page where
 
 
 
 
 
 

-remove_images :: (ArrowXml a) => a XmlTree XmlTree
-remove_images =
-  processTopDown ((none) `when` is_image)
-
-

 is_link :: (ArrowXml a) => a XmlTree XmlTree
 is_link =
 is_link :: (ArrowXml a) => a XmlTree XmlTree
 is_link =

-  hasName "a"
+  isElem >>> hasName "a"
+
+
+remove_comment_links  :: (ArrowXml a) => a XmlTree XmlTree
+remove_comment_links =
+  processTopDown $ kill_comments `when` is_link
+  where    
+    contains = isInfixOf
+
+    is_comment_link =
+      hasAttrValue "href" (contains "#Comments")
+
+    kill_comments =
+      none `when` is_comment_link

 
 replace_links_with_spans :: (ArrowXml a) => a XmlTree XmlTree
 replace_links_with_spans =
 
 replace_links_with_spans :: (ArrowXml a) => a XmlTree XmlTree
 replace_links_with_spans =


@@ -100,21 +136,49 @@ replace_links_with_spans =
     make_span    = setElemName $ mkName "span"
     remove_attrs = processAttrl none
 
     make_span    = setElemName $ mkName "span"
     remove_attrs = processAttrl none
 

+

 -- | Preprocessing common to both page types.
 -- | Preprocessing common to both page types.

-preprocess :: IOSArrow XmlTree (NTree XNode) -> IOSArrow XmlTree (NTree XNode)
-preprocess xml =
-  xml >>> remove_images >>> replace_links_with_spans
+preprocess :: (ArrowXml a) => a XmlTree XmlTree
+preprocess =
+  make_image_srcs_absolute
+  >>>
+  remove_comment_links
+  >>>
+  replace_links_with_spans
+
+
+replace_remote_img_srcs :: (ArrowXml a) => ImageMap -> a XmlTree XmlTree
+replace_remote_img_srcs image_map =
+  processTopDown (make_srcs_local `when` is_image)
+  where
+    -- old_src -> new_src
+    change_src_func :: String -> String
+    change_src_func old_src =
+      case Map.lookup old_src image_map of
+        -- Leave it alone if we don't have the file locally
+        Nothing -> old_src
+        Just v -> v
+
+    change_src :: (ArrowXml a) => a XmlTree XmlTree
+    change_src =
+      changeAttrValue change_src_func
+
+    make_srcs_local :: (ArrowXml a) => a XmlTree XmlTree
+    make_srcs_local =
+      processAttrl $ (change_src `when` (hasName "src"))

 
 
 parse :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe Page)
 parse xml = do
 
 
 parse :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe Page)
 parse xml = do

-  let clean_xml = preprocess xml
-  appr <- ap_parse clean_xml
-  fppr <- fp_parse clean_xml
+  let clean_xml = xml >>> preprocess
+  image_map <- download_images clean_xml
+  let local_xml = clean_xml >>> replace_remote_img_srcs image_map
+  appr <- ap_parse local_xml
+  fppr <- fp_parse local_xml

   return $
     if (isNothing appr) then
       fppr
   return $
     if (isNothing appr) then
       fppr

-    else
+    else 

       appr
 
 
       appr
 
 


@@ -148,9 +212,9 @@ parse_byline xml = do
 --
 ap_parse :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe Page)
 ap_parse xml = do
 --
 ap_parse :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe Page)
 ap_parse xml = do

-    arts <- ap_parse_articles xml
+    arts <- ap_parse_articles xml          

     case arts of
     case arts of

-      Just [x] -> return $ Just $ ArticlePage x
+      [x] -> return $ Just $ ArticlePage x

       _   -> return Nothing
 
   
       _   -> return Nothing
 
   


@@ -165,16 +229,22 @@ ap_parse_body xml = do
             _   -> error "Found more than one article."
 
 
             _   -> error "Found more than one article."
 
 

-ap_parse_articles :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe [Article])
+ap_parse_articles :: IOSArrow XmlTree (NTree XNode) -> IO [Article]

 ap_parse_articles xml = do
   parsed_headline <- parse_headline xml
   parsed_byline   <- parse_byline xml
   parsed_body     <- ap_parse_body xml
 ap_parse_articles xml = do
   parsed_headline <- parse_headline xml
   parsed_byline   <- parse_byline xml
   parsed_body     <- ap_parse_body xml

-  let title'   = Title (fromJust parsed_headline)
-  let byline' = Byline  parsed_byline
-  let body'   = BodyHtml (fromJust parsed_body)
-  return $ Just $ [Article title' byline' body']

 
 

+  putStrLn $ fromJust parsed_headline
+
+  if (isNothing parsed_headline) || (isNothing parsed_body)
+  then return []
+  else do    
+    let title'  = Title    $ fromJust parsed_headline
+    let byline' = Byline     parsed_byline
+    let body'   = BodyHtml $ fromJust parsed_body
+    
+    return $ [Article title' byline' body']

 
 
 
 
 
 


@@ -187,8 +257,8 @@ fp_parse xml = do
     hl <- parse_headline xml
     parsed_articles <- fp_parse_articles xml
     case parsed_articles of
     hl <- parse_headline xml
     parsed_articles <- fp_parse_articles xml
     case parsed_articles of

-      them@(_:_) -> return $ Just $ FullPage (fromJust hl) them
-      _          -> return Nothing
+      []          -> return Nothing
+      x -> return $ Just $ FullPage (fromJust hl) x

 
 
 
 
 
 


@@ -219,8 +289,7 @@ is_byline =
 
 
 is_image :: (ArrowXml a) => a XmlTree XmlTree
 
 
 is_image :: (ArrowXml a) => a XmlTree XmlTree

-is_image =
-  hasName "img"
+is_image = isElem >>> hasName "img"

 
 remove_title :: (ArrowXml a) => a XmlTree XmlTree
 remove_title =
 
 remove_title :: (ArrowXml a) => a XmlTree XmlTree
 remove_title =


@@ -251,10 +320,15 @@ fp_parse_article xml = do
   parsed_article_title    <- fp_parse_article_title xml
   parsed_article_byline   <- parse_byline xml
   parsed_article_body     <- fp_parse_article_body xml
   parsed_article_title    <- fp_parse_article_title xml
   parsed_article_byline   <- parse_byline xml
   parsed_article_body     <- fp_parse_article_body xml

-  let title'   = Title    $ fromJust parsed_article_title
-  let byline'  = Byline     parsed_article_byline
-  let body'    = BodyHtml $ fromJust parsed_article_body
-  return $ Just $ Article title' byline' body'
+
+  if (isNothing parsed_article_title) || (isNothing parsed_article_body)
+  then
+    return Nothing
+  else do
+    let title'   = Title    $ fromJust parsed_article_title
+    let byline'  = Byline     parsed_article_byline
+    let body'    = BodyHtml $ fromJust parsed_article_body
+    return $ Just $ Article title' byline' body'

 
 parse_html_article :: String -> IO (Maybe Article)
 parse_html_article html = do
 
 parse_html_article :: String -> IO (Maybe Article)
 parse_html_article html = do


@@ -275,7 +349,9 @@ fp_parse_articles xml = do
   let article_separator = "<h2 class=\"SummaryHL\">"
   let split_articles'' = split article_separator (concat bodies)
   -- The first element will contain the crap before the first <h2...>.
   let article_separator = "<h2 class=\"SummaryHL\">"
   let split_articles'' = split article_separator (concat bodies)
   -- The first element will contain the crap before the first <h2...>.

-  let split_articles' = tail split_articles''
+  let split_articles' = case split_articles'' of
+                          (_:_) -> tail split_articles''
+                          []    -> []

   -- Put the separator back, it was lost during the split.
   let split_articles = map (article_separator ++) split_articles'
   --_ <- mapM print_article split_articles
   -- Put the separator back, it was lost during the split.
   let split_articles = map (article_separator ++) split_articles'
   --_ <- mapM print_article split_articles


@@ -331,6 +407,27 @@ xhtml_to_epub epmd =
 
 
 
 
 
 

+--
+-- Misc
+--
+
+image_srcs :: (ArrowXml a) => a XmlTree URL
+image_srcs =
+  css "img"
+  >>>
+  getAttrValue "src"
+
+make_image_srcs_absolute :: (ArrowXml a) => a XmlTree XmlTree
+make_image_srcs_absolute =
+  processTopDown (make_srcs_absolute `when` is_image)
+  where
+    change_src :: (ArrowXml a) => a XmlTree XmlTree
+    change_src =
+      changeAttrValue try_make_absolute_url
+
+    make_srcs_absolute :: (ArrowXml a) => a XmlTree XmlTree
+    make_srcs_absolute = 
+      processAttrl $ change_src `when` hasName "src"

 
 
 --
 
 
 --


@@ -339,7 +436,7 @@ xhtml_to_epub epmd =
 
 test_preprocess_links :: Assertion
 test_preprocess_links = do
 
 test_preprocess_links :: Assertion
 test_preprocess_links = do

-  actual_xml' <- runX $ (preprocess input_xml) >>> css "body"
+  actual_xml' <- runX $ input_xml >>> preprocess >>> css "body"

   let actual_xml = actual_xml' !! 0
 
   expected_xml' <- runX $ expected_xml'' >>> css "body"
   let actual_xml = actual_xml' !! 0
 
   expected_xml' <- runX $ expected_xml'' >>> css "body"


@@ -355,7 +452,59 @@ test_preprocess_links = do
     expected_html = "<body><span>Hello, world!</span></body>"
     expected_xml'' = parseHtml expected_html
 
     expected_html = "<body><span>Hello, world!</span></body>"
     expected_xml'' = parseHtml expected_html
 

+
+test_absolve_images :: Assertion
+test_absolve_images = do
+  actual_xml' <- runX $ input_xml >>> preprocess >>> css "body"
+  let actual_xml = actual_xml' !! 0
+
+  expected_xml' <- runX $ expected_xml'' >>> css "body"
+  let expected_xml = expected_xml' !! 0
+
+  assertEqual
+    "Image srcs are made absolute"
+    expected_xml
+    actual_xml
+  where
+    input_html =
+      "<body>" ++
+      "<img src=\"/images/2012/example.jpg\" />" ++
+      "</body>"
+    input_xml  = parseHtml input_html
+    expected_html =
+      "<body>" ++
+      "<img src=\"https://lwn.net/images/2012/example.jpg\" />" ++
+      "</body>"
+    expected_xml'' = parseHtml expected_html
+
+
+test_comments_removed :: Assertion
+test_comments_removed = do
+  actual_xml' <- runX $ input_xml >>> preprocess >>> css "body"
+  let actual_xml = actual_xml' !! 0
+
+  expected_xml' <- runX $ expected_xml'' >>> css "body"
+  let expected_xml = expected_xml' !! 0
+
+  assertEqual
+    "Comment links are removed"
+    expected_xml
+    actual_xml
+  where
+    input_html =
+      "<body><p>" ++
+      "<a href=\"/Articles/501490/#Comments\">Comments (6 posted)</a>" ++
+      "</p></body>"
+    input_xml  = parseHtml input_html
+
+    expected_html  = "<body><p></p></body>"
+    expected_xml'' = parseHtml expected_html
+
+
+

 page_tests :: Test
 page_tests =
   testGroup "Page Tests" [
 page_tests :: Test
 page_tests =
   testGroup "Page Tests" [

-    testCase "Links are replaced with spans" test_preprocess_links ]
+    testCase "Links are replaced with spans" test_preprocess_links,
+    testCase "Image srcs are made absolute" test_absolve_images,
+    testCase "Comment links are removed" test_comments_removed ]