Only fetch login cookies once.

Implement the full story downloading (still buggy).
Reorganize many of the XML functions.

diff --git a/src/Configuration.hs b/src/Configuration.hs
index 4898c08978e6d71846c85c535c39c64b4642edd9..478d465ef8aefe5eb1225d60505b23bdffedeab8 100644 (file)
--- a/src/Configuration.hs
+++ b/src/Configuration.hs
@@ -28,37 +28,43 @@ import ExitCodes
 
 -- | Contains all of our configurable options.
 data Cfg = Cfg {
 
 -- | Contains all of our configurable options.
 data Cfg = Cfg {

-  article  :: String,
-  output :: FilePath,
-  password :: Maybe String,
-  username :: Maybe String }
+  article    :: String,
+  cookie_jar :: Maybe FilePath,
+  output     :: FilePath,
+  password   :: Maybe String,
+  username   :: Maybe String }

 
 
 instance Monoid Cfg where
   mempty = Cfg { article  = "",
 
 
 instance Monoid Cfg where
   mempty = Cfg { article  = "",

+                 cookie_jar = Nothing,

                  output   = "",
                  password = Nothing,
                  username = Nothing }
 
   mappend c1 c2 =
                  output   = "",
                  password = Nothing,
                  username = Nothing }
 
   mappend c1 c2 =

-    let article'  = (if null article1 then article2 else article1)
-        output'   = (if null output1 then output2 else output1)
-        password' = password1 `mplus` password2
-        username' = username1 `mplus` username2
+    let article'    = (if null article1 then article2 else article1)
+        cookie_jar' = cookie_jar1 `mplus` cookie_jar2
+        output'     = (if null output1 then output2 else output1)
+        password'   = password1 `mplus` password2
+        username'   = username1 `mplus` username2

     in
     in

-        Cfg { article  = article',
-              output   = output',
-              password = password',
-              username = username' }
+        Cfg { article    = article',
+              cookie_jar = cookie_jar',
+              output     = output',
+              password   = password',
+              username   = username' }

     where
     where

-      article1  = article c1
-      article2  = article c2
-      output1   = output c1
-      output2   = output c2
-      password1 = password c1
-      password2 = password c2
-      username1 = username c1
-      username2 = username c2
+      article1    = article c1
+      article2    = article c2
+      cookie_jar1 = cookie_jar c1
+      cookie_jar2 = cookie_jar c2
+      output1     = output c1
+      output2     = output c2
+      password1   = password c1
+      password2   = password c2
+      username1   = username c1
+      username2   = username c2

 
 
 use_account :: Cfg -> Bool
 
 
 use_account :: Cfg -> Bool

diff --git a/src/LWN/Article.hs b/src/LWN/Article.hs
index ac3d456da8aae0ef43339e66c9bd62d5e92cff44..47e36519858209235829485c6cf099309d1d7963 100644 (file)
--- a/src/LWN/Article.hs
+++ b/src/LWN/Article.hs
@@ -98,12 +98,14 @@ real_article_path path = do
   where
     abs_current = try_make_absolute_url ("/" ++ path)
     abs_article = try_make_absolute_url ("Articles/" ++ path)
   where
     abs_current = try_make_absolute_url ("/" ++ path)
     abs_article = try_make_absolute_url ("Articles/" ++ path)

+    abs_full_article = try_make_absolute_url path

 
     check_cases :: String
     check_cases
       | is_lwn_url path = make_https path
       | isPrefixOf "current" path = abs_current
       | path =~ "^[0-9]+$" = abs_article
 
     check_cases :: String
     check_cases
       | is_lwn_url path = make_https path
       | isPrefixOf "current" path = abs_current
       | path =~ "^[0-9]+$" = abs_article

+      | path =~ "^/Articles/[0-9]+/?$" = abs_full_article

       | otherwise = path -- Give up
 
 
       | otherwise = path -- Give up
 
 

diff --git a/src/LWN/HTTP.hs b/src/LWN/HTTP.hs
index 7da6ed1488d97114247091476c26b57ace5cc7d8..63079fd127aa853e6b69eef96588153dace02d30 100644 (file)
--- a/src/LWN/HTTP.hs
+++ b/src/LWN/HTTP.hs
@@ -5,7 +5,7 @@ where
 
 import qualified Data.ByteString as B (hPut)
 import qualified Data.Map as Map (Map, empty, insert)
 
 import qualified Data.ByteString as B (hPut)
 import qualified Data.Map as Map (Map, empty, insert)

-import Data.Maybe (fromJust)
+import Data.Maybe (fromJust, isNothing)

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


@@ -22,7 +22,7 @@ import System.IO (hClose, hPutStrLn, stderr)
 import qualified System.IO.UTF8 as Utf8 (readFile)
 import System.IO.Temp (openBinaryTempFile, openTempFile)
 
 import qualified System.IO.UTF8 as Utf8 (readFile)
 import System.IO.Temp (openBinaryTempFile, openTempFile)
 

-import qualified Configuration as C (Cfg, password, use_account, username)
+import qualified Configuration as C (Cfg(..))

 import LWN.Article (real_article_path)
 import LWN.URI (URL, filename)
 
 import LWN.Article (real_article_path)
 import LWN.URI (URL, filename)
 


@@ -188,6 +188,29 @@ download_image_urls image_urls = do
     my_insert dict (k, Just v) = Map.insert k v dict
 
 
     my_insert dict (k, Just v) = Map.insert k v dict
 
 

+
+
+
+get_login_cookie :: C.Cfg -> IO C.Cfg
+get_login_cookie cfg
+  | isNothing (C.username cfg) = return cfg
+  | isNothing (C.password cfg) = return cfg
+  | otherwise = do
+      let uname = fromJust $ C.username cfg
+      let pword = fromJust $ C.password cfg
+      cj <- make_cookie_jar
+      li_result <- log_in cj uname pword
+
+      case li_result of
+        Left err -> do
+          let msg = "Failed to log in. " ++ err
+          hPutStrLn stderr msg
+        Right response_body -> do
+          hPutStrLn stderr response_body
+
+      return $ cfg { C.cookie_jar = Just cj }
+
+

 -- | Try to parse the given article using HXT. We try a few different
 --   methods; if none of them work, we return 'Nothing'.
 get_article_contents :: C.Cfg -> URL -> IO (Maybe String)
 -- | Try to parse the given article using HXT. We try a few different
 --   methods; if none of them work, we return 'Nothing'.
 get_article_contents :: C.Cfg -> URL -> IO (Maybe String)


@@ -200,33 +223,11 @@ get_article_contents cfg article_name = do
       return $ Just $ contents
     False -> do
       -- Download the URL and try to parse it.
       return $ Just $ contents
     False -> do
       -- Download the URL and try to parse it.

-      if C.use_account cfg then do
-        -- use_account would be false if these fromJusts would fail.
-        cj <- make_cookie_jar
-        li_result <- log_in cj
-                      (fromJust $ C.username cfg)
-                      (fromJust $ C.password cfg)
-
-        case li_result of
-          Left err -> do
-            let msg = "Failed to log in. " ++ err
-            hPutStrLn stderr msg
-          Right response_body -> do
-            hPutStrLn stderr response_body
-
-        html <- get_page (Just cj) my_article
-
-        case html of
-          Left err -> do
-            let msg = "Failed to retrieve page. " ++ err
-            hPutStrLn stderr msg
-            return Nothing
-          Right h -> return $ Just h
-      else do
-        html <- get_page Nothing my_article
-        case html of
-          Left err -> do
-            let msg = "Failed to retrieve page. " ++ err
-            hPutStrLn stderr msg
-            return Nothing
-          Right h -> return $ Just h
+      html <- get_page (C.cookie_jar cfg) my_article
+
+      case html of
+        Left err -> do
+          let msg = "Failed to retrieve page. " ++ err
+          hPutStrLn stderr msg
+          return Nothing
+        Right h -> return $ Just h

diff --git a/src/LWN/Page.hs b/src/LWN/Page.hs
index 97171c641be08a6761a1a1800002190c7f10b9ed..f0ada7cd13cfff0707904272f93fa2b4b354f9e3 100644 (file)
--- a/src/LWN/Page.hs
+++ b/src/LWN/Page.hs
@@ -7,6 +7,7 @@ import qualified Data.Map as Map (lookup)
 import Data.Time (getCurrentTime)
 import qualified Data.ByteString.Lazy as B (ByteString, hPut)
 import Data.String.Utils (split, strip)
 import Data.Time (getCurrentTime)
 import qualified Data.ByteString.Lazy as B (ByteString, hPut)
 import Data.String.Utils (split, strip)

+import qualified Data.Map as Map (Map, empty, insert)

 import Data.Maybe (catMaybes, fromJust, isNothing)
 import Prelude hiding (readFile)
 import System.IO (Handle, hClose, hFlush)
 import Data.Maybe (catMaybes, fromJust, isNothing)
 import Prelude hiding (readFile)
 import System.IO (Handle, hClose, hFlush)


@@ -23,15 +24,18 @@ import Text.XML.HXT.Core (
   ArrowXml,
   IOSArrow,
   XmlTree,
   ArrowXml,
   IOSArrow,
   XmlTree,

+  ($<),

   (>>>),
   (/>),
   (//>),
   changeAttrValue,
   (>>>),
   (/>),
   (//>),
   changeAttrValue,

+  getAttrValue,

   getChildren,
   getText,
   hasName,
   processAttrl,
   processTopDown,
   getChildren,
   getText,
   hasName,
   processAttrl,
   processTopDown,

+  this,

   runX,
   xshow,
   when)
   runX,
   xshow,
   when)


@@ -46,12 +50,16 @@ import LWN.HTTP (
 import LWN.URI (URL)
 import LWN.XHTML (
   XHTML,
 import LWN.URI (URL)
 import LWN.XHTML (
   XHTML,

+  full_story_urls,

   image_srcs,
   image_srcs,

+  full_story_link,
+  full_story_paragraph,

   is_image,
   preprocess,
   remove_byline,
   remove_title,
   to_xhtml,
   is_image,
   preprocess,
   remove_byline,
   remove_title,
   to_xhtml,

+  to_xml,

   xml_from_contents)
 
 
   xml_from_contents)
 
 


@@ -106,19 +114,28 @@ page_from_url :: Cfg -> URL -> IO (Maybe Page)
 page_from_url cfg url = do
   contents <- get_article_contents cfg url  
   case (xml_from_contents contents) of
 page_from_url cfg url = do
   contents <- get_article_contents cfg url  
   case (xml_from_contents contents) of

-    Just html -> parse html
+    Just html -> parse cfg html

     Nothing -> return Nothing
 
 
 
     Nothing -> return Nothing
 
 
 

--- Should be called *after* preprocessing.
-download_images :: IOSArrow XmlTree XmlTree -> IO ImageMap
-download_images xml = do
-  image_urls <- runX $ xml >>> image_srcs
-  download_image_urls image_urls
-
-
-
+insert_full_stories :: (ArrowXml a) => StoryMap -> a XmlTree XmlTree
+insert_full_stories story_map =
+  processTopDown (article_xml `when` full_story_paragraph)
+  where
+    lookup_func :: (ArrowXml a) => URL -> a XmlTree XmlTree
+    lookup_func href =
+      case Map.lookup href story_map of
+        -- Leave it alone if we don't have the full story.
+        Nothing -> this
+        Just v -> to_xml v
+
+    article_xml :: (ArrowXml a) => a XmlTree XmlTree
+    article_xml =
+      lookup_func
+      $<
+      (this /> full_story_link >>> getAttrValue "href")
+                   

 replace_remote_img_srcs :: (ArrowXml a) => ImageMap -> a XmlTree XmlTree
 replace_remote_img_srcs image_map =
   processTopDown (make_srcs_local `when` is_image)
 replace_remote_img_srcs :: (ArrowXml a) => ImageMap -> a XmlTree XmlTree
 replace_remote_img_srcs image_map =
   processTopDown (make_srcs_local `when` is_image)


@@ -140,11 +157,47 @@ replace_remote_img_srcs image_map =
       processAttrl $ (change_src `when` (hasName "src"))
 
 
       processAttrl $ (change_src `when` (hasName "src"))
 
 

-parse :: IOSArrow XmlTree XmlTree -> IO (Maybe Page)
-parse xml = do
-  let clean_xml = xml >>> preprocess
+
+
+-- Should be called *after* preprocessing.
+download_images :: IOSArrow XmlTree XmlTree -> IO ImageMap
+download_images xml = do
+  image_urls <- runX $ xml >>> image_srcs
+  download_image_urls image_urls
+
+
+
+type StoryMap = Map.Map URL Article
+
+-- These come *before* preprocessing.
+download_full_story_urls :: Cfg -> [URL] -> IO StoryMap
+download_full_story_urls cfg story_urls = do
+  pages <- mapM (page_from_url cfg) story_urls
+  let pairs = zip story_urls pages
+  return $ foldl my_insert empty_map pairs
+  where
+    empty_map = Map.empty :: StoryMap
+
+    my_insert :: StoryMap -> (URL, Maybe Page) -> StoryMap
+    my_insert dict (k, Just (ArticlePage v)) = Map.insert k v dict
+    my_insert dict (_, _)  = dict
+
+
+download_full_stories :: Cfg -> IOSArrow XmlTree XmlTree -> IO StoryMap
+download_full_stories cfg xml = do
+  story_urls <- runX $ xml >>> full_story_urls
+  download_full_story_urls cfg story_urls
+  
+
+parse :: Cfg -> IOSArrow XmlTree XmlTree -> IO (Maybe Page)
+parse cfg xml = do
+  story_map <- download_full_stories cfg xml
+  let fs_xml = xml >>> insert_full_stories story_map
+
+  let clean_xml = fs_xml >>> preprocess

   image_map <- download_images clean_xml
   let local_xml = clean_xml >>> replace_remote_img_srcs image_map
   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 $
   appr <- ap_parse local_xml
   fppr <- fp_parse local_xml
   return $


@@ -423,10 +476,33 @@ test_comments_removed = do
     expected_xml'' = parseHtml expected_html
 
 
     expected_xml'' = parseHtml expected_html
 
 

+test_full_story_urls_parsed :: Assertion
+test_full_story_urls_parsed = do
+  actual <- runX $ actual'
+
+  assertEqual
+    "Full Story URLs are parsed"
+    expected
+    actual
+  where
+    expected = ["/Articles/500738/", "/Articles/501837/"]
+
+    full_story_html =
+      concat ["<p>",
+              "<a href=\"/Articles/500738/\">Full Story</a> ",
+              "(<a href=\"/Articles/500738/#Comments\">comments: 49</a>)",
+              "<p>",
+              "<a href=\"/Articles/501837/\">Full Story</a> ",
+              "(<a href=\"/Articles/501837/#Comments\">comments: none</a>)",
+              "<p>"]
+
+    xml = parseHtml full_story_html
+    actual' = xml >>> full_story_urls

 
 page_tests :: Test
 page_tests =
   testGroup "Page Tests" [
     testCase "Links are replaced with spans" test_preprocess_links,
     testCase "Image srcs are made absolute" test_absolve_images,
 
 page_tests :: Test
 page_tests =
   testGroup "Page Tests" [
     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 ]
+    testCase "Comment links are removed" test_comments_removed,
+    testCase "Full Story URLs are parsed" test_full_story_urls_parsed ]

diff --git a/src/LWN/XHTML.hs b/src/LWN/XHTML.hs
index 8dfe3b2e85645c451b601a58af96107f571e589b..a2f103fa0d83b7ae433f239036e02456eb6e08f3 100644 (file)
--- a/src/LWN/XHTML.hs
+++ b/src/LWN/XHTML.hs
@@ -1,7 +1,10 @@
 module LWN.XHTML (
   XHTML,
   XML,
 module LWN.XHTML (
   XHTML,
   XML,

+  full_story_urls,

   image_srcs,
   image_srcs,

+  full_story_link,
+  full_story_paragraph,

   is_image,
   parse_lwn,
   preprocess,
   is_image,
   parse_lwn,
   preprocess,


@@ -13,16 +16,21 @@ module LWN.XHTML (
 where
 
 import Text.HandsomeSoup (css)
 where
 
 import Text.HandsomeSoup (css)

+import Text.Regex.Posix ((=~))

 import Text.XML.HXT.Core (
   (>>>),
 import Text.XML.HXT.Core (
   (>>>),

+  (/>),

   ArrowXml,
   IOStateArrow,
   SysConfigList,
   XmlTree,
   changeAttrValue,
   ArrowXml,
   IOStateArrow,
   SysConfigList,
   XmlTree,
   changeAttrValue,

+  deep,

   getAttrValue,
   hasAttrValue,
   hasName,
   getAttrValue,
   hasAttrValue,
   hasName,

+  hasText,
+  ifA,

   isElem,
   mkName,
   no,
   isElem,
   mkName,
   no,


@@ -31,12 +39,14 @@ import Text.XML.HXT.Core (
   processTopDown,
   readString,
   setElemName,
   processTopDown,
   readString,
   setElemName,

+  this,

   when,
   withParseHTML,
   withValidate,
   withWarnings,
   yes)
 
   when,
   withParseHTML,
   withValidate,
   withWarnings,
   yes)
 

+

 import LWN.URI (URL, try_make_absolute_url)
 import Misc (contains)
 
 import LWN.URI (URL, try_make_absolute_url)
 import Misc (contains)
 


@@ -132,6 +142,44 @@ image_srcs =
   >>>
   getAttrValue "src"
 
   >>>
   getAttrValue "src"
 

+
+full_story_paragraph :: (ArrowXml a) => a XmlTree XmlTree
+full_story_paragraph =
+  isElem
+  >>>
+  hasName "p"
+  >>>
+  ifA
+    (this /> full_story_link)
+    this
+    none
+
+
+-- Without regard to the parent paragraph.
+full_story_link :: (ArrowXml a) => a XmlTree XmlTree
+full_story_link =
+  isElem
+  >>>
+  hasName "a"
+  >>>
+  ifA
+    (this /> hasText (=~ "Full Story"))
+    this
+    none
+
+
+-- | Get the hrefs of all full story links.
+full_story_urls :: (ArrowXml a) => a XmlTree URL
+full_story_urls =
+  deep $ 
+  full_story_paragraph
+  />
+  full_story_link
+  >>>
+  getAttrValue "href"
+
+
+

 make_image_srcs_absolute :: (ArrowXml a) => a XmlTree XmlTree
 make_image_srcs_absolute =
   processTopDown (make_srcs_absolute `when` is_image)
 make_image_srcs_absolute :: (ArrowXml a) => a XmlTree XmlTree
 make_image_srcs_absolute =
   processTopDown (make_srcs_absolute `when` is_image)

diff --git a/src/Main.hs b/src/Main.hs
index 88ba39c5ff493cd9b3b0acafc9992738d080138f..a1230d60e836c08e849f9c40e78b34e6c4925151 100644 (file)
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,6 +2,7 @@
 module Main
 where
 
 module Main
 where
 

+import System.Directory (doesFileExist)

 import System.IO (
   Handle,
   IOMode (WriteMode),
 import System.IO (
   Handle,
   IOMode (WriteMode),


@@ -10,6 +11,8 @@ import System.IO (
 
 import CommandLine (show_help)
 import Configuration (Cfg(..), get_cfg)
 
 import CommandLine (show_help)
 import Configuration (Cfg(..), get_cfg)

+import LWN.Article (real_article_path)
+import LWN.HTTP (get_login_cookie)

 import LWN.Page (epublish, page_from_url)
 
 
 import LWN.Page (epublish, page_from_url)
 
 


@@ -24,9 +27,18 @@ get_output_handle path =
     openBinaryFile path WriteMode
 
 
     openBinaryFile path WriteMode
 
 

+argument_is_file :: Cfg -> IO Bool
+argument_is_file cfg = do
+  path <- real_article_path (article cfg)
+  doesFileExist path
+

 main :: IO ()
 main = do
 main :: IO ()
 main = do

-  cfg <- get_cfg
+  cfg' <- get_cfg
+  aif <- argument_is_file cfg'
+  cfg  <- case aif of
+           False -> get_login_cookie cfg'
+           True  -> return cfg'

   page <- page_from_url cfg (article cfg)
   case page of
     Just p -> do
   page <- page_from_url cfg (article cfg)
   case page of
     Just p -> do