Permalink
Browse files

code changes to simplify the RSS feed interface incl. contracts added…

…; keyword arguments and removal of need to enter redundant info; moved atom-inc and rss-inc into page.scm due to a circular dependency where feed.ss needs to call page-url (from page.scm)
  • Loading branch information...
1 parent 372b34e commit 6d520540d7d26d2b7740c7fa94f56465d5920b52 @vegashacker committed Nov 25, 2008
Showing with 70 additions and 80 deletions.
  1. +9 −0 contract-lp.ss
  2. +49 −68 feed.ss
  3. +3 −7 leftparen.scm
  4. +8 −3 page.scm
  5. +1 −2 web-support.scm
View
@@ -0,0 +1,9 @@
+#lang scheme/base
+
+;; a one-stop require that handles the "any" conflict with PLT contracts and SRFI 1.
+
+(require scheme/contract)
+
+(provide (combine-out (except-out (all-from-out scheme/contract) any)
+ (rename-out (any c:any))))
+
View
117 feed.ss
@@ -2,28 +2,26 @@
(require "time.scm"
"util.scm"
+ "contract-lp.ss"
"web-support.scm"
+ "settings.scm"
+ "page.scm"
(planet "uuid-v4.ss" ("zitterbewegung" "uuid-v4.plt" 1 0)))
(provide atom-item
- atom-inc
- atom-wrapper
+ atom-feed
- rss-inc
- rss-wrapper
- rss-item
- rss-li)
+ rss-feed
+ ;; rss-item (via contract)
+ )
-(define (atom-inc feed-url)
- `(link ((rel "alternate") (type "application/atom+xml") (href ,feed-url))))
-
-(define (atom-wrapper feed-title
- feed-subtitle
- feed-url
- url
- author-name
- author-email
- . body)
+(define (atom-feed feed-title
+ feed-subtitle
+ feed-url
+ url
+ author-name
+ author-email
+ . body)
(list-response #:type #"text/xml"
(list (raw-str "<?xml version=\"1.0\" encoding=\"utf-8\"?>")
`(feed ((xmlns "http://www.w3.org/2005/Atom"))
@@ -44,73 +42,56 @@
(updated ,(atom-time-str (current-seconds)))
(summary ,item-summary)
(content ,item-content)))
+
;;
;; rss-inc
;;
-;; Function to include the browser feed autodiscovery link in your page.
+;; Function to include the browser feed auto-discovery link in your page.
;;
(define (rss-inc feed-url)
`(link ((href ,feed-url) (rel "alternate") (type "application/rss+xml")
(title "Sitewide RSS Feed"))))
;;
-;; rss-wrapper
+;; rss-feed
;;
-;; Main wrapper function to create an RSS 1.0 feed.
+;; Generate an RSS 1.0 feed.
;;
-(define (rss-wrapper about
- channel-title
- channel-link
- channel-description
- channel-image
- item-list
- . body)
+;(provide/contract
+; (rss-feed ))
+;;
+(define (rss-feed rss-feed-page
+ #:feed-title feed-title
+ #:feed-description feed-description
+ #:original-content-link (original-content-link (setting *WEB_APP_URL*))
+ #:items (rss-items '()))
(list-response #:type #"text/xml"
- (list (raw-str "<?xml version=\"1.0\"?>")
+ (list (raw-str "<?xml version=\"1.0\" encoding=\"utf-8\"?>")
`(rdf:RDF
((xmlns "http://purl.org/rss/1.0/")
(xmlns:rdf "http://www.w3.org/1999/02/22-rdf-syntax-ns#"))
- (channel
- ((rdf:about ,about))
- (title ,channel-title)
- (link ,channel-link)
- (description
- ,channel-description)
- (image ((rdf:resource ,channel-image)))
- (items
- (rdf:Seq
- ,@item-list)))
- ,@body))))
+ (channel ((rdf:about ,(page-url rss-feed-page)))
+ (title ,feed-title)
+ (link ,original-content-link)
+ (description ,feed-description)
+ (items (rdf:Seq ,@(map rss-li rss-items))))
+ ,@(map markup-rss-item rss-items)))))
-;;
-;; rss-li
-;;
-;; RSS list element creator.
-;;
-(define (rss-li resource-link)
- `(rdf:li ((resource ,resource-link))))
+(define (rss-li rss-item)
+ `(rdf:li ((resource ,(rss-item-url rss-item)))))
-;;
-;; rss-item
-;;
-;; Creation of RSS items.
-;;
-(define (rss-item rdf-about item-title item-link item-description)
- `(item
- ((rdf:about ,rdf-about))
- (title () ,item-title)
- (link () ,item-link)
- (description () ,item-description)))
+(define-struct rss-item (title url description))
-;;
-;; rss-textinput
-;;
-;; Creation of RSS textinput items.
-;;
-(define (rss-textinput about text-title text-description text-name text-link)
- `(textinput
- ((rdf:about ,about))
- (title () ,text-title)
- (description () ,text-description)
- (name () , text-name)
- (link () ,text-link)))
+(provide/contract
+ (rename construct-rss-item rss-item (->* (#:title string? #:url string?)
+ (#:description (or/c #f string?))
+ rss-item?)))
+(define (construct-rss-item #:title title #:url url #:description (desc #f))
+ (make-rss-item title url desc))
+
+(define (markup-rss-item rss-item)
+ (let ((url (rss-item-url rss-item)))
+ `(item ((rdf:about ,url))
+ (title ,(rss-item-title rss-item))
+ (link ,url)
+ ,@(splice-if (aand (rss-item-description rss-item) `(description ,it))))))
View
@@ -56,14 +56,11 @@
form-markup
grab-user-input
- ;;Feeds
+ ;; feeds
+ atom-feed
atom-item
- atom-inc
- atom-wrapper
- rss-inc
- rss-wrapper
+ rss-feed
rss-item
- rss-li
;; records and the data repository
rec-prop
@@ -145,7 +142,6 @@
**
page-url
redirect-to-page
- atom-wrapper
js-inc
css-inc
versioned-file-reference
View
@@ -7,8 +7,7 @@
"web-support.scm"
"session.scm"
"settings.scm"
- "time.scm"
- "feed.ss")
+ "time.scm")
(provide define-page
define-session-page
@@ -17,7 +16,6 @@
**
page-url
redirect-to-page
- atom-wrapper
js-inc
css-inc
versioned-file-reference
@@ -148,6 +146,13 @@
(define (css-inc css-filename)
`(link ((rel "stylesheet") (type "text/css") (href ,css-filename))))
+(define (atom-inc feed-url)
+ `(link ((rel "alternate") (type "application/atom+xml") (href ,feed-url))))
+
+(define (rss-inc feed-url #:title (title "RSS feed"))
+ `(link ((href ,feed-url) (rel "alternate") (type "application/rss+xml")
+ (title ,title))))
+
;; filename should be relative to htdocs directory
;; XXX I'm not sure this will actually work (does the # trigger a new file refresh?)
;; XXX INDEED IT DOES NOT. We'll have to change the actual filename and then
View
@@ -4,8 +4,7 @@
(lib "xml.ss" "xml")
net/url
scheme/serialize
- (rename-in scheme/contract
- (any c:any))
+ "contract-lp.ss"
(planet "web.scm" ("soegaard" "web.plt" 2 1))
)

0 comments on commit 6d52054

Please sign in to comment.