X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Flwn-epub.git;a=blobdiff_plain;f=src%2FLWN%2FPage.hs;h=620e3ec3d8bf66a9a67bff98cc3ac215a2a64b70;hp=7419402a3af304974dac87236826b4fcd8f545ae;hb=4220827f62d772d7edcbdcc1c2f13d6c2eb5f534;hpb=ebedcdb6b1b8925dcfb5700d076f25743fac8645

diff --git a/src/LWN/Page.hs b/src/LWN/Page.hs
index 7419402..620e3ec 100644
--- a/src/LWN/Page.hs
+++ b/src/LWN/Page.hs
@@ -3,22 +3,25 @@
 module LWN.Page
 where
 
-import qualified Data.Map as Map
+import qualified Data.Map as Map (lookup)
 import Data.Time (getCurrentTime)
-import System.IO (Handle)
+import System.IO (Handle, hClose, hFlush)
 import qualified Data.ByteString.Lazy as B (ByteString, hPut)
 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.Pandoc (
+  defaultParserState,
+  defaultWriterOptions,
+  readHtml,
+  writeEPUB,
+  writerEPUBMetadata)
 import Text.XML.HXT.Core (
   ArrowXml,
   IOSArrow,
   XmlTree,
-  XNode,
   (>>>),
   (/>),
   (//>),
@@ -36,33 +39,20 @@ import Text.XML.HXT.Core (
   runX,
   setElemName,
   xshow,
-  when
-  )
+  when)
 import Text.HandsomeSoup (css, parseHtml)
 
 import LWN.Article
-import LWN.HTTP (save_image)
+import LWN.HTTP (ImageMap, download_image_urls)
 import LWN.URI (URL, try_make_absolute_url)
+import LWN.XHTML (XHTML, to_xhtml)
 import Misc (contains)
-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 :: IOSArrow XmlTree XmlTree -> 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
+  download_image_urls image_urls
 
 
 data Page =
@@ -120,7 +110,7 @@ is_link =
 remove_comment_links  :: (ArrowXml a) => a XmlTree XmlTree
 remove_comment_links =
   processTopDown $ kill_comments `when` is_link
-  where    
+  where
     is_comment_link =
       hasAttrValue "href" (contains "#Comments")
 
@@ -166,7 +156,7 @@ replace_remote_img_srcs image_map =
       processAttrl $ (change_src `when` (hasName "src"))
 
 
-parse :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe Page)
+parse :: IOSArrow XmlTree XmlTree -> IO (Maybe Page)
 parse xml = do
   let clean_xml = xml >>> preprocess
   image_map <- download_images clean_xml
@@ -176,12 +166,12 @@ parse xml = do
   return $
     if (isNothing appr) then
       fppr
-    else 
+    else
       appr
 
 
 
-parse_headline :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe String)
+parse_headline :: IOSArrow XmlTree XmlTree -> IO (Maybe String)
 parse_headline xml = do
   let element_filter = xml >>> css "div.PageHeadline h1"
   let element_text_filter = element_filter /> getText
@@ -193,7 +183,7 @@ parse_headline xml = do
       _   -> error "Found more than one headline."
 
 
-parse_byline :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe String)
+parse_byline :: IOSArrow XmlTree XmlTree -> IO (Maybe String)
 parse_byline xml = do
   let element_filter = xml >>> css "div.FeatureByLine"
   let element_text_filter = element_filter /> getText
@@ -208,15 +198,15 @@ parse_byline xml = do
 --
 -- ArticlePage Stuff
 --
-ap_parse :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe Page)
+ap_parse :: IOSArrow XmlTree XmlTree -> IO (Maybe Page)
 ap_parse xml = do
-    arts <- ap_parse_articles xml          
+    arts <- ap_parse_articles xml
     case arts of
       [x] -> return $ Just $ ArticlePage x
       _   -> return Nothing
 
-  
-ap_parse_body :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe String)
+
+ap_parse_body :: IOSArrow XmlTree XmlTree -> IO (Maybe String)
 ap_parse_body xml = do
   let element_filter = xml >>> css "div.ArticleText"
   let element_html_filter = xshow element_filter
@@ -227,7 +217,7 @@ ap_parse_body xml = do
             _   -> error "Found more than one article."
 
 
-ap_parse_articles :: IOSArrow XmlTree (NTree XNode) -> IO [Article]
+ap_parse_articles :: IOSArrow XmlTree XmlTree -> IO [Article]
 ap_parse_articles xml = do
   parsed_headline <- parse_headline xml
   parsed_byline   <- parse_byline xml
@@ -237,11 +227,11 @@ ap_parse_articles xml = do
 
   if (isNothing parsed_headline) || (isNothing parsed_body)
   then return []
-  else do    
+  else do
     let title'  = Title    $ fromJust parsed_headline
     let byline' = Byline     parsed_byline
     let body'   = BodyHtml $ fromJust parsed_body
-    
+
     return $ [Article title' byline' body']
 
 
@@ -250,7 +240,7 @@ ap_parse_articles xml = do
 -- FullPage Stuff
 --
 
-fp_parse :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe Page)
+fp_parse :: IOSArrow XmlTree XmlTree -> IO (Maybe Page)
 fp_parse xml = do
     hl <- parse_headline xml
     parsed_articles <- fp_parse_articles xml
@@ -260,7 +250,7 @@ fp_parse xml = do
 
 
 
-fp_parse_article_title :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe String)
+fp_parse_article_title :: IOSArrow XmlTree XmlTree -> IO (Maybe String)
 fp_parse_article_title xml = do
   let element_filter = xml >>> css "h2.SummaryHL"
   let element_text_filter = element_filter //> getText
@@ -300,7 +290,7 @@ remove_byline =
 
 
 
-fp_parse_article_body :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe String)
+fp_parse_article_body :: IOSArrow XmlTree XmlTree -> IO (Maybe String)
 fp_parse_article_body xml = do
   -- First, delete the article title and byline.
   let clean_xml' = xml >>> remove_title >>> remove_byline
@@ -313,7 +303,7 @@ fp_parse_article_body xml = do
             []  -> Nothing
             _   -> error "Found more than one article body."
 
-fp_parse_article :: IOSArrow XmlTree (NTree XNode) -> IO (Maybe Article)
+fp_parse_article :: IOSArrow XmlTree XmlTree -> IO (Maybe Article)
 fp_parse_article xml = do
   parsed_article_title    <- fp_parse_article_title xml
   parsed_article_byline   <- parse_byline xml
@@ -333,15 +323,15 @@ parse_html_article html = do
   let xml = parseHtml $ wrap_in_body_div html
   fp_parse_article xml
 
-  
+
 -- | In the full page, all of the article titles and bodies are
 --   wrapped in one big div.ArticleText.
-parse_bodies :: IOSArrow XmlTree (NTree XNode) -> IOSArrow XmlTree (NTree XNode)
+parse_bodies :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
 parse_bodies xml =
   xml >>> css "div.ArticleText"
 
 
-fp_parse_articles :: IOSArrow XmlTree (NTree XNode) -> IO [Article]
+fp_parse_articles :: IOSArrow XmlTree XmlTree -> IO [Article]
 fp_parse_articles xml = do
   bodies <- runX . xshow $ parse_bodies xml
   let article_separator = "<h2 class=\"SummaryHL\">"
@@ -393,7 +383,8 @@ epublish obj handle = do
   epmd <- metadata obj
   epub <- xhtml_to_epub epmd xhtml
   B.hPut handle epub
-
+  hFlush handle
+  hClose handle
 
 xhtml_to_epub :: String -> String -> IO B.ByteString
 xhtml_to_epub epmd =
@@ -424,7 +415,7 @@ make_image_srcs_absolute =
       changeAttrValue try_make_absolute_url
 
     make_srcs_absolute :: (ArrowXml a) => a XmlTree XmlTree
-    make_srcs_absolute = 
+    make_srcs_absolute =
       processAttrl $ change_src `when` hasName "src"