git: Ignore tarball signature files.

* haunt/builder/rss.scm: New file with support for RSS feeds.
* Makefile.am: Add it.

.gitignore

@@ -13,6 +13,7 @@ Makefile.in
 /example/site/
 /scripts/haunt
 *.tar.gz
+*.tar.gz.asc
 /website/site
 /test-env
 *.log

Makefile.am

@@ -54,6 +54,7 @@ SOURCES =					\
   haunt/builder/assets.scm			\
   haunt/builder/atom.scm			\
   haunt/builder/blog.scm			\
+  haunt/builder/rss.scm				\
   haunt/reader.scm				\
   haunt/reader/texinfo.scm			\
   haunt/ui.scm					\

README

@@ -5,7 +5,7 @@ simple, functional, and extensible.
 
 * Features
 
-  - Easy blog and Atom feed generation
+  - Easy blog and Atom/RSS feed generation
   - Supports any markup language that can be parsed to SXML
   - Simple development server
   - Purely functional build process

THANKS

@@ -1,3 +1,5 @@
 Ben Sturmfels <ben@sturm.com.au>
 Vladimir Zhbanov <vzhbanov@gmail.com>
 Urbain Vaes <urbain@vaes.uk>
+Alex Kost <alezost@gmail.com>
+Jorge Maldonado Ventura <jorgesumle@freakspot.net>

configure.ac

@@ -1,6 +1,6 @@
 dnl -*- Autoconf -*-
 
-AC_INIT(Haunt, 0.2.2)
+AC_INIT(Haunt, 0.2.3)
 AC_CONFIG_SRCDIR(haunt)
 AC_CONFIG_AUX_DIR([build-aux])
 AM_INIT_AUTOMAKE([color-tests -Wall -Wno-portability foreign])

doc/haunt.texi

@@ -144,9 +144,9 @@ Happy haunting!
 @node Downloading
 @section Downloading
 
-Official Haunt source code release tarballs can be found on the
-@url{http://haunt.dthompson.us/downloads.html, downloads page} of
-Haunt's website, along with their associated checksums.
+Official Haunt source code release tarballs can be found under Releases
+in @url{https://dthompson.us/projects/haunt.html, Haunt's website},
+along with their associated checksums.
 
 @node Requirements
 @section Requirements

haunt/builder/atom.scm

@@ -24,6 +24,7 @@
 ;;; Code:
 
 (define-module (haunt builder atom)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
@@ -33,9 +34,98 @@
   #:use-module (haunt page)
   #:use-module (haunt utils)
   #:use-module (haunt html)
-  #:export (atom-feed
+  #:use-module (haunt serve mime-types)
+  #:export (make-enclosure
+            enclosure?
+            enclosure-title
+            enclosure-url
+            enclosure-extra
+            enclosure-mime-type
+
+            atom-feed
             atom-feeds-by-tag))
 
+(define-record-type <enclosure>
+  (make-enclosure title url extra)
+  enclosure?
+  (title enclosure-title)
+  (url enclosure-url)
+  (extra enclosure-extra))
+
+(define (enclosure-mime-type enclosure)
+  (mime-type (enclosure-url enclosure)))
+
+(define char-set:enclosure-key
+  (char-set-union char-set:letter+digit
+                  (char-set-delete char-set:punctuation #\: #\")
+                  (char-set-delete char-set:symbol #\=)))
+
+(define (parse-enclosure s)
+  (call-with-input-string s
+    (lambda (port)
+      (define (assert-char char)
+        (let ((c (read-char port)))
+          (unless (eqv? c char)
+            (error "enclosure: parse: expected" char "got" c))))
+      (define (whitespace? char)
+        (char-set-contains? char-set:whitespace char))
+      (define (consume-whitespace)
+        (match (peek-char port)
+          ((? eof-object?) *unspecified*)
+          ((? whitespace?)
+           (read-char port)
+           (consume-whitespace))
+          (_ *unspecified*)))
+      (define (read-escape-character)
+        (match (read-char port)
+          (#\" #\")
+          (#\\ #\\)
+          (char (error "enclosure: parse: invalid escape character:" char))))
+      (define (read-unquoted-string)
+        (list->string
+         (let loop ()
+           (let ((c (peek-char port)))
+             (cond
+              ((eof-object? c)
+               '())
+              ((char-set-contains? char-set:enclosure-key c)
+               (read-char port)
+               (cons c (loop)))
+              (else
+               '()))))))
+      (define (read-string)
+        (if (eqv? (peek-char port) #\")
+            (begin
+              (assert-char #\")
+              (list->string
+               (let loop ()
+                 (match (read-char port)
+                   ((? eof-object?)
+                    (error "enclosure: parse: EOF while reading string"))
+                   (#\" '())
+                   (#\\ (cons (read-escape-character) (loop)))
+                   (char (cons char (loop)))))))
+            (read-unquoted-string)))
+      (define (read-key)
+        (string->symbol (read-unquoted-string)))
+      (let loop ((attrs '()))
+        (consume-whitespace)
+        (if (eof-object? (peek-char port))
+            (make-enclosure (assq-ref attrs 'title)
+                            (assq-ref attrs 'url)
+                            (let loop ((attrs attrs))
+                              (match attrs
+                                (() '())
+                                ((((or 'title 'url) . _) . rest)
+                                 (loop rest))
+                                ((attr . rest)
+                                 (cons attr (loop rest))))))
+            (let ((key (read-key)))
+              (assert-char #\:)
+              (loop (cons (cons key (read-string)) attrs))))))))
+
+(register-metadata-parser! 'enclosure parse-enclosure)
+
 (define (sxml->xml* sxml port)
   "Write SXML to PORT, preceded by an <?xml> tag."
   (display "<?xml version=\"1.0\" encoding=\"utf-8\"?>" port)
@@ -58,7 +148,17 @@
                                    (site-post-slug site post) ".html"))
              (rel "alternate")))
     (summary (@ (type "html"))
-             ,(sxml->html-string (post-sxml post)))))
+             ,(sxml->html-string (post-sxml post)))
+    ,@(map (lambda (enclosure)
+             `(link (@ (rel "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* (atom-feed #:key
                     (file-name "feed.xml")

haunt/builder/rss.scm

@@ -0,0 +1,107 @@
+;;; Haunt --- Static site generator for GNU Guile
+;;; 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 site)
+  #:use-module (haunt post)
+  #:use-module (haunt page)
+  #:use-module (haunt utils)
+  #:use-module (haunt html)
+  #:use-module (haunt serve mime-types)
+  #:use-module (haunt builder atom)
+  #: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 post #:key (blog-prefix ""))
+  "Convert POST into an RSS <item> node."
+  `(item
+    (title ,(post-ref post 'title))
+    ;; Looks like: <author>lawyer@boyer.net (Lawyer Boyer)</author>
+    (author
+     ,(let ((email (post-ref post 'email))
+            (author (post-ref post 'author)))
+        (string-append (if email
+                           (string-append email " ")
+                           "")
+                       (if author
+                           (string-append "(" author ")")
+                           ""))))
+    (pubDate ,(date->rfc822-str (post-date post)))
+    (link (@ (href ,(string-append blog-prefix "/"
+                                   (site-post-slug site post) ".html"))
+             (rel "alternate")))
+    (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 ""))
+  "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"
+  (lambda (site posts)
+    (make-page file-name
+               `(rss (@ (version "2.0"))
+                     (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 (@ (href ,(site-domain site))))
+                      ,@(map (cut post->rss-item site <>
+                                  #:blog-prefix blog-prefix)
+                             (take-up-to max-entries (filter posts)))))
+               sxml->xml*)))

haunt/post.scm

@@ -36,13 +36,14 @@
             post-sxml
             post-metadata
             post-ref
+            post-ref-all
             post-slug
             %default-date
             post-date
             posts/reverse-chronological
             posts/group-by-tag
 
-            register-metdata-parser!
+            register-metadata-parser!
             parse-metadata
             read-metadata-headers))
 
@@ -57,6 +58,13 @@
   "Return the metadata corresponding to KEY within POST."
   (assq-ref (post-metadata post) key))
 
+(define (post-ref-all post key)
+  "Return a list of all metadata values for KEY within POST."
+  (filter-map (match-lambda
+                ((k . v)
+                 (and (eq? key k) v)))
+              (post-metadata post)))
+
 (define char-set:slug
   (char-set-union char-set:letter+digit (char-set #\-)))