X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Flwn-epub.git;a=blobdiff_plain;f=src%2FLWN%2FPage.hs;h=97171c641be08a6761a1a1800002190c7f10b9ed;hp=620e3ec3d8bf66a9a67bff98cc3ac215a2a64b70;hb=aad40cd8e1e8c84c5fc294674a7159bb40838440;hpb=4220827f62d772d7edcbdcc1c2f13d6c2eb5f534 diff --git a/src/LWN/Page.hs b/src/LWN/Page.hs index 620e3ec..97171c6 100644 --- a/src/LWN/Page.hs +++ b/src/LWN/Page.hs @@ -5,10 +5,11 @@ where import qualified Data.Map as Map (lookup) import Data.Time (getCurrentTime) -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 Prelude hiding (readFile) +import System.IO (Handle, hClose, hFlush) import Test.HUnit (Assertion, assertEqual) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) @@ -26,33 +27,34 @@ import Text.XML.HXT.Core ( (/>), (//>), changeAttrValue, - getAttrValue, getChildren, getText, - hasAttrValue, hasName, - isElem, - mkName, - none, processAttrl, processTopDown, runX, - setElemName, xshow, when) import Text.HandsomeSoup (css, parseHtml) +import Configuration (Cfg) import LWN.Article -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 LWN.HTTP ( + ImageMap, + download_image_urls, + get_article_contents) +import LWN.URI (URL) +import LWN.XHTML ( + XHTML, + image_srcs, + is_image, + preprocess, + remove_byline, + remove_title, + to_xhtml, + xml_from_contents) + --- 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 data Page = @@ -77,9 +79,7 @@ instance XHTML Page where " " ++ (show $ LWN.Article.title a) ++ "" ++ "" ++ "" ++ - "
" ++ (to_xhtml a) ++ - "
" ++ "" ++ "" @@ -102,37 +102,21 @@ instance XHTML Page where -is_link :: (ArrowXml a) => a XmlTree XmlTree -is_link = - isElem >>> hasName "a" +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 + Just html -> parse html + Nothing -> return Nothing -remove_comment_links :: (ArrowXml a) => a XmlTree XmlTree -remove_comment_links = - processTopDown $ kill_comments `when` is_link - where - 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 = - processTopDown $ (make_span >>> remove_attrs) `when` is_link - where - make_span = setElemName $ mkName "span" - remove_attrs = processAttrl none +-- 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 --- | Preprocessing common to both page types. -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 @@ -262,33 +246,6 @@ fp_parse_article_title xml = do -is_title :: (ArrowXml a) => a XmlTree XmlTree -is_title = - (hasName "h2") - >>> - (hasAttrValue "class" (== "SummaryHL")) - - -is_byline :: (ArrowXml a) => a XmlTree XmlTree -is_byline = - (hasName "div") - >>> - (hasAttrValue "class" (== "FeatureByLine")) - - -is_image :: (ArrowXml a) => a XmlTree XmlTree -is_image = isElem >>> hasName "img" - -remove_title :: (ArrowXml a) => a XmlTree XmlTree -remove_title = - processTopDown ((none) `when` is_title) - - -remove_byline :: (ArrowXml a) => a XmlTree XmlTree -remove_byline = - processTopDown ((none) `when` is_byline) - - fp_parse_article_body :: IOSArrow XmlTree XmlTree -> IO (Maybe String) fp_parse_article_body xml = do @@ -395,30 +352,6 @@ xhtml_to_epub epmd = read_html = readHtml defaultParserState - --- --- 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" - - -- -- Tests --