From 608276fe9aa6d249344aa46cee24376fe6bf2ad0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 5 Jun 2008 01:48:31 -0500
Subject: [PATCH] Improve furnace RSS support

---
 extra/furnace/furnace.factor |  4 +--
 extra/furnace/rss/rss.factor | 48 ++++++++++++++++++++++++++++++++----
 extra/rss/rss-tests.factor   |  3 +++
 extra/rss/rss.factor         | 12 ++++-----
 4 files changed, 54 insertions(+), 13 deletions(-)

diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index 4859d8b0f6..862ed80e11 100644
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -8,7 +8,6 @@ xml
 xml.data
 xml.entities
 xml.writer
-xml.utilities
 html.components
 html.elements
 html.templates
@@ -20,6 +19,7 @@ http.server.redirection
 http.server.responses
 qualified ;
 QUALIFIED-WITH: assocs a
+EXCLUDE: xml.utilities => children>string ;
 IN: furnace
 
 : nested-responders ( -- seq )
@@ -97,7 +97,7 @@ SYMBOL: exit-continuation
     [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
 
 CHLOE: atom
-    [ "title" required-attr ]
+    [ children>string ]
     [ "href" required-attr ]
     [ "query" optional-attr parse-query-attr ] tri
     <url>
diff --git a/extra/furnace/rss/rss.factor b/extra/furnace/rss/rss.factor
index a94ef4fe51..c2163eda66 100644
--- a/extra/furnace/rss/rss.factor
+++ b/extra/furnace/rss/rss.factor
@@ -1,14 +1,52 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel fry
-rss http.server.responses furnace.actions ;
+USING: accessors kernel sequences fry sequences.lib
+combinators rss http.server.responses http.server.redirection
+furnace furnace.actions ;
 IN: furnace.rss
 
+GENERIC: feed-entry-title ( object -- string )
+
+GENERIC: feed-entry-date ( object -- timestamp )
+
+GENERIC: feed-entry-url ( object -- url )
+
+GENERIC: feed-entry-description ( object -- description )
+
+M: object feed-entry-description drop f ;
+
+GENERIC: >entry ( object -- entry )
+
+M: entry >entry ;
+
+M: object >entry
+    <entry>
+        swap {
+            [ feed-entry-title >>title ]
+            [ feed-entry-date >>date ]
+            [ feed-entry-url >>url ]
+            [ feed-entry-description >>description ]
+        } cleave ;
+
+: process-entries ( seq -- seq' )
+    20 short head-slice [
+        >entry clone
+        [ adjust-url relative-to-request ] change-url
+    ] map ;
+
 : <feed-content> ( body -- response )
     feed>xml "application/atom+xml" <content> ;
 
-TUPLE: feed-action < action feed ;
+TUPLE: feed-action < action title url entries ;
 
-: <feed-action> ( -- feed )
+: <feed-action> ( -- action )
     feed-action new-action
-        dup '[ , feed>> call <feed-content> ] >>display ;
+        dup '[
+            feed new
+                ,
+                [ title>> call >>title ]
+                [ url>> call adjust-url relative-to-request >>url ]
+                [ entries>> call process-entries >>entries ]
+                tri
+            <feed-content>
+        ] >>display ;
diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor
index 4ecb7fc965..81a0bf9e1a 100755
--- a/extra/rss/rss-tests.factor
+++ b/extra/rss/rss-tests.factor
@@ -2,6 +2,9 @@ USING: rss io kernel io.files tools.test io.encodings.utf8
 calendar urls ;
 IN: rss.tests
 
+\ download-feed must-infer
+\ feed>xml must-infer
+
 : load-news-file ( filename -- feed )
     #! Load an news syndication file and process it, returning
     #! it as an feed tuple.
diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor
index 4aa92abc67..7696a7c220 100644
--- a/extra/rss/rss.factor
+++ b/extra/rss/rss.factor
@@ -14,7 +14,7 @@ TUPLE: feed title url entries ;
 
 : <feed> ( -- feed ) feed new ;
 
-TUPLE: entry title url description pub-date ;
+TUPLE: entry title url description date ;
 
 : set-entries ( feed entries -- feed )
     [ dup url>> ] dip
@@ -35,7 +35,7 @@ TUPLE: entry title url description pub-date ;
         [
             f "date" "http://purl.org/dc/elements/1.1/" <name>
             tag-named dup [ children>string try-parsing-timestamp ] when
-            >>pub-date
+            >>date
         ]
     } cleave ;
 
@@ -55,7 +55,7 @@ TUPLE: entry title url description pub-date ;
         [ "description" tag-named children>string >>description ]
         [
             { "date" "pubDate" } any-tag-named
-            children>string try-parsing-timestamp >>pub-date
+            children>string try-parsing-timestamp >>date
         ]
     } cleave ;
 
@@ -64,7 +64,7 @@ TUPLE: entry title url description pub-date ;
     swap
     "channel" tag-named 
     [ "title" tag-named children>string >>title ]
-    [ "link" tag-named children>string >>link ]
+    [ "link" tag-named children>string >url >>url ]
     [ "item" tags-named [ rss2.0-entry ] map set-entries ]
     tri ;
 
@@ -82,7 +82,7 @@ TUPLE: entry title url description pub-date ;
         [
             { "published" "updated" "issued" "modified" } 
             any-tag-named children>string try-parsing-timestamp
-            >>pub-date
+            >>date
         ]
     } cleave ;
 
@@ -120,7 +120,7 @@ TUPLE: entry title url description pub-date ;
         {
             [ title>> "title" { { "type" "html" } } simple-tag*, ]
             [ url>> present "href" associate "link" swap contained*, ]
-            [ pub-date>> timestamp>rfc3339 "published" simple-tag, ]
+            [ date>> timestamp>rfc3339 "published" simple-tag, ]
             [ description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ]
         } cleave
     ] tag, ;