1 ;; -*- geiser-scheme-implementation: guile -*-
3 (use-modules (srfi srfi-1
) ; list stuff
4 (srfi srfi-11
) ; let-values
5 (srfi srfi-19
) ; date functions
7 (ice-9 ftw
) ; file system
8 (ice-9 match
) ; match-lambda
13 (haunt post
) ;post-file-name
15 (haunt html
) ;sxml->html
16 (haunt utils
) ;absolute-file-name
22 (make-skribe-reader #:modules
'((haunt skribe utils
)
27 (define (photo-snippet post
)
28 ;; TODO: derive alt-text from "photo" metadata
29 (let ((meta (post-ref post
'photo
)))
31 `(img (@ (class "stretch full")
32 (src ,(string-append "/images/posts/" meta
))))
35 (define (flattr-snippet post
)
36 (let ((meta (post-ref post
'flattr
)))
38 `(a (@ (href ,(string-append "http://flattr.com/thing/" meta
)))
39 (img (@ (title "Flattr this")
41 (src "http://api.flattr.com/button/flattr-badge-large.png"))))
45 (define (license-snippet post
)
46 (let ((meta (post-ref post
'license
)))
48 `(div (@ (class "fineprint"))
49 (div (@ (class "license"))
51 (href "http://creativecommons.org/licenses/by-sa/3.0/"))
52 (img (@ (alt "Creative Commons License")
53 (style "border-width:0")
54 (src "http://i.creativecommons.org/l/by-sa/3.0/80x15.png"))))
55 (span (@ (xmlns:dct
"http://purl.org/dc/terms/")
56 (href "http://purl.org/dc/dcmitype/StillImage")
57 (property "dct:title")
59 ,(post-ref post
'title
))
61 (a (@ (xmlns:cc
"http://creativecommons.org/ns#")
62 (href "http://elephly.net")
63 (property "cc:attributionName")
64 (rel "cc:attributionURL"))
66 " is licensed under a "
68 (href "http://creativecommons.org/licenses/by-sa/3.0/"))
69 "Creative Commons Attribution-ShareAlike 3.0 Unported License")))
74 (define (drop-extension file-name
)
76 (drop-right (string-split file-name
#\.
) 1) ""))
79 (define (post/file-base-name post
)
80 (drop-extension (basename (post-file-name post
))))
83 (define* (read-page reader file-name layout target
)
84 "Read a page object from FILE-NAME using READER and wrap it in LAYOUT."
85 (let-values (((metadata sxml
) ((reader-proc reader
) file-name
)))
87 (layout #f
(assoc-ref metadata
'title
) sxml
) ; site is #f
91 (define* (wrap-pages directory dest layout readers
)
92 "Read all files in DIRECTORY, wrap them with the given LAYOUT and
93 place them in the directory DEST."
94 (define enter?
(const #t
))
96 ;; remove "directory" from the front of "file-name", prepend "dest"
97 (define (leaf file-name stat memo
)
98 (let* ((reader (find (cut reader-match?
<> file-name
) readers
))
99 (base-length (length (file-name-components directory
)))
100 (dest* (file-name-components dest
))
101 (file-name* (file-name-components file-name
))
102 (target (join-file-name-components
103 (append dest
* (drop file-name
* base-length
))))
104 (target-name (string-append (drop-extension target
) ".html")))
106 (cons (read-page reader file-name default-layout target-name
) memo
)
107 (error "no reader available for page: " file-name
))))
109 (define (noop file-name stat memo
) memo
)
111 (define (err file-name stat errno memo
)
112 (error "layout processing failed with errno: " file-name errno
))
114 (file-system-fold enter? leaf noop noop noop err
'() directory
))
117 (define* (latest-blog-post #:key theme
)
118 "Return a builder procedure that copies the latest blog post to posts/latest.html."
120 (make-page "posts/latest.html"
121 ((@@ (haunt builder blog
) render-post
)
124 (first (posts/reverse-chronological posts
)))
127 (define* (pin-blog-post file-name pinned-name
#:key theme
)
128 "Return a builder procedure that copies FILE-NAME as PINNED-NAME."
130 (make-page pinned-name
131 ((@@ (haunt builder blog
) render-post
) theme site
133 (equal?
(post-file-name post
) file-name
))
137 (define* (tag-pages #:key
138 (theme elephly-theme
)
140 (filter posts
/reverse-chronological
))
141 "Return a builder procedure that renders a list page for every tag
142 used in a post. All arguments are optional:
144 PREFIX: The directory in which to write the posts
145 FILTER: The procedure called to manipulate the posts list before rendering"
147 (define (tag-list tag posts all-posts
)
148 (define (render-list title posts prefix
)
149 (let ((body ((theme-collection-template theme
)
150 site title posts prefix all-posts tag
)))
151 ((theme-layout theme
) site title body
)))
152 (make-page (string-append "tags/" tag
".html")
153 (render-list (string-append "Posts tagged ‘" tag
"’")
157 (let ((tag-groups (posts/group-by-tag posts
)))
159 ((tag . tagged-posts
) (tag-list tag tagged-posts posts
)))
163 (define (tag-links posts
)
164 "Generate an alphabetically sorted list of links to tagged posts.
165 The link text consists of the tag name and the number of tagged posts
167 `(ul (@ (class "tags"))
170 `(li (a (@ (href ,(string-append "/tags/" tag
".html")))
171 ,(string-append tag
" (" (number->string
(length posts
)) ")")))))
173 (sort (posts/group-by-tag posts
)
174 (lambda (a b
) (string<?
(car a
) (car b
)))))))
176 (define (date->string
* date
)
177 "Convert DATE to human readable string."
178 (date->string date
"~B ~e, ~Y"))
182 (define (default-layout site title body
)
185 (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
186 (meta (@ (http-equiv "Content-Language") (content "en")))
187 (meta (@ (name "author") (content "Ricardo Wurmus")))
188 (meta (@ (name "viewport") (content "width=device-width")))
189 (title ,(or title
(if site
(site-title site
) "Rekado")))
190 (link (@ (rel "openid2.provider")
191 (href "https://openid.stackexchange.com/openid/provider")))
192 (link (@ (rel "openid2.local_id")
193 (href "https://openid.stackexchange.com/user/0f8f09d4-a2f3-429f-8752-b53a328c255c")))
194 (link (@ (rel "stylesheet")
197 (href "/css/reset.css")))
198 (link (@ (rel "stylesheet")
201 (href "/css/screen.css")))
202 (link (@ (rel "shortcut icon")
203 (href "http://elephly.net/favicon.ico")))
204 (script (@ (type "text/javascript") (src "/js/libs/jquery-1.6.2.min.js")))
205 (script (@ (type "text/javascript") (src "/js/deobfuscate.js")))
206 (script (@ (type "text/javascript") (src "/js/hyphenator/Hyphenator.js")))
207 (script (@ (type "text/javascript")) "Hyphenator.run();")
208 (script (@ (type "text/javascript") (src "/js/loadComments.js"))))
210 (div (@ (id "index"))
211 (a (@ (href "/") (title "show index"))
213 (src "/images/logo.png")))))
214 (div (@ (id "page") (class "hyphenate"))
218 (define elephly-theme
219 (theme #:name
"Elephly"
220 #:layout default-layout
221 #:post-template
; TODO: should also take "site" for "site-post-slug"
223 ;; TODO: similar version below for collection-template
224 (define (post-uri post
)
225 (string-append "/posts/" (%make-slug post
) ".html"))
226 `((h1 (@ (class "donthyphenate")) ,(post-ref post
'title
))
227 (div (@ (class "time"))
228 (a (@ (href ,(post-uri post
)))
229 ,(date->string
* (post-date post
))))
230 ,(photo-snippet post
)
232 ,(flattr-snippet post
)
233 ,(license-snippet post
)
234 (p (@ (class "back"))
235 (a (@ (href "/posts"))
237 (div (@ (id "comments"))
238 (p "Comments? Then send me an email! Interesting comments may be published here."))))
239 #:collection-template
240 (lambda* (site title posts prefix
#:optional all-posts tag
)
241 (define (post-uri post
)
242 (string-append "/" (or prefix
"") (site-post-slug site post
) ".html"))
243 `((h1 (@ (class "donthyphenate"))
246 `(a (@ (href ,(string-append "/feeds/tags/" tag
".xml")))
247 (img (@ (class "feed-icon")
248 (src "/images/feed.png")
249 (alt "subscribe to atom feed"))))
251 (ul (@ (class "archive"))
252 ,@(map (lambda (post)
254 (a (@ (href ,(post-uri post
)))
255 ,(post-ref post
'title
))))
258 ;; TODO: I really want this to be computed only once for
260 ,(tag-links (or all-posts posts
))
262 '(a (@ (href "/posts"))
267 ;; needed for post template, because the site is not passed to the
269 (define %make-slug post
/file-base-name
)
271 (site #:title
"Rekado"
272 #:domain
"http://elephly.net"
274 '((author .
"Ricardo Wurmus")
275 (email .
"rekado+web@elephly.net"))
276 #:make-slug %make-slug
277 #:readers
(list skribe-reader html-reader
)
278 #:builders
(list (lambda (args . rest
)
279 (wrap-pages "non-posts" "." default-layout
280 (list skribe-reader html-reader
)))
282 (directory-assets "static" (const #t
) "."))
283 (blog #:theme elephly-theme
285 (tag-pages #:theme elephly-theme
287 (latest-blog-post #:theme elephly-theme
)
288 (pin-blog-post "posts/2010-03-28-elephly.skr"
290 #:theme elephly-theme
)
291 (pin-blog-post "posts/2010-03-23-fur-man.skr"
293 #:theme elephly-theme
)
294 (atom-feed #:blog-prefix
"/posts")
295 (atom-feeds-by-tag #:blog-prefix
"/posts")))