summaryrefslogtreecommitdiffstats
path: root/website/haunt.scm
diff options
context:
space:
mode:
Diffstat (limited to 'website/haunt.scm')
-rw-r--r--website/haunt.scm265
1 files changed, 0 insertions, 265 deletions
diff --git a/website/haunt.scm b/website/haunt.scm
deleted file mode 100644
index a230226..0000000
--- a/website/haunt.scm
+++ /dev/null
@@ -1,265 +0,0 @@
1;;; The GNU Assembly Web Site
2;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
3;;; Copyright © 2021 Ricardo Wurmus <rekado@elephly.net>
4;;;
5;;; This program is free software; you can redistribute it and/or modify it
6;;; under the terms of the GNU General Public License as published by
7;;; the Free Software Foundation; either version 3 of the License, or (at
8;;; your option) any later version.
9;;;
10;;; This program is distributed in the hope that it will be useful, but
11;;; WITHOUT ANY WARRANTY; without even the implied warranty of
12;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13;;; GNU General Public License for more details.
14;;;
15;;; You should have received a copy of the GNU General Public License
16;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
17
18(use-modules (haunt asset)
19 (haunt site)
20 (haunt page)
21 (haunt html)
22 (haunt post)
23 (haunt builder assets)
24 (haunt builder blog)
25 (haunt builder atom)
26 (haunt reader)
27 (haunt reader commonmark)
28 (srfi srfi-19) ;dates
29 (srfi srfi-26) ;cut
30 (srfi srfi-71) ;multiple-value let
31 (ice-9 match))
32
33(define %cwd
34 (and=> (assq-ref (current-source-location) 'filename)
35 dirname))
36
37(define (base-url . location)
38 (string-concatenate (cons "" location)))
39
40(define (image-url location)
41 (base-url "/static/images" location))
42
43(define (css-url location)
44 (base-url "/static/css" location))
45
46(define* (base-layout body #:key (title "") (meta '())
47 (posts '()) site)
48 (define (menubar where)
49 (let ((locations
50 '(("about" "About" "/")
51 ("software" "Software" "/en/software")
52 ("documents" "Documents" "/en/documents")
53 ("contribute" "contribute" "/en/contribute")
54 ("blog" "Blog" "/en/blog"))))
55 `(div (@ (id "menubar")
56 (class "width-control"))
57 (ul
58 ,@(map (match-lambda
59 ((key text path)
60 (if (and where (string=? where key))
61 `(li (@ (class "selected"))
62 (span ,text))
63 `(li (a (@ (href ,(base-url path)))
64 ,text)))))
65 locations)
66 (li (a (@ (href ,(base-url "/en/blog/feed.xml")))
67 (img (@ (alt "Atom feed")
68 (src ,(image-url "/feed.png"))))))))))
69 (define front-page?
70 (assoc-ref meta 'frontpage))
71
72 `((doctype "html")
73 (html (@ (lang "en"))
74 (head
75 (meta (@ (http-equiv "Content-Type")
76 (content "text/html; charset=utf-8")))
77 (link (@ (rel "icon")
78 (type "image/x-icon")
79 (href ,(image-url "/favicon.svg"))))
80 (link (@ (rel "stylesheet")
81 (href ,(css-url "/main.css"))
82 (type "text/css")
83 (media "screen")))
84 (title ,title))
85 (body
86 ,@(if front-page?
87 '((@ (class "frontpage")))
88 '())
89 (div (@ (id "header"))
90 (div (@ (id "header-inner")
91 (class "width-control"))
92 (a (@ (href ,(base-url "/"))
93 (class ,(if front-page?
94 "logo" "logo small")))
95 (img (@ (alt "The logo of the GNU Assembly")
96 (src ,(image-url (if front-page?
97 "/logo.svg"
98 "/logo-small.svg"))))))
99
100 ;; Add the large-font welcoming message on the
101 ;; front page.
102 ,@(if front-page?
103 `((p (@ (id "heading")
104 (class "front-page-heading"))
105 "Welcome to the GNU Assembly! We write "
106 (a (@ (href "/en/documents/free-software"))
107 (emph "free software"))
108 " — software that empowers users, "
109 "giving them individual and collective control "
110 "over their computing, from the operating "
111 "system to applications."))
112 `(,(menubar (assoc-ref meta 'menu))))))
113 ,@(if front-page?
114 `(,(menubar "about"))
115 '())
116
117 (div (@ (id "content")
118 (class "width-control"))
119 (div (@ (id "content-inner"))
120 (article ,body)))
121
122 (div (@ (id "footer-box")
123 (class "width-control"))
124 (p (a (@ (href "https://wiki.gnu.tools/git/gnu-tools-wiki/tree/website")) ;FIXME
125 "Source of this site")))))))
126
127(define read-markdown
128 (reader-proc commonmark-reader))
129
130(define (read-markdown-page file posts site)
131 "Read the CommonMark page from FILE. Return its final SXML
132representation."
133 (let ((meta body (read-markdown (string-append %cwd "/" file))))
134 (base-layout `(div (@ (class "post"))
135 (div (@ (class "post-body"))
136 ,body))
137 #:title (string-append "The GNU Assembly — "
138 (assoc-ref meta 'title))
139 #:meta meta
140 #:posts posts
141 #:site site)))
142
143(define (static-pages)
144 "Return the list of static web pages."
145 (define (markdown-page html md)
146 (lambda (site posts)
147 (make-page html (read-markdown-page md posts site)
148 sxml->html)))
149
150 (list (markdown-page "index.html" "index.md")
151
152 (markdown-page "/en/documents/index.html"
153 "documents.md")
154 (markdown-page "/en/software/index.html"
155 "software.md")
156 (markdown-page "/en/contribute/index.html"
157 "contribute.md")
158 (markdown-page "/en/documents/free-software/index.html"
159 "free-software.md")
160 (markdown-page "/en/documents/code-of-conduct/index.html"
161 "code-of-conduct.md")
162 (markdown-page "/en/documents/social-contract/index.html"
163 "social-contract.md")))
164
165
166;;;
167;;; Blog.
168;;;
169
170(define (post-url post site)
171 "Return the URL of POST, a Haunt blog post, for SITE."
172 (let ((date (post-date post)))
173 (base-url "/en/blog/"
174 (number->string (date-year date))
175 "/"
176 (string-pad (number->string (date-month date))
177 2 #\0)
178
179 ;; There's an implicit "/index.html" here.
180 "/" (site-post-slug site post))))
181
182(define (summarize-post post uri)
183 (match (post-sxml post)
184 ((('p paragraph ...) _ ...)
185 `((p ,@paragraph)
186 (p (a (@ (href ,uri)) "Continue reading…"))))
187 (body
188 body)))
189
190(define* (post->sxml post #:key post-uri summarize?)
191 "Return the SXML for POST."
192 (define post-body*
193 (if summarize?
194 (cut summarize-post <> post-uri)
195 post-sxml))
196
197 `(div (@ (class "post"))
198 (h1 (@ (class "title"))
199 ,(if post-uri
200 `(a (@ (href ,post-uri))
201 ,(post-ref post 'title))
202 (post-ref post 'title)))
203 (div (@ (class "post-about"))
204 ,(post-ref post 'author)
205 " — " ,(date->string (post-date post) "~B ~e, ~Y"))
206 (hr)
207 (div (@ (class "post-body"))
208 ,(post-body* post))))
209
210(define (page->sxml site title posts prefix)
211 "Return the SXML for the news page of SITE, containing POSTS."
212 `((div (@ (class "header"))
213 (div (@ (class "post-list"))
214 ,@(map (lambda (post)
215 (post->sxml post #:post-uri (post-url post site)
216 #:summarize? #t))
217 posts)))))
218
219(define (post->page post site)
220 (make-page (string-append (post-url post site) "/index.html")
221 (render-post %theme site post)
222 sxml->html))
223
224(define %theme
225 ;; Theme for the rendering of the news pages.
226 (theme #:name "The GNU Assembly"
227 #:layout (lambda (site title body)
228 (base-layout body
229 #:title
230 (string-append "The GNU Assembly — "
231 title)))
232 #:post-template post->sxml
233 #:collection-template page->sxml))
234
235
236(site #:title "The GNU Assembly"
237 #:domain "gnu.tools"
238 #:default-metadata
239 '((author . "The GNU Assembly")
240 (email . "assembly@lists.gnu.tools"))
241 #:readers (list commonmark-reader)
242 #:builders (append (list (static-directory "static"))
243 (static-pages)
244
245 ;; Blog posts.
246 (list (lambda (site posts)
247 ;; Pages for each post.
248 (map (cut post->page <> site) posts))
249
250 (lambda (site posts)
251 ;; The main collection.
252 (make-page
253 "/en/blog/index.html"
254 (render-collection
255 %theme site
256 "The GNU Assembly — Blog" ;title
257 (posts/reverse-chronological posts)
258 "/en/blog")
259 sxml->html))
260
261 ;; Apparently the <link> tags of Atom entries
262 ;; must be absolute URLs, hence this
263 ;; #:blog-prefix.
264 (atom-feed #:file-name "en/blog/feed.xml"
265 #:blog-prefix "https://gnu.tools/en/blog"))))
generated by cgit v1.2.1 (git 2.18.0) at 2024-04-19 22:26:41 +0000