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