Implement image download and replacement.

diff --git a/lwn-epub.cabal b/lwn-epub.cabal
index abe1e61980c70c0d5694ded7e1dc635292ed8b61..c374d8d201cc3ad096e36ae1efc5f9d41af6d507 100644 (file)
--- a/lwn-epub.cabal
+++ b/lwn-epub.cabal
@@ -12,6 +12,8 @@ executable lwn-epub
     base                    == 4.5.*,
     bytestring              == 0.9.*,
     cmdargs                 == 0.9.*,
     base                    == 4.5.*,
     bytestring              == 0.9.*,
     cmdargs                 == 0.9.*,

+    containers              == 0.*,
+    curl                    == 1.*,

     directory               == 1.1.*,
     download-curl           == 0.1.*,
     filepath                == 1.3.*,
     directory               == 1.1.*,
     download-curl           == 0.1.*,
     filepath                == 1.3.*,


@@ -22,6 +24,7 @@ executable lwn-epub
     network                 == 2.3.*,
     pandoc                  == 1.9.*,
     regex-posix             == 0.95.*,
     network                 == 2.3.*,
     pandoc                  == 1.9.*,
     regex-posix             == 0.95.*,

+    temporary               == 1.*,

     test-framework          == 0.6.*,
     test-framework-hunit    == 0.2.*,
     time                    == 1.*,
     test-framework          == 0.6.*,
     test-framework-hunit    == 0.2.*,
     time                    == 1.*,

diff --git a/src/LWN/HTTP.hs b/src/LWN/HTTP.hs
index c74248ba9dca05bdcc54c2417758906ecd021212..743a99c8fa0fb98429a114e13e621e074b5b825d 100644 (file)
--- a/src/LWN/HTTP.hs
+++ b/src/LWN/HTTP.hs
@@ -1,7 +1,10 @@
+{-# LANGUAGE DoAndIfThenElse #-}
+

 module LWN.HTTP
 where
 
 import qualified Data.ByteString as B (hPut)
 module LWN.HTTP
 where
 
 import qualified Data.ByteString as B (hPut)

+

 import Network.Curl (
   CurlCode(..),
   CurlOption(..),
 import Network.Curl (
   CurlCode(..),
   CurlOption(..),


@@ -14,7 +17,7 @@ import Network.Curl (
   withCurlDo               
   )
 import Network.Curl.Download (openURI)
   withCurlDo               
   )
 import Network.Curl.Download (openURI)

-import System.Directory (getTemporaryDirectory)
+import System.Directory (doesFileExist, getTemporaryDirectory)

 import System.IO (hPutStrLn, stderr)
 import System.IO.Temp (openBinaryTempFile)
 
 import System.IO (hPutStrLn, stderr)
 import System.IO.Temp (openBinaryTempFile)
 


@@ -58,7 +61,7 @@ get_page cookie_jar url =
     -- Perform the request, and get back a CurlResponse object.
     -- The cast is needed to specify how we would like our headers
     -- and body returned (Strings).
     -- Perform the request, and get back a CurlResponse object.
     -- The cast is needed to specify how we would like our headers
     -- and body returned (Strings).

-    resp <- do_curl_ curl login_url curl_opts :: IO CurlResponse
+    resp <- do_curl_ curl url curl_opts :: IO CurlResponse

 
     -- Pull out the response code as a CurlCode.
     let code = respCurlCode resp
 
     -- Pull out the response code as a CurlCode.
     let code = respCurlCode resp


@@ -113,7 +116,7 @@ log_in cookie_jar username password =
     post_password = password_field ++ "=" ++ password
 
     post_data :: [String]
     post_password = password_field ++ "=" ++ password
 
     post_data :: [String]

-    post_data = [post_username, post_password]
+    post_data = [post_username, post_password, post_submit]

 
     post_opts :: [CurlOption]
     post_opts =
 
     post_opts :: [CurlOption]
     post_opts =


@@ -135,17 +138,22 @@ log_in cookie_jar username password =
 --   knows that type (jpg, png, etc.) it is.
 save_image :: URLString -> IO (Maybe FilePath)
 save_image url = do
 --   knows that type (jpg, png, etc.) it is.
 save_image :: URLString -> IO (Maybe FilePath)
 save_image url = do

-  let fn = filename url
-  case fn of
-    Nothing -> return Nothing
-    Just file -> do
-      temp_dir <- getTemporaryDirectory
-      (out_path, out_handle) <- openBinaryTempFile temp_dir file
-      result <- openURI url
-      case result of
-        Left err -> do
-          hPutStrLn stderr ("HTTP Error: " ++ err)
-          return Nothing
-        Right bs -> do
-          B.hPut out_handle bs
-          return $ Just out_path
+  it_exists <- doesFileExist url
+  if it_exists then do
+    -- It's local, just use it.
+    return $ Just url
+  else do
+    let fn = filename url
+    case fn of
+      Nothing -> return Nothing
+      Just file -> do
+        temp_dir <- getTemporaryDirectory
+        (out_path, out_handle) <- openBinaryTempFile temp_dir file
+        result <- openURI url
+        case result of
+          Left err -> do
+            hPutStrLn stderr ("HTTP Error: " ++ err)
+            return Nothing
+          Right bs -> do
+            B.hPut out_handle bs
+            return $ Just out_path

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 ]

diff --git a/src/LWN/URI.hs b/src/LWN/URI.hs
index 5e61eb6272ad588a09105083bf0e08214db0d7ca..9e7c7d944963a0a52b51b2b6b48aeb48ef57373d 100644 (file)
--- a/src/LWN/URI.hs
+++ b/src/LWN/URI.hs
@@ -112,7 +112,7 @@ filename url =
       let reverse_components = reverse components in
       case reverse_components of
         []     -> Nothing
       let reverse_components = reverse components in
       case reverse_components of
         []     -> Nothing

-        (x:xs) -> Just x
+        (x:_) -> Just x

   where
     parse_result = parseURIReference url
 
   where
     parse_result = parseURIReference url
 


@@ -144,7 +144,13 @@ make_absolute_url relative_url =
   where
     parse_result = parseURIReference relative_url
 
   where
     parse_result = parseURIReference relative_url
 

-
+-- | Like 'make_absolute_url', except returns its input instead of
+--   'Nothing' if the absolution fails.
+try_make_absolute_url :: URL -> URL
+try_make_absolute_url url =
+  case make_absolute_url url of
+    Nothing -> url
+    Just abs_url -> abs_url

 
 -- | A List of LWN URLs to use during testing.
 lwn_urls :: [URL]
 
 -- | A List of LWN URLs to use during testing.
 lwn_urls :: [URL]