dan
/
haunt
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
David Thompson 2018-11-18 20:47:47 -05:00
parent 51e2f10645
commit 15c4605e1d
1 changed files with 102 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
haunt/builder/atom.scm
View File

@ -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")