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

Last change on this file since 23470 was 23470, checked in by Moritz Heidkamp, 10 years ago

hyde-atom: add `pages->atom-doc' to facilitate generating atom feeds from a list of hyde pages

File size: 4.6 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) (page-path)) relation: "self" type: 'atom))
58      entries: (map (lambda (p)
59                      (make-entry title: (make-title (page-title p))
60                                  published: (page-date->rfc3339-string (page-date p))
61                                  updated: (page-date->rfc3339-string (page-date p))
62                                  id: (format ($ 'tag) 
63                                              (page-date->YYYY-MM-DD (page-date p))
64                                              (page-path p))
65                                  links: (list (make-link uri: (string-append ($ 'base-uri) (page-path p)) 
66                                                          type: (or (page-type p) ($ 'entries-type))))
67                                  authors: (let ((authors (maybe-authors->atom-authors (page-authors p))))
68                                             ;; we include the feed authors for every entry in case there are
69                                             ;; none for this entry specifically since feed readers tend to ignore
70                                             ;; feed-wide authors
71                                             (if (null? authors) feed-authors authors))
72                                  content: (page->atom-content p)))
73                    pages)))))
74
75(define (translate/atom)
76  (let ((env (page-eval-env)))
77    (for-each (lambda (binding)
78                (apply environment-extend! (cons env binding)))
79              `((make-atom-doc ,make-atom-doc) (make-author ,make-author) (make-category ,make-category)
80                (make-content ,make-content) (make-contributor ,make-contributor) (make-entry ,make-entry)
81                (make-feed ,make-feed) (make-generator ,make-generator) (make-icon ,make-icon)
82                (make-link ,make-link) (make-logo ,make-logo) (make-rights ,make-rights)
83                (make-source ,make-source) (make-subtitle ,make-subtitle) (make-summary ,make-summary)
84                (make-title ,make-title) (make-rfc3339 ,make-rfc3339) (rfc3339->string ,rfc3339->string)
85                (seconds->rfc3339 ,seconds->rfc3339) (utc-time->rfc3339 ,utc-time->rfc3339)
86                (time->rfc3339 ,time->rfc3339) (pages->atom-doc ,pages->atom-doc)))
87
88    (write-atom-doc (eval (read) env))))
89
90(translators (cons (list "atom" translate/atom '(ext . atom) '(layouts))
91                   (translators)))
92
93)
Note: See TracBrowser for help on using the repository browser.