1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
|
;; -*- geiser-scheme-implementation: guile -*-
;;; Bootstrappable.org website
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of the Bootstrappable.org website.
;;;
;;; The Bootstrappable.org website is free software; you can
;;; redistribute it and/or modify it under the terms of the Affero
;;; General Public License as published by the Free Software
;;; Foundation; either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; GuixSD website is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the Affero General Public
;;; License along with these source files. If not, see
;;; <http://www.gnu.org/licenses/>.
;; This is a build file for Haunt.
(use-modules (srfi srfi-1) ; list stuff
(srfi srfi-11) ; let-values
(srfi srfi-19) ; date functions
(srfi srfi-26) ; cut
(ice-9 ftw) ; file system
(ice-9 match) ; match-lambda
(haunt reader)
(haunt reader skribe)
(haunt site)
(haunt asset)
(haunt post) ;post-file-name
(haunt page)
(haunt html) ;sxml->html
(haunt utils) ;absolute-file-name
(haunt builder blog)
(haunt builder atom))
(define skribe-reader
(make-skribe-reader #:modules '((haunt skribe utils)
(haunt utils)
(skribe-utils))))
(define (drop-extension file-name)
(string-join
(drop-right (string-split file-name #\.) 1) ""))
(define (post/file-base-name post)
(drop-extension (basename (post-file-name post))))
(define* (read-page reader file-name layout target)
"Read a page object from FILE-NAME using READER and wrap it in LAYOUT."
(let-values (((metadata sxml) ((reader-proc reader) file-name)))
(make-page target
(layout #f (assoc-ref metadata 'title) sxml) ; site is #f
sxml->html)))
(define* (wrap-pages directory dest layout readers)
"Read all files in DIRECTORY, wrap them with the given LAYOUT and
place them in the directory DEST."
(define enter? (const #t))
;; remove "directory" from the front of "file-name", prepend "dest"
(define (leaf file-name stat memo)
(let* ((reader (find (cut reader-match? <> file-name) readers))
(base-length (length (file-name-components directory)))
(dest* (file-name-components dest))
(file-name* (file-name-components file-name))
(target (join-file-name-components
(append dest* (drop file-name* base-length))))
(target-name (string-append (drop-extension target) ".html")))
(if reader
(cons (read-page reader file-name default-layout target-name) memo)
(error "no reader available for page: " file-name))))
(define (noop file-name stat memo) memo)
(define (err file-name stat errno memo)
(error "layout processing failed with errno: " file-name errno))
(file-system-fold enter? leaf noop noop noop err '() directory))
(define* (latest-blog-post #:key theme)
"Return a builder procedure that copies the latest blog post to blog/latest.html."
(lambda (site posts)
(make-page "blog/latest.html"
((@@ (haunt builder blog) render-post)
theme
site
(first (posts/reverse-chronological posts)))
sxml->html)))
(define* (pin-blog-post file-name pinned-name #:key theme)
"Return a builder procedure that copies FILE-NAME as PINNED-NAME."
(lambda (site posts)
(make-page pinned-name
((@@ (haunt builder blog) render-post) theme site
(find (lambda (post)
(equal? (post-file-name post) file-name))
posts))
sxml->html)))
(define (date->string* date)
"Convert DATE to human readable string."
(date->string date "~B ~e, ~Y"))
(define footer
`(footer
"Made with " (span (@ (class "highlight")) "♥")
" by "
(a (@ (href "/who.html"))
"humans")
" and powered by "
(a (@ (href "https://gnu.org/software/guile"))
"GNU Guile") ". "
(a (@ (href "http://git.savannah.gnu.org/cgit/guix/bootstrappable.git/"))
"Source code")
" under the "
(a (@ (href "https://gnu.org/licenses/agpl-3.0.html"))
"GNU AGPL") "."))
(define (make-layout big-banner?)
(lambda (site title body)
`((doctype "html")
(head
(meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
(meta (@ (http-equiv "Content-Language") (content "en")))
(meta (@ (name "author") (content "Ricardo Wurmus")))
(meta (@ (name "viewport") (content "width=device-width")))
(title ,(or title (if site (site-title site) "Bootstrappable --- towards trustable trust")))
(link (@ (rel "stylesheet")
(media "screen")
(type "text/css")
(href "/css/reset.css")))
(link (@ (rel "stylesheet")
(media "screen")
(type "text/css")
(href "/css/screen.css")))
(link (@ (rel "shortcut icon")
(href "http://bootstrappable.org/favicon.ico"))))
(body (@ (id "top"))
,(if big-banner?
'(div (@ (id "banner"))
(img (@ (alt "A boot pulled up by its straps.")
(src "/images/banner.svg"))))
`(begin
(div (@ (id "banner-slim"))
(a (@ (href "/"))
(img (@ (alt "A boot pulled up by its straps.")
(src "/images/banner-slim.svg")))))
(h1 ,title)))
(div (@ (id "page"))
,body)
,footer))))
(define default-layout (make-layout #f))
(define index-layout (make-layout #t))
(define bootstrappable-theme
(theme #:name "Bootstrappable"
#:layout default-layout
#:post-template ; TODO: should also take "site" for "site-post-slug"
(lambda (post)
;; TODO: similar version below for collection-template
(define (post-uri post)
(string-append "/blog/" (%make-slug post) ".html"))
`((h1 ,(post-ref post 'title))
(div (@ (class "time"))
(a (@ (href ,(post-uri post)))
,(date->string* (post-date post))))
(p (@ (class "back"))
(a (@ (href "/blog"))
"← other posts"))))
#:collection-template
(lambda* (site title posts prefix #:optional all-posts tag)
(define (post-uri post)
(string-append "/" (or prefix "") (site-post-slug site post) ".html"))
`((h1 ,title
,(if tag
`(a (@ (href ,(string-append "/feeds/tags/" tag ".xml")))
(img (@ (class "feed-icon")
(src "/images/feed.png")
(alt "subscribe to atom feed"))))
'()))
(ul (@ (class "archive"))
,@(map (lambda (post)
`(li
(a (@ (href ,(post-uri post)))
,(post-ref post 'title))))
posts))))))
;; needed for post template, because the site is not passed to the
;; layout function
(define %make-slug post/file-base-name)
(site #:title "Bootstrappable"
#:domain "http://bootstrappable.org/blog"
#:default-metadata
'((author . "Ricardo Wurmus")
(email . "rekado@elephly.net"))
#:make-slug %make-slug
#:readers (list skribe-reader html-reader)
#:builders (list (lambda _
(read-page skribe-reader
"index.skr"
index-layout
"index.html"))
(lambda (args . rest)
(wrap-pages "pages" "." default-layout
(list skribe-reader html-reader)))
(lambda _
(directory-assets "static" (const #t) "."))
(blog #:theme bootstrappable-theme
#:prefix "blog/")
(atom-feed)
(atom-feeds-by-tag)))
|
