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

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

hyde: Ensure that all required page-vars are present in atom pages

File size: 5.0 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
29  (unless (and ($ 'tag) ($ 'base-uri) ($ 'date))
30    (error "An atom page requires at least these page-vars to be defined"
31           '(tag base-uri date)))
32
33  (let* ((rfc3339-string->seconds 
34          (lambda (date)
35            (rfc3339->seconds (string->rfc3339 date))))
36         (page-date->seconds
37          (lambda (date)
38            (rfc3339-string->seconds (page-date->rfc3339-string date))))
39         (rfc3339-string->YYYY-MM-DD 
40          (lambda (date)
41            (time->string (seconds->utc-time (rfc3339-string->seconds date)) 
42                          "%Y-%m-%d")))
43         (page-date->YYYY-MM-DD
44          (lambda (date)
45            (rfc3339-string->YYYY-MM-DD (page-date->rfc3339-string date))))
46         (feed-authors (maybe-authors->atom-authors ($ 'authors))))
47    (make-atom-doc
48     (make-feed
49      title: (make-title ($ 'title))
50      subtitle: (make-subtitle ($ 'subtitle))
51      icon: (and ($ 'icon) (make-icon (string-append ($ 'base-uri) ($ 'icon))))
52      logo: (and ($ 'logo) (make-logo (string-append ($ 'base-uri) ($ 'logo))))
53      authors: feed-authors
54      updated: (rfc3339->string
55                (seconds->rfc3339
56                 (fold (lambda (p c)
57                         (let ((p (page-date->seconds (page-date p))))
58                           (if (and c (> c p)) c p)))
59                       #f
60                       pages)))
61      id: (format ($ 'tag) ($ 'date) "/")
62      links: (list (make-link uri: (string-append ($ 'base-uri) (or ($ 'root-path) "/"))
63                              relation: "alternate"
64                              type: 'html)
65                   (make-link uri: (string-append ($ 'base-uri) (page-path))
66                              relation: "self"
67                              type: 'atom))
68      entries: (map (lambda (p)
69                      (make-entry title: (make-title (page-title p))
70                                  published: (page-date->rfc3339-string (page-date p))
71                                  updated: (page-date->rfc3339-string (page-date p))
72                                  id: (format ($ 'tag) 
73                                              (page-date->YYYY-MM-DD (page-date p))
74                                              (page-path p))
75                                  links: (list (make-link uri: (string-append ($ 'base-uri) (page-path p)) 
76                                                          type: (or (page-type p) ($ 'entries-type))))
77                                  authors: (let ((authors (maybe-authors->atom-authors (page-authors p))))
78                                             ;; we include the feed authors for every entry in case there are
79                                             ;; none for this entry specifically since feed readers tend to ignore
80                                             ;; feed-wide authors
81                                             (if (null? authors) feed-authors authors))
82                                  content: (page->atom-content p)))
83                    pages)))))
84
85(define (translate/atom)
86  (let ((env (page-eval-env)))
87    (for-each (lambda (binding)
88                (apply environment-extend! (cons env binding)))
89              `((make-atom-doc ,make-atom-doc) (make-author ,make-author) (make-category ,make-category)
90                (make-content ,make-content) (make-contributor ,make-contributor) (make-entry ,make-entry)
91                (make-feed ,make-feed) (make-generator ,make-generator) (make-icon ,make-icon)
92                (make-link ,make-link) (make-logo ,make-logo) (make-rights ,make-rights)
93                (make-source ,make-source) (make-subtitle ,make-subtitle) (make-summary ,make-summary)
94                (make-title ,make-title) (make-rfc3339 ,make-rfc3339) (rfc3339->string ,rfc3339->string)
95                (seconds->rfc3339 ,seconds->rfc3339) (utc-time->rfc3339 ,utc-time->rfc3339)
96                (time->rfc3339 ,time->rfc3339) (pages->atom-doc ,pages->atom-doc)))
97
98    (write-atom-doc (eval (read) env))))
99
100(translators (cons (list "atom" translate/atom '(ext . atom) '(layouts))
101                   (translators)))
102
103)
Note: See TracBrowser for help on using the repository browser.