blob: 969d0562b3b961be967d5995f7a27c39f93f58fb (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
;;; Harmonic Flow web site
(define-module (apps blog builder)
#:use-module (apps aux system)
#:use-module (apps aux web)
#:use-module (apps base utils)
#:use-module (apps blog templates feed)
#:use-module (apps blog templates post-list)
#:use-module (apps blog templates post)
#:use-module (apps blog templates tag)
#:use-module (apps blog utils)
#:use-module (haunt html)
#:use-module (haunt artifact)
#:use-module (haunt post)
#:use-module (haunt site)
#:use-module (haunt utils)
#:use-module (sxml simple)
#:export (builder))
;;;
;;; Application builder.
;;;
(define (builder site posts)
"Return the list of web resources that compose the app.
This procedure is a Haunt builder procedure.
SITE (<site>)
A site object that defines all the properties of the website. See
Haunt <site> objects for more information.
POSTS (list of <post>)
A list of post objects that represent articles from the blog. See
Haunt <post> objects for more information.
RETURN (list of <page>)
A list of page objects that represent the web resources of the
application. See Haunt <page> objects for more information."
(flatten
(list
(blog-feed-builder site posts)
(post-list-builder posts)
(posts-builder posts)
(tag-feed-builder site posts)
(tags-builder posts))))
;;;
;;; Helper builders.
;;;
(define (sxml->xml* sxml port) ;from (haunt builder atom)
"Write SXML to PORT, preceded by an <?xml> tag."
(set-port-encoding! port "UTF-8")
(display "<?xml version=\"1.0\" encoding=\"utf-8\"?>" port)
(sxml->xml sxml port))
(define (blog-feed-builder site posts)
"Return a Haunt page representing the atom feed of the blog."
(let* ((domain (site-domain site))
(sorted-posts (posts/reverse-chronological posts))
(max-posts 10) ; Number of posts to add to the feed.
(context
(list
(cons "domain" domain)
(cons "title" "Harmonic Flow Blog")
(cons "id" (url-path-join domain "feeds" "blog.atom"))
(cons "alternate" (url-path-join domain "blog" ""))
(cons "posts"
(if (> (length sorted-posts) max-posts)
(list-head sorted-posts max-posts)
sorted-posts)))))
(serialized-artifact (path-join "feeds" "blog.atom")
(atom-feed-t context)
sxml->xml*)))
(define (post-list-builder posts)
"Return a list of Haunt pages representing paginated POSTS."
(let ((context
(list
(cons "tags" (post-groups->tag-list
(posts/group-by-tag posts))))))
(paginate #:dataset (posts/reverse-chronological posts)
#:base-path "blog"
#:template post-list-t
#:context context
#:writer sxml->html)))
(define (posts-builder posts)
"Return a list of Haunt pages representing blog posts."
(map
(lambda (post)
(let ((context (list (cons "post" post))))
(serialized-artifact (path-join (post-url-path post) "index.html")
(post-t context)
sxml->html)))
posts))
(define (tag-feed-builder site posts)
"Return a Haunt page representing the atom feed of a blog topic."
(let ((post-groups (posts/group-by-tag posts)))
(map
(lambda (tagged-posts)
(let* ((domain (site-domain site))
(tag-name (car tagged-posts))
(tag-slug (slugify tag-name))
(file-name (string-append tag-slug ".atom"))
(context
(list
(cons "domain" domain)
(cons "title"
(string-append "Harmonic Flow Blog — " tag-name))
(cons "id" (url-path-join domain
"feeds"
"blog"
file-name))
(cons "alternate" (url-path-join domain
"blog"
"tags"
tag-slug
""))
(cons "posts"
(posts/reverse-chronological (cdr tagged-posts))))))
(serialized-artifact (path-join "feeds" "blog" file-name)
(atom-feed-t context)
sxml->xml)))
post-groups)))
(define (tags-builder posts)
"Return a list of lists of Haunt pages representing POSTS grouped by
tag.
Each list of pages corresponds to the paginated blog posts of one
tag."
(let ((post-groups (posts/group-by-tag posts)))
(map
(lambda (tagged-posts)
(let ((context
(list
(cons "tag" (car tagged-posts))
(cons "tags" (post-groups->tag-list post-groups)))))
(paginate #:dataset (posts/reverse-chronological (cdr tagged-posts))
#:base-path (tag-system-path (car tagged-posts))
#:template tag-t
#:context context
#:writer sxml->html)))
post-groups)))
|
