Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
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...
commit 6d520540d7d26d2b7740c7fa94f56465d5920b52 1 parent 372b34e
@vegashacker authored
View
9 contract-lp.ss
@@ -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
10 leftparen.scm
@@ -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
11 page.scm
@@ -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
3  web-support.scm
@@ -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))
)
Please sign in to comment.
Something went wrong with that request. Please try again.