Implement image download and replacement.
authorMichael Orlitzky <michael@orlitzky.com>
Wed, 27 Jun 2012 21:00:48 +0000 (17:00 -0400)
committerMichael Orlitzky <michael@orlitzky.com>
Wed, 27 Jun 2012 21:00:48 +0000 (17:00 -0400)
lwn-epub.cabal
src/LWN/HTTP.hs
src/LWN/Page.hs
src/LWN/URI.hs

index abe1e61980c70c0d5694ded7e1dc635292ed8b61..c374d8d201cc3ad096e36ae1efc5f9d41af6d507 100644 (file)
@@ -12,6 +12,8 @@ executable lwn-epub
     base                    == 4.5.*,
     bytestring              == 0.9.*,
     cmdargs                 == 0.9.*,
+    containers              == 0.*,
+    curl                    == 1.*,
     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.*,
+    temporary               == 1.*,
     test-framework          == 0.6.*,
     test-framework-hunit    == 0.2.*,
     time                    == 1.*,
index c74248ba9dca05bdcc54c2417758906ecd021212..743a99c8fa0fb98429a114e13e621e074b5b825d 100644 (file)
@@ -1,7 +1,10 @@
+{-# LANGUAGE DoAndIfThenElse #-}
+
 module LWN.HTTP
 where
 
 import qualified Data.ByteString as B (hPut)
+
 import Network.Curl (
   CurlCode(..),
   CurlOption(..),
@@ -14,7 +17,7 @@ import Network.Curl (
   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)
 
@@ -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).
-    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
@@ -113,7 +116,7 @@ log_in cookie_jar username password =
     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 =
@@ -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
-  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
index a4a56c222a8ebd1533fff5e9773efbf2dfe22acf..0307214176a82c469f1f555a056b553c05bd3b06 100644 (file)
@@ -1,16 +1,20 @@
+{-# LANGUAGE DoAndIfThenElse #-}
+
 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.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 Text.Pandoc
 import Text.XML.HXT.Core (
   ArrowXml,
   IOSArrow,
@@ -19,10 +23,13 @@ import Text.XML.HXT.Core (
   (>>>),
   (/>),
   (//>),
+  changeAttrValue,
+  getAttrValue,
   getChildren,
   getText,
   hasAttrValue,
   hasName,
+  isElem,
   mkName,
   none,
   processAttrl,
@@ -35,8 +42,29 @@ import Text.XML.HXT.Core (
 import Text.HandsomeSoup (css, parseHtml)
 
 import LWN.Article
+import LWN.HTTP (save_image)
+import LWN.URI (URL, try_make_absolute_url)
 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 } |
@@ -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 =
-  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 =
@@ -100,21 +136,49 @@ replace_links_with_spans =
     make_span    = setElemName $ mkName "span"
     remove_attrs = processAttrl none
 
+
 -- | 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
-  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
-    else
+    else 
       appr
 
 
@@ -148,9 +212,9 @@ parse_byline 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
-      Just [x] -> return $ Just $ ArticlePage x
+      [x] -> return $ Just $ ArticlePage x
       _   -> return Nothing
 
   
@@ -165,16 +229,22 @@ ap_parse_body xml = do
             _   -> 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
-  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
-      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 =
-  hasName "img"
+is_image = isElem >>> hasName "img"
 
 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
-  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
@@ -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 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
@@ -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
-  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"
@@ -355,7 +452,59 @@ test_preprocess_links = do
     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" [
-    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 ]
index 5e61eb6272ad588a09105083bf0e08214db0d7ca..9e7c7d944963a0a52b51b2b6b48aeb48ef57373d 100644 (file)
@@ -112,7 +112,7 @@ filename url =
       let reverse_components = reverse components in
       case reverse_components of
         []     -> Nothing
-        (x:xs) -> Just x
+        (x:_) -> Just x
   where
     parse_result = parseURIReference url
 
@@ -144,7 +144,13 @@ make_absolute_url 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]