diff options
Diffstat (limited to 'haunt.scm')
-rw-r--r-- | haunt.scm | 125 |
1 files changed, 125 insertions, 0 deletions
diff --git a/haunt.scm b/haunt.scm new file mode 100644 index 0000000..18a7b2d --- /dev/null +++ b/haunt.scm | |||
@@ -0,0 +1,125 @@ | |||
1 | ;;; The GNU Assembly Web Site | ||
2 | ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> | ||
3 | ;;; | ||
4 | ;;; This program is free software; you can redistribute it and/or modify it | ||
5 | ;;; under the terms of the GNU General Public License as published by | ||
6 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
7 | ;;; your option) any later version. | ||
8 | ;;; | ||
9 | ;;; This program is distributed in the hope that it will be useful, but | ||
10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
12 | ;;; GNU General Public License for more details. | ||
13 | ;;; | ||
14 | ;;; You should have received a copy of the GNU General Public License | ||
15 | ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. | ||
16 | |||
17 | (use-modules (haunt asset) | ||
18 | (haunt site) | ||
19 | (haunt page) | ||
20 | (haunt html) | ||
21 | (haunt builder assets) | ||
22 | (haunt reader) | ||
23 | (haunt reader commonmark) | ||
24 | (srfi srfi-71)) | ||
25 | |||
26 | (define %cwd | ||
27 | (and=> (assq-ref (current-source-location) 'filename) | ||
28 | dirname)) | ||
29 | |||
30 | (define (base-url . location) | ||
31 | (string-concatenate (cons "" location))) | ||
32 | |||
33 | (define (image-url location) | ||
34 | (base-url "/static/images" location)) | ||
35 | |||
36 | (define (css-url location) | ||
37 | (base-url "/static/css" location)) | ||
38 | |||
39 | (define* (base-layout body #:key (title "") (meta '()) | ||
40 | (posts '()) site) | ||
41 | `((doctype "html") | ||
42 | (html (@ (lang "en")) | ||
43 | (head | ||
44 | (meta (@ (http-equiv "Content-Type") | ||
45 | (content "text/html; charset=utf-8"))) | ||
46 | (link (@ (rel "icon") | ||
47 | (type "image/x-icon") | ||
48 | (href ,(image-url "/favicon.png")))) | ||
49 | (link (@ (rel "stylesheet") | ||
50 | (href ,(css-url "/main.css")) | ||
51 | (type "text/css") | ||
52 | (media "screen"))) | ||
53 | (title ,title)) | ||
54 | (body | ||
55 | (div (@ (id "header") | ||
56 | ,@(if (assoc-ref meta 'frontpage) | ||
57 | '((class "frontpage")) | ||
58 | '())) | ||
59 | (div (@ (id "header-inner") | ||
60 | (class "width-control")) | ||
61 | (a (@ (href ,(base-url "/"))) | ||
62 | (img (@ (class "logo") | ||
63 | (src ,(image-url (if (assoc-ref meta 'frontpage) | ||
64 | "/logo.png" | ||
65 | "/logo-small.png")))))) | ||
66 | ,@(if (assoc-ref meta 'frontpage) | ||
67 | '((div (@ (class "baseline")) | ||
68 | "Software for human empowerment.")) | ||
69 | '()))) | ||
70 | (div (@ (id "menubar") | ||
71 | (class "width-control")) | ||
72 | (ul | ||
73 | (li (a (@ (href ,(base-url "/"))) | ||
74 | "About")) | ||
75 | (li (a (@ (href ,(base-url "/blog"))) | ||
76 | "Blog")) | ||
77 | (li (a (@ (href ,(base-url "/blog/feed.xml"))) | ||
78 | (img (@ (alt "Atom feed") | ||
79 | (src ,(image-url "/feed.png")))))))) | ||
80 | |||
81 | (div (@ (id "content") | ||
82 | (class "width-control")) | ||
83 | (div (@ (id "content-inner")) | ||
84 | (article ,body))) | ||
85 | |||
86 | (div (@ (id "footer-box") | ||
87 | (class "width-control")) | ||
88 | (p (a (@ (href "https://wiki.gnu.tools/git/")) ;FIXME | ||
89 | "Source of this site"))))))) | ||
90 | |||
91 | (define read-markdown | ||
92 | (reader-proc commonmark-reader)) | ||
93 | |||
94 | (define (read-markdown-page file posts site) | ||
95 | "Read the CommonMark page from FILE. Return its final SXML | ||
96 | representation." | ||
97 | (let ((meta body (read-markdown (string-append %cwd "/" file)))) | ||
98 | (base-layout `(div (@ (class "post")) | ||
99 | (div (@ (class "post-body")) ,body)) | ||
100 | #:title (string-append "The GNU Assembly — " | ||
101 | (assoc-ref meta 'title)) | ||
102 | #:meta meta | ||
103 | #:posts posts | ||
104 | #:site site))) | ||
105 | |||
106 | (define (static-pages) | ||
107 | "Return the list of static web pages." | ||
108 | (define (markdown-page html md) | ||
109 | (lambda (site posts) | ||
110 | (make-page html (read-markdown-page md posts site) | ||
111 | sxml->html))) | ||
112 | |||
113 | (list (markdown-page "index.html" "index.md") | ||
114 | (markdown-page "/en/documents/social-contract/index.html" | ||
115 | "social-contract.md"))) | ||
116 | |||
117 | |||
118 | (site #:title "The GNU Assembly" | ||
119 | #:domain "gnu.tools" | ||
120 | #:default-metadata | ||
121 | '((author . "The GNU Assembly") | ||
122 | (email . "assembly@lists.gnu.tools")) | ||
123 | #:readers (list commonmark-reader) | ||
124 | #:builders (cons (static-directory "static") | ||
125 | (static-pages))) | ||