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