From 15c4605e1dede94e00c78cc247f6a4e71a0d258b Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sun, 18 Nov 2018 20:47:47 -0500
Subject: atom: Add support for enclosures.

The most notable use-case here is allowing Haunt to be used for
podcasting.  Thanks to Christopher Lemmer Webber for wanting to use
Haunt to build their podcast Atom feed!

* haunt/builder/atom.scm (<enclosure>): New record type.
(make-enclosure, enclosure?, enclosure-title, enclosure-url,
enclosure-extra, enclosure-mime-type, parse-enclosure): New
procedures.
(post->atom-entry): Render enclosures.
---
 haunt/builder/atom.scm | 104 ++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 102 insertions(+), 2 deletions(-)

diff --git a/haunt/builder/atom.scm b/haunt/builder/atom.scm
index 39c331a..5ffb6d0 100644
--- a/haunt/builder/atom.scm
+++ b/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")
-- 
cgit v1.2.3