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