source: project/release/4/hyde/trunk/hyde-atom.scm @ 27156

Last change on this file since 27156 was 27156, checked in by Moritz Heidkamp, 9 years ago

hyde-atom: Add a link with relation alternate to the atom feed emitted by pages->atom-doc

File size: 4.9 KB
Line 
1(module hyde-atom (translate/atom)
2
3(import chicken scheme)
4(use hyde atom rfc3339 posix extras srfi-1 environments)
5
6(define $ (environment-ref (page-eval-env) '$))
7(define page-path (environment-ref (page-eval-env) 'page-path))
8(define read-page (environment-ref (page-eval-env) 'read-page))
9
10(define (maybe-authors->atom-authors authors)
11  (if authors
12      (map (lambda (author)
13             (make-author name: author))
14           authors)
15      '()))
16
17(define (pages->atom-doc pages #!key
18                         (page-title (lambda (page) ($ 'title page))) 
19                         (page-date (lambda (page)
20                                      (or ($ 'updated page) ($ 'date page))))
21                         (page-type (lambda (page)
22                                      ($ 'type page)))
23                         (page-authors (lambda (page)
24                                         ($ 'authors page)))
25                         (page-date->rfc3339-string (lambda (x) x))
26                         (page->atom-content (lambda (page)
27                                               (make-content (read-page page) type: 'html))))
28  (let* ((rfc3339-string->seconds 
29          (lambda (date)
30            (rfc3339->seconds (string->rfc3339 date))))
31         (page-date->seconds
32          (lambda (date)
33            (rfc3339-string->seconds (page-date->rfc3339-string date))))
34         (rfc3339-string->YYYY-MM-DD 
35          (lambda (date)
36            (time->string (seconds->utc-time (rfc3339-string->seconds date)) 
37                          "%Y-%m-%d")))
38         (page-date->YYYY-MM-DD
39          (lambda (date)
40            (rfc3339-string->YYYY-MM-DD (page-date->rfc3339-string date))))
41         (feed-authors (maybe-authors->atom-authors ($ 'authors))))
42    (make-atom-doc
43     (make-feed
44      title: (make-title ($ 'title))
45      subtitle: (make-subtitle ($ 'subtitle))
46      icon: (and ($ 'icon) (make-icon (string-append ($ 'base-uri) ($ 'icon))))
47      logo: (and ($ 'logo) (make-logo (string-append ($ 'base-uri) ($ 'logo))))
48      authors: feed-authors
49      updated: (rfc3339->string
50                (seconds->rfc3339
51                 (fold (lambda (p c)
52                         (let ((p (page-date->seconds (page-date p))))
53                           (if (and c (> c p)) c p)))
54                       #f
55                       pages)))
56      id: (format ($ 'tag) ($ 'date) "/")
57      links: (list (make-link uri: (string-append ($ 'base-uri) (or ($ 'root-path) "/"))
58                              relation: "alternate"
59                              type: 'html)
60                   (make-link uri: (string-append ($ 'base-uri) (page-path))
61                              relation: "self"
62                              type: 'atom))
63      entries: (map (lambda (p)
64                      (make-entry title: (make-title (page-title p))
65                                  published: (page-date->rfc3339-string (page-date p))
66                                  updated: (page-date->rfc3339-string (page-date p))
67                                  id: (format ($ 'tag) 
68                                              (page-date->YYYY-MM-DD (page-date p))
69                                              (page-path p))
70                                  links: (list (make-link uri: (string-append ($ 'base-uri) (page-path p)) 
71                                                          type: (or (page-type p) ($ 'entries-type))))
72                                  authors: (let ((authors (maybe-authors->atom-authors (page-authors p))))
73                                             ;; we include the feed authors for every entry in case there are
74                                             ;; none for this entry specifically since feed readers tend to ignore
75                                             ;; feed-wide authors
76                                             (if (null? authors) feed-authors authors))
77                                  content: (page->atom-content p)))
78                    pages)))))
79
80(define (translate/atom)
81  (let ((env (page-eval-env)))
82    (for-each (lambda (binding)
83                (apply environment-extend! (cons env binding)))
84              `((make-atom-doc ,make-atom-doc) (make-author ,make-author) (make-category ,make-category)
85                (make-content ,make-content) (make-contributor ,make-contributor) (make-entry ,make-entry)
86                (make-feed ,make-feed) (make-generator ,make-generator) (make-icon ,make-icon)
87                (make-link ,make-link) (make-logo ,make-logo) (make-rights ,make-rights)
88                (make-source ,make-source) (make-subtitle ,make-subtitle) (make-summary ,make-summary)
89                (make-title ,make-title) (make-rfc3339 ,make-rfc3339) (rfc3339->string ,rfc3339->string)
90                (seconds->rfc3339 ,seconds->rfc3339) (utc-time->rfc3339 ,utc-time->rfc3339)
91                (time->rfc3339 ,time->rfc3339) (pages->atom-doc ,pages->atom-doc)))
92
93    (write-atom-doc (eval (read) env))))
94
95(translators (cons (list "atom" translate/atom '(ext . atom) '(layouts))
96                   (translators)))
97
98)
Note: See TracBrowser for help on using the repository browser.