1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
;;; Haunt --- Static site generator for GNU Guile
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;; Copyright © 2018 Christopher Lemmer Webber <cwebber@dustycloud.org>
;;;
;;; This file is part of Haunt.
;;;
;;; Haunt is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Haunt is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Haunt. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; RSS feed builder.
;;
;;; Code:
(define-module (haunt builder rss)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (sxml simple)
#:use-module (haunt artifact)
#:use-module (haunt site)
#:use-module (haunt post)
#:use-module (haunt utils)
#:use-module (haunt html)
#:use-module (haunt serve mime-types)
#:use-module (haunt builder atom)
#:use-module (haunt builder blog)
#:use-module (web uri)
#:export (rss-feed))
;; Reader beware: this isn't as nice as atom.scm, because rss isn't
;; as nice as atom. Worse beats better on the play field again...
;; RFC 822 dates are inferior to ISO 8601, but it's
;; what RSS wants, so...
(define (date->rfc822-str date)
(date->string date "~a, ~d ~b ~Y ~T ~z"))
(define (sxml->xml* sxml port)
"Write SXML to PORT, preceded by an <?xml> tag."
(display "<?xml version=\"1.0\" encoding=\"utf-8\"?>" port)
(sxml->xml sxml port))
(define* (post->rss-item site slug->file-name post)
"Convert POST into an RSS <item> node."
(let ((uri (uri->string
(build-uri (site-scheme site)
#:host (site-domain site)
#:path (string-append "/"
(slug->file-name
(site-post-slug site post)))))))
`(item
(title ,(post-ref post 'title))
;; Looks like: <author>lawyer@boyer.net (Lawyer Boyer)</author>
,@(let ((email (post-ref post 'email))
(author (post-ref post 'author)))
(cond ((and email author)
`((author ,(string-append email " (" author ")"))))
(email
`((author ,email)))
(else '())))
(pubDate ,(date->rfc822-str (post-date post)))
(guid ,uri)
(link ,uri)
(description ,(sxml->html-string (post-sxml post)))
,@(map (lambda (enclosure)
`(enclosure (@ (title ,(enclosure-title enclosure))
(url ,(enclosure-url enclosure))
(type ,(enclosure-mime-type enclosure))
,@(map (match-lambda
((key . value)
(list key value)))
(enclosure-extra enclosure)))))
(post-ref-all post 'enclosure)))))
(define* (rss-feed #:key
(file-name "rss-feed.xml")
(subtitle "Recent Posts")
(filter posts/reverse-chronological)
(max-entries 20)
(blog-prefix "")
(slug->file-name slug->file-name/default))
"Return a builder procedure that renders a list of posts as an RSS
feed. All arguments are optional:
FILE-NAME: The page file name
SUBTITLE: The feed subtitle
FILTER: The procedure called to manipulate the posts list before rendering
MAX-ENTRIES: The maximum number of posts to render in the feed"
;; Preserve compatibility with older versions, for now.
(define slug->file-name*
(if (string=? blog-prefix "")
slug->file-name
(begin
(display "warning: #:blog-prefix keyword of 'rss-feed' procedure is deprecated, switch to #:slug->file-name\n")
(make-compat-slug->file-name blog-prefix))))
(lambda (site posts)
(serialized-artifact file-name
`(rss (@ (version "2.0")
(xmlns:atom "http://www.w3.org/2005/Atom"))
(channel
(title ,(site-title site))
;; It looks like RSS's description and atom's subtitle
;; are equivalent?
(description ,subtitle)
(pubDate ,(date->rfc822-str (current-date)))
(link
,(string-append (symbol->string
(site-scheme site))
"://" (site-domain site) "/"))
(atom:link
(@ (href ,(string-append (symbol->string
(site-scheme site))
"://" (site-domain site)
"/" file-name))
(rel "self")
(type "application/rss+xml")))
,@(map (cut post->rss-item site slug->file-name* <>)
(take-up-to max-entries
(filter posts)))))
sxml->xml*)))
|
