#lang scheme/base
(require "time.scm"
"util.scm"
"contract-lp.ss"
"web-export.ss"
"web-support.scm"
"settings.scm"
"page.scm")
(provide ;; atom-feed (via contract)
;; atom-item (via contract)
;; rss-feed (via contract)
;; rss-item (via contract)
)
(define-struct atom-item (title url updated content))
(define-struct rss-item (title url content))
;;
;; atom-feed
;;
;; Generate an Atom 1.0 feed.
;;
(provide/contract
(atom-feed (->* (page? #:feed-title string? #:feed-updated/epoch-seconds integer?
#:author-name string?)
(#:feed-description (or/c #f string?) #:feed-id string?
#:related-content-link string? #:items (listof atom-item?))
response/full?)))
;;
(define (atom-feed atom-feed-page
#:feed-title feed-title
#:feed-updated/epoch-seconds feed-updated
#:author-name author-name
#:feed-description (feed-description #f)
#:feed-id (feed-id (page-url atom-feed-page #:absolute #t))
#:related-content-link (related-content-link (setting *WEB_APP_URL*))
#:items (atom-items '()))
(list-response #:type #"text/xml"
(list (raw-str "<?xml version=\"1.0\" encoding=\"utf-8\"?>")
`(feed ((xmlns "http://www.w3.org/2005/Atom"))
(id ,feed-id)
(title ,feed-title)
,@(splice-if feed-description `(subtitle ,feed-description))
(link ((href ,(page-url atom-feed-page #:absolute #t))
(rel "self")))
(link ((href ,related-content-link) (rel "alternate")))
(updated ,(atom-time-str feed-updated))
(author (name ,author-name))
,@(map atom-item-markup atom-items)))))
;;
;; atom-item
;;
;; A way to make atom-items (which are passed into #:items of atom-feed).
;;
(provide/contract
(rename construct-atom-item atom-item (->* (#:title string? #:url string?
#:updated-epoch-seconds integer?)
(#:content (or/c #f string?))
atom-item?)))
;;
(define (construct-atom-item #:title title #:url url #:updated-epoch-seconds updated
#:content (content #f))
(make-atom-item title url updated content))
(define (atom-item-markup atom-item)
(let ((url (atom-item-url atom-item)))
`(entry (title ,(atom-item-title atom-item))
(link ((href ,url) (rel "self")))
(id ,url)
(updated ,(atom-time-str (atom-item-updated atom-item)))
,@(splice-if (aand (atom-item-content atom-item) `(content ,it))))))
;;
;; rss-feed
;;
;; Generate an RSS 1.0 feed.
;;
(provide/contract
(rss-feed (->* (page? #:feed-title string? #:feed-description string?)
(#:related-content-link string? #:items (listof rss-item?))
response/full?)))
;;
(define (rss-feed rss-feed-page
#:feed-title feed-title
#:feed-description feed-description
#:related-content-link (related-content-link (setting *WEB_APP_URL*))
#:items (rss-items '()))
(list-response #:type #"text/xml"
(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 ,(page-url rss-feed-page #:absolute #t)))
(title ,feed-title)
(link ,related-content-link)
(description ,feed-description)
(items (rdf:Seq ,@(map rss-li rss-items))))
,@(map rss-item-markup rss-items)))))
(define (rss-li rss-item)
`(rdf:li ((resource ,(rss-item-url rss-item)))))
;;
;; rss-item
;;
;; A way to make rss-items (which are passed into #:items of rss-feed)
;;
(provide/contract
(rename construct-rss-item rss-item (->* (#:title string? #:url string?)
(#:content (or/c #f string?))
rss-item?)))
;;
(define (construct-rss-item #:title title #:url url #:content (content #f))
(make-rss-item title url content))
(define (rss-item-markup 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-content rss-item) `(description ,it))))))
) is private.
