diff options
Diffstat (limited to 'haunt/jakob/builder/atom.scm')
| -rw-r--r-- | haunt/jakob/builder/atom.scm | 52 |
1 files changed, 32 insertions, 20 deletions
diff --git a/haunt/jakob/builder/atom.scm b/haunt/jakob/builder/atom.scm index 8852372..ea2cfd1 100644 --- a/haunt/jakob/builder/atom.scm +++ b/haunt/jakob/builder/atom.scm @@ -29,18 +29,35 @@ #:use-module (web uri) #:export (atom-feed)) +(define (format-date date) + "Format DATE into a date-time production as defined in RFC 3339" + (let* ((formatted (date->string date "~4")) + (up-to-tz-minute (string-drop-right formatted 2)) + (tz-minute (string-take-right formatted 2))) + (string-concatenate `(,up-to-tz-minute ":" ,tz-minute)))) + +(define (format-relative-path site path) + "Return an absolute URI for PATH" + (let ((path (if (not (string-prefix? "/" path)) + (format #f "/~a" path) + path))) + (uri->string + (build-uri 'https ;; (site-scheme site) + #:host (site-domain site) + #:path path)))) + (define* (post->atom-entry site post #:key (blog-prefix "")) "Convert POST into an Atom <entry> XML node." (let ((uri (or (post-ref post 'crosspost) (post-uri post)))) `(entry (title ,(post-ref post 'title)) - (id ,uri) + (id ,(format-relative-path site uri)) (author (name ,(post-ref post 'author)) ,(let ((email (post-ref post 'email))) (if email `(email ,email) '()))) - (updated ,(date->string (post-date post) "~4")) + (updated ,(format-date (post-date post))) (link (@ (href ,uri) (rel "alternate"))) (summary (@ (type "html")) ,(sxml->html-string @@ -72,21 +89,16 @@ add support for cross-posts. See the docstring in that manual for details on the use of this function." (lambda (site posts) - (let ((uri (uri->string - (build-uri 'http ;; (site-scheme site) - #:host (site-domain site) - #:path (string-append "/" file-name))))) - (make-page file-name - `(feed (@ (xmlns "http://www.w3.org/2005/Atom")) - (title ,(site-title site)) - (id ,uri) - (subtitle ,subtitle) - (updated ,(date->string (current-date) "~4")) - (link (@ (href ,(string-append (site-domain site) - "/" file-name)) - (rel "self"))) - (link (@ (href ,(site-domain site)))) - ,@(map (cut post->atom-entry site <> - #:blog-prefix blog-prefix) - (take-up-to max-entries (filter posts)))) - (@@ (haunt builder atom) sxml->xml*))))) + (make-page file-name + `(feed (@ (xmlns "http://www.w3.org/2005/Atom")) + (title ,(site-title site)) + (id ,(format-relative-path site file-name)) + (subtitle ,subtitle) + (updated ,(format-date (current-date))) + (link (@ (href ,(format-relative-path site file-name)) + (rel "self"))) + (link (@ (href ,(format-relative-path site "")))) + ,@(map (cut post->atom-entry site <> + #:blog-prefix blog-prefix) + (take-up-to max-entries (filter posts)))) + (@@ (haunt builder atom) sxml->xml*)))) |