Use new skribe reader in haunt.
[software/elephly-net.git] / haunt.scm
1 (use-modules (srfi srfi-1) ; list stuff
2 (srfi srfi-11) ; let-values
3 (srfi srfi-19) ; date functions
4 (srfi srfi-26) ; cut
5 (ice-9 ftw) ; file system
6 (ice-9 match) ; match-lambda
7 (haunt reader)
8 (haunt reader skribe)
9 (haunt site)
10 (haunt asset)
11 (haunt post) ;post-file-name
12 (haunt page)
13 (haunt html) ;sxml->html
14 (haunt utils) ;absolute-file-name
15 (haunt builder blog)
16 (haunt builder atom))
17
18 \f
19 (define skribe-reader
20 (make-skribe-reader #:modules '((haunt skribe utils)
21 (haunt utils)
22 (skribe-utils))))
23
24 \f
25 (define (photo-snippet post)
26 (let ((meta (post-ref post 'photo)))
27 (if meta
28 `(img (@ (class "stretch full")
29 (src ,(string-append "/images/posts/" meta))))
30 '())))
31
32 (define (flattr-snippet post)
33 (let ((meta (post-ref post 'flattr)))
34 (if meta
35 `(a (@ (href ,(string-append "http://flattr.com/thing/" meta)))
36 (img (@ (title "Flattr this")
37 (alt "Flattr this")
38 (src "http://api.flattr.com/button/flattr-badge-large.png"))))
39 '())))
40
41 ;; TODO: use license
42 (define (license-snippet post)
43 (let ((meta (post-ref post 'license)))
44 (if meta
45 `(div (@ (class "fineprint"))
46 (div (@ (class "license"))
47 (a (@ (rel "license")
48 (href "http://creativecommons.org/licenses/by-sa/3.0/"))
49 (img (@ (alt "Creative Commons License")
50 (style "border-width:0")
51 (src "http://i.creativecommons.org/l/by-sa/3.0/80x15.png"))))
52 (span (@ (xmlns:dct "http://purl.org/dc/terms/")
53 (href "http://purl.org/dc/dcmitype/StillImage")
54 (property "dct:title")
55 (rel "dct:type"))
56 ,(post-ref post 'title))
57 " by "
58 (a (@ (xmlns:cc "http://creativecommons.org/ns#")
59 (href "http://elephly.net")
60 (property "cc:attributionName")
61 (rel "cc:attributionURL"))
62 "Ricardo Wurmus")
63 " is licensed under a "
64 (a (@ (rel "license")
65 (href "http://creativecommons.org/licenses/by-sa/3.0/"))
66 "Creative Commons Attribution-ShareAlike 3.0 Unported License")))
67 '())))
68
69
70 \f
71 (define (drop-extension file-name)
72 (string-join
73 (drop-right (string-split file-name #\.) 1) ""))
74
75
76 (define (post/file-base-name post)
77 (drop-extension (basename (post-file-name post))))
78
79
80 (define* (read-page reader file-name layout target)
81 "Read a page object from FILE-NAME using READER and wrap it in LAYOUT."
82 (let-values (((metadata sxml) ((reader-proc reader) file-name)))
83 (make-page target
84 (layout #f (assoc-ref metadata 'title) sxml) ; site is #f
85 sxml->html)))
86
87
88 (define* (wrap-pages directory dest layout readers)
89 "Read all files in DIRECTORY, wrap them with the given LAYOUT and
90 place them in the directory DEST."
91 (define enter? (const #t))
92
93 ;; remove "directory" from the front of "file-name", prepend "dest"
94 (define (leaf file-name stat memo)
95 (let* ((reader (find (cut reader-match? <> file-name) readers))
96 (base-length (length (file-name-components directory)))
97 (dest* (file-name-components dest))
98 (file-name* (file-name-components file-name))
99 (target (join-file-name-components
100 (append dest* (drop file-name* base-length))))
101 (target-name (string-append (drop-extension target) ".html")))
102 (if reader
103 (cons (read-page reader file-name default-layout target-name) memo)
104 (error "no reader available for page: " file-name))))
105
106 (define (noop file-name stat memo) memo)
107
108 (define (err file-name stat errno memo)
109 (error "layout processing failed with errno: " file-name errno))
110
111 (file-system-fold enter? leaf noop noop noop err '() directory))
112
113
114 (define* (latest-blog-post #:key theme)
115 "Return a builder procedure that copies the latest blog post to posts/latest.html."
116 (lambda (site posts)
117 (make-page "posts/latest.html"
118 ((@@ (haunt builder blog) render-post)
119 theme
120 site
121 (first (posts/reverse-chronological posts)))
122 sxml->html)))
123
124 (define* (pin-blog-post file-name pinned-name #:key theme)
125 "Return a builder procedure that copies FILE-NAME as PINNED-NAME."
126 (lambda (site posts)
127 (make-page pinned-name
128 ((@@ (haunt builder blog) render-post) theme site
129 (find (lambda (post)
130 (equal? (post-file-name post) file-name))
131 posts))
132 sxml->html)))
133
134 (define* (tag-pages #:key
135 (theme elephly-theme)
136 (prefix "posts/")
137 (filter posts/reverse-chronological))
138 "Return a builder procedure that renders a list page for every tag
139 used in a post. All arguments are optional:
140
141 PREFIX: The directory in which to write the posts
142 FILTER: The procedure called to manipulate the posts list before rendering"
143 (lambda (site posts)
144 (define (tag-list tag posts all-posts)
145 (define (render-list title posts prefix)
146 (let ((body ((theme-list-template theme) site title posts prefix all-posts tag)))
147 ((theme-layout theme) site title body)))
148 (make-page (string-append "tags/" tag ".html")
149 (render-list (string-append "Posts tagged ‘" tag "’")
150 (filter posts)
151 prefix)
152 sxml->html))
153 (let ((tag-groups (posts/group-by-tag posts)))
154 (map (match-lambda
155 ((tag . tagged-posts) (tag-list tag tagged-posts posts)))
156 tag-groups))))
157
158
159 (define (tag-links posts)
160 "Generate an alphabetically sorted list of links to tagged posts.
161 The link text consists of the tag name and the number of tagged posts
162 in parentheses."
163 `(ul (@ (class "tags"))
164 ,(map (match-lambda
165 ((tag . posts)
166 `(li (a (@ (href ,(string-append "/tags/" tag ".html")))
167 ,(string-append tag " (" (number->string (length posts)) ")")))))
168 ;; sort by tag
169 (sort (posts/group-by-tag posts)
170 (lambda (a b) (string<? (car a) (car b)))))))
171
172 (define (date->string* date)
173 "Convert DATE to human readable string."
174 (date->string date "~B ~e, ~Y"))
175
176
177 \f
178 (define (default-layout site title body)
179 `((doctype "html")
180 (head
181 (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
182 (meta (@ (http-equiv "Content-Language") (content "en")))
183 (meta (@ (name "author") (content "Ricardo Wurmus")))
184 (meta (@ (name "viewport") (content "width=device-width")))
185 (title ,(or title (if site (site-title site) "Rekado")))
186 (link (@ (rel "openid2.provider")
187 (href "https://openid.stackexchange.com/openid/provider")))
188 (link (@ (rel "openid2.local_id")
189 (href "https://openid.stackexchange.com/user/0f8f09d4-a2f3-429f-8752-b53a328c255c")))
190 (link (@ (rel "stylesheet")
191 (media "screen")
192 (type "text/css")
193 (href "/css/reset.css")))
194 (link (@ (rel "stylesheet")
195 (media "screen")
196 (type "text/css")
197 (href "/css/screen.css")))
198 (link (@ (rel "shortcut icon")
199 (href "http://elephly.net/favicon.ico")))
200 (script (@ (type "text/javascript") (src "/js/libs/jquery-1.6.2.min.js")))
201 (script (@ (type "text/javascript") (src "/js/deobfuscate.js")))
202 (script (@ (type "text/javascript") (src "/js/hyphenator/Hyphenator.js")))
203 (script (@ (type "text/javascript")) "Hyphenator.run();")
204 (script (@ (type "text/javascript") (src "/js/loadComments.js"))))
205 (body (@ (id "top"))
206 (div (@ (id "index"))
207 (a (@ (href "/") (title "show index"))
208 (img (@ (alt "logo")
209 (src "/images/logo.png")))))
210 (div (@ (id "page") (class "hyphenate"))
211 ,body))))
212
213
214 (define elephly-theme
215 (theme #:name "Elephly"
216 #:layout default-layout
217 #:post-template ; TODO: should also take "site" for "site-post-slug"
218 (lambda (post)
219 ;; TODO: similar version below for list-template
220 (define (post-uri post)
221 (string-append "/posts/" (%make-slug post) ".html"))
222 `((h1 (@ (class "donthyphenate")) ,(post-ref post 'title))
223 (div (@ (class "time"))
224 (a (@ (href ,(post-uri post)))
225 ,(date->string* (post-date post))))
226 ,(photo-snippet post)
227 ,(post-sxml post)
228 ,(flattr-snippet post)
229 ,(license-snippet post)
230 (p (@ (class "back"))
231 (a (@ (href "/posts"))
232 "← other posts"))
233 (div (@ (id "disqus_thread")))
234 (a (@ (id "loadComments") (href "javascript:loadComments()"))
235 "Click to load Disqus comments")))
236 #:list-template
237 (lambda* (site title posts prefix #:optional all-posts tag)
238 (define (post-uri post)
239 (string-append "/" (or prefix "") (site-post-slug site post) ".html"))
240 `((h1 (@ (class "donthyphenate"))
241 ,title
242 ,(if tag
243 `(a (@ (href ,(string-append "/feeds/tags/" tag ".xml")))
244 (img (@ (class "feed-icon")
245 (src "/images/feed.png")
246 (alt "subscribe to atom feed"))))
247 '()))
248 (ul (@ (class "archive"))
249 ,@(map (lambda (post)
250 `(li
251 (a (@ (href ,(post-uri post)))
252 ,(post-ref post 'title))))
253 posts))
254 (h2 "All tags")
255 ;; TODO: I really want this to be computed only once for
256 ;; all posts
257 ,(tag-links (or all-posts posts))
258 ,(if tag
259 '(a (@ (href "/posts"))
260 "← all posts")
261 '())))))
262
263
264 ;; needed for post template, because the site is not passed to the
265 ;; layout function
266 (define %make-slug post/file-base-name)
267
268 (site #:title "Rekado"
269 #:domain "elephly.net"
270 #:default-metadata
271 '((author . "Ricardo Wurmus")
272 (email . "rekado+web@elephly.net"))
273 #:make-slug %make-slug
274 #:readers (list skribe-reader html-reader)
275 #:builders (list (lambda (args . rest)
276 (wrap-pages "non-posts" "." default-layout
277 (list skribe-reader html-reader)))
278 (lambda _
279 (directory-assets "static" "."))
280 (blog #:theme elephly-theme
281 #:prefix "posts/")
282 (tag-pages #:theme elephly-theme
283 #:prefix "posts/")
284 (latest-blog-post #:theme elephly-theme)
285 (pin-blog-post "posts/2010-03-28-elephly.skr"
286 "elephly.html"
287 #:theme elephly-theme)
288 (pin-blog-post "posts/2010-03-23-fur-man.skr"
289 "fur-man.html"
290 #:theme elephly-theme)
291 (atom-feed)
292 (atom-feeds-by-tag)))