source: project/release/4/rss/trunk/rss.scm @ 23851

Last change on this file since 23851 was 23851, checked in by felix winkelmann, 9 years ago

applied patch for rss:enclosure(s) by ckeen

File size: 6.2 KB
Line 
1 ;;; rss.scm
2
3(module rss
4(rss:item? rss:item-title rss:item-link rss:item-description
5 rss:item-attributes rss:item-attribute
6 rss:feed? rss:feed-version rss:feed-channel rss:feed-items
7 rss:item-enclosures rss:enclosure-type rss:enclosure-length
8 rss:enclosure? rss:enclosure-url  rss:item=? rss:read)
9
10(import scheme chicken extras)
11(require-extension srfi-1 matchable ssax)
12
13(define namespace-prefixes
14  '((rdf . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
15    (dc . "http://purl.org/dc/elements/1.1/")
16    (sy . "http://purl.org/rss/1.0/modules/syndication/")
17    (admin . "http://webns.net/mvcb/")
18    (rss . "http://purl.org/rss/1.0/") 
19    (rdf . "http://my.netscape.com/rdf/simple/0.9/") 
20    (itunes . "http://www.itunes.com/dtds/podcast-1.0.dtd")
21    (content . "http://purl.org/rss/1.0/modules/content/")
22    (atom . "http://www.w3.org/2005/Atom") ) )
23
24(define-record-type rss:item
25  (make-rss:item title link description enclosures attributes)
26  rss:item?
27  (title rss:item-title rss:item-title-set!)
28  (link rss:item-link rss:item-link-set!)
29  (description rss:item-description rss:item-description-set!)
30  (enclosures rss:item-enclosures rss:item-enclosures-set!)
31  (attributes rss:item-attributes rss:item-attributes-set!)
32  )
33
34(define-record-type rss:feed
35  (make-rss:feed version channel items)
36  rss:feed?
37  (version rss:feed-version rss:feed-version-set!)
38  (channel rss:feed-channel rss:feed-channel-set!)
39  (items rss:feed-items rss:feed-items-set!)
40  )
41
42(define-record-type rss:enclosure
43   (make-rss:enclosure type url length)
44   rss:enclosure?
45   (type rss:enclosure-type rss:enclosure-type-set!)
46   (url rss:enclosure-url rss:enclosure-url-set!)
47   (length rss:enclosure-length rss:enclosure-length-set!)
48)
49
50(define (sxml->enclosure sxml)
51   (let ((enc (make-rss:enclosure #f #f #f)))
52      (letrec ((parse
53         (match-lambda 
54           ['() enc] 
55           [('@ rest ...) (parse rest)]
56           [(('url url) rest ...) (rss:enclosure-url-set! enc url) (parse rest)]
57           [(('length len) rest ...) (rss:enclosure-length-set! enc len) (parse rest)]
58           [(('type type) rest ...) (rss:enclosure-type-set! enc type)(parse rest)] 
59           [ x (warn "uncatched pattern ~S" x)]
60         )))
61      (parse sxml))))
62
63(define (rss:item-attribute item attr)
64  (let ([attrs (rss:item-attributes item)])
65    (and-let* ([a (assq attr attrs)])
66      (cdr a) ) ) )
67
68(define (rss:item=? i1 i2)
69  (or (and-let* ([g1 (rss:item-attribute i1 'guid)]
70                 [g2 (rss:item-attribute i2 'guid)] )
71        (string=? g1 g2) )
72      (equal? i1 i2) ) )
73
74(define feed #f)
75
76(define (rss:read . port)
77  (let ([sxml (ssax:xml->sxml (if (pair? port) (car port) (current-input-port))
78                              namespace-prefixes)])
79    ;;(pp sxml (current-error-port))
80    (fluid-let ([feed (make-rss:feed #f #f '())])
81      (traverse sxml) 
82      (rss:feed-items-set! feed (reverse (rss:feed-items feed)))
83      feed) ) )
84
85(define cleanup
86  (match-lambda
87    [('*TOP* items ...)
88     (let loop ([items items])
89       (match (car items)
90         [('@ . _) (loop (cdr items))]
91         [('@@ . _) (loop (cdr items))]
92         [('*PI* . _) (loop (cdr items))]
93         [('*NAMESPACES* . _) (loop (cdr items))]
94         [x x] ) ) ]
95    [x x] ) )
96
97(define (rss:error msg . args)
98  (signal
99   (make-composite-condition
100    (make-property-condition 'rss)
101    (make-property-condition 'exn 'message msg 'arguments args) ) ) )
102
103(define (traverse sxml)
104  (match (cleanup sxml)
105    [('rss ('@ attrs ...) data ...)
106     (check-version attrs) 
107     (for-each (cut traverse-element <> #f) data) ]
108    [('rdf:RDF data ...)
109     (rss:feed-version-set! feed "1.0")
110     (for-each (cut traverse-element <> #t) data) ]
111    [_ (rss:error "invalid root element" sxml)] ) )
112
113(define (check-version attrs)
114  (for-each
115   (match-lambda
116     [('version v)
117      (rss:feed-version-set! feed v) ] )
118   attrs) )
119
120(define last-channel #f)
121(define channel #f)
122(define item #f)
123
124(define (warn fstr . args)
125  (printf "Warning: ~?~%" fstr args) )
126
127(define (traverse-element sxml rdf)
128  (let rec ([sxml sxml])
129    (match sxml
130      [((or 'channel 'rss:channel 'rdf:channel) elts ...)
131       (fluid-let ([channel (make-rss:item #f #f #f '() '())])
132         (set! last-channel channel)
133         (rss:feed-channel-set! feed channel)
134         (for-each rec elts) ) ]
135      [((or 'item 'rss:item 'rdf:item) elts ...)
136       (fluid-let ([item (make-rss:item #f #f #f '() '())])
137         (rss:feed-items-set! feed (cons item (rss:feed-items feed)))
138         (for-each rec elts) ) ]
139      [((or 'title 'rss:title 'rdf:title) title)
140       (let ([d (or item channel last-channel)])
141         (if d
142             (begin
143               (rss:item-title-set! d title)
144               (rss:item-attributes-set! d (alist-cons 'title title (rss:item-attributes d))) )
145             (warn "tag `title' with content ~S in wrong context" title) ) ) ]
146      [((or 'link 'rss:link 'rdf:link) link)
147       (let ([d (or item channel last-channel)])
148         (if d
149             (begin
150               (rss:item-link-set! d link)
151               (rss:item-attributes-set! d (alist-cons 'link link (rss:item-attributes d))) )
152             (warn "tag `link' with content ~S in wrong context" link) ) ) ]
153      [((or 'enclosure 'rss:enclosure 'rdf:enclosure) enclosure)
154       (let ([d (or item channel last-channel)])
155         (if d
156            (begin
157               (rss:item-enclosures-set! d (cons (sxml->enclosure enclosure) (rss:item-enclosures d)))
158               (rss:item-attributes-set! d (alist-cons 'enclosure enclosure (rss:item-attributes d))))
159            (warn "tag `enclosure' with content ~S in wrong context" enclosure)) ) ]
160      [((or 'description 'rss:description 'rdf:description) description)
161       (let ([d (or item channel last-channel)])
162         (if d
163             (begin
164               (rss:item-description-set! d description)
165               (rss:item-attributes-set! d (alist-cons 'description description (rss:item-attributes d))) )
166             (warn "tag `description' with content ~S in wrong context" description) ) ) ]
167      [(tag ('@ . _) . more)
168       (rec (cons tag more)) ]
169      [(tag . more)
170       (let ([d (or item channel last-channel)])
171         (if d
172             (rss:item-attributes-set! 
173              d 
174              (alist-cons 
175               tag
176               (cond [(null? more) #t]
177                     [(null? (cdr more)) (car more)]
178                     [else more] )
179               (rss:item-attributes d) ) )
180             (warn "tag `~A' with content ~S in wrong context" tag more) )
181         (for-each rec more) ) ]
182      [_ #f] ) ) )
183
184)
Note: See TracBrowser for help on using the repository browser.