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

atom: Add 'id' attribute to feed and entries.

This commit is contained in:
David Thompson 2019-06-28 08:28:40 -04:00
parent 794125e408
commit d92411f7c1
1 changed files with 46 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
haunt/builder/atom.scm
View File

@ -35,6 +35,7 @@
#:use-module (haunt utils) #:use-module (haunt utils)
#:use-module (haunt html) #:use-module (haunt html)
#:use-module (haunt serve mime-types) #:use-module (haunt serve mime-types)
#:use-module (web uri)
#:export (make-enclosure #:export (make-enclosure
enclosure? enclosure?
enclosure-title enclosure-title
@ -137,28 +138,33 @@
(define* (post->atom-entry site post #:key (blog-prefix "")) (define* (post->atom-entry site post #:key (blog-prefix ""))
"Convert POST into an Atom <entry> XML node." "Convert POST into an Atom <entry> XML node."
`(entry (let ((uri (uri->string
(title ,(post-ref post 'title)) (build-uri (site-scheme site)
(author #:host (site-domain site)
(name ,(post-ref post 'author)) #:path (string-append blog-prefix "/"
,(let ((email (post-ref post 'email))) (site-post-slug site post)
(if email `(email ,email) '()))) ".html")))))
(updated ,(date->string* (post-date post))) `(entry
(link (@ (href ,(string-append blog-prefix "/" (title ,(post-ref post 'title))
(site-post-slug site post) ".html")) (id ,uri)
(rel "alternate"))) (author
(summary (@ (type "html")) (name ,(post-ref post 'author))
,(sxml->html-string (post-sxml post))) ,(let ((email (post-ref post 'email)))
,@(map (lambda (enclosure) (if email `(email ,email) '())))
`(link (@ (rel "enclosure") (updated ,(date->string* (post-date post)))
(title ,(enclosure-title enclosure)) (link (@ (href ,uri) (rel "alternate")))
(href ,(enclosure-url enclosure)) (summary (@ (type "html"))
(type ,(enclosure-mime-type enclosure)) ,(sxml->html-string (post-sxml post)))
,@(map (match-lambda ,@(map (lambda (enclosure)
((key . value) `(link (@ (rel "enclosure")
(list key value))) (title ,(enclosure-title enclosure))
(enclosure-extra enclosure))))) (href ,(enclosure-url enclosure))
(post-ref-all post '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 (define* (atom-feed #:key
(file-name "feed.xml") (file-name "feed.xml")
@ -174,19 +180,24 @@ SUBTITLE: The feed subtitle
FILTER: The procedure called to manipulate the posts list before rendering FILTER: The procedure called to manipulate the posts list before rendering
MAX-ENTRIES: The maximum number of posts to render in the feed" MAX-ENTRIES: The maximum number of posts to render in the feed"
(lambda (site posts) (lambda (site posts)
(make-page file-name (let ((uri (uri->string
`(feed (@ (xmlns "http://www.w3.org/2005/Atom")) (build-uri (site-scheme site)
(title ,(site-title site)) #:host (site-domain site)
(subtitle ,subtitle) #:path (string-append "/" file-name)))))
(updated ,(date->string* (current-date))) (make-page file-name
(link (@ (href ,(string-append (site-domain site) `(feed (@ (xmlns "http://www.w3.org/2005/Atom"))
"/" file-name)) (title ,(site-title site))
(rel "self"))) (id ,uri)
(link (@ (href ,(site-domain site)))) (subtitle ,subtitle)
,@(map (cut post->atom-entry site <> (updated ,(date->string* (current-date)))
#:blog-prefix blog-prefix) (link (@ (href ,(string-append (site-domain site)
(take-up-to max-entries (filter posts)))) "/" file-name))
sxml->xml*))) (rel "self")))
(link (@ (href ,(site-domain site))))
,@(map (cut post->atom-entry site <>
#:blog-prefix blog-prefix)
(take-up-to max-entries (filter posts))))
sxml->xml*))))
(define* (atom-feeds-by-tag #:key (define* (atom-feeds-by-tag #:key
(prefix "feeds/tags") (prefix "feeds/tags")