diff options
Diffstat (limited to '')
-rw-r--r-- | website/haunt.scm | 265 |
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 | ||
132 | representation." | ||
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")))) | ||