Initial commit.
[software/mumi.git] / mumi / web / sxml.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
3 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
4 ;;;
5 ;;; This program is free software: you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Affero General Public License
7 ;;; as published by the Free Software Foundation, either version 3 of
8 ;;; the License, or (at your option) any later version.
9 ;;;
10 ;;; This program is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Affero General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Affero General Public
16 ;;; License along with this program. If not, see
17 ;;; <http://www.gnu.org/licenses/>.
18
19 ;;; Commentary:
20 ;;
21 ;; SXML to HTML conversion.
22 ;;
23 ;;; Code:
24
25 (define-module (mumi web sxml)
26 #:use-module (sxml simple)
27 #:use-module (srfi srfi-26)
28 #:use-module (ice-9 match)
29 #:use-module (ice-9 format)
30 #:use-module (ice-9 hash-table)
31 #:export (sxml->html))
32
33 (define %self-closing-tags
34 '(area
35 base
36 br
37 col
38 command
39 embed
40 hr
41 img
42 input
43 keygen
44 link
45 meta
46 param
47 source
48 track
49 wbr))
50
51 (define (self-closing-tag? tag)
52 "Return #t if TAG is self-closing."
53 (pair? (memq tag %self-closing-tags)))
54
55 (define %escape-chars
56 (alist->hash-table
57 '((#\" . "quot")
58 (#\& . "amp")
59 (#\' . "apos")
60 (#\< . "lt")
61 (#\> . "gt")
62 (#\¡ . "iexcl")
63 (#\¢ . "cent")
64 (#\£ . "pound")
65 (#\¤ . "curren")
66 (#\¥ . "yen")
67 (#\¦ . "brvbar")
68 (#\§ . "sect")
69 (#\¨ . "uml")
70 (#\© . "copy")
71 (#\ª . "ordf")
72 (#\« . "laquo")
73 (#\¬ . "not")
74 (#\® . "reg")
75 (#\¯ . "macr")
76 (#\° . "deg")
77 (#\± . "plusmn")
78 (#\² . "sup2")
79 (#\³ . "sup3")
80 (#\´ . "acute")
81 (#\µ . "micro")
82 (#\¶ . "para")
83 (#\· . "middot")
84 (#\¸ . "cedil")
85 (#\¹ . "sup1")
86 (#\º . "ordm")
87 (#\» . "raquo")
88 (#\¼ . "frac14")
89 (#\½ . "frac12")
90 (#\¾ . "frac34")
91 (#\¿ . "iquest")
92 (#\À . "Agrave")
93 (#\Á . "Aacute")
94 (#\Â . "Acirc")
95 (#\Ã . "Atilde")
96 (#\Ä . "Auml")
97 (#\Å . "Aring")
98 (#\Æ . "AElig")
99 (#\Ç . "Ccedil")
100 (#\È . "Egrave")
101 (#\É . "Eacute")
102 (#\Ê . "Ecirc")
103 (#\Ë . "Euml")
104 (#\Ì . "Igrave")
105 (#\Í . "Iacute")
106 (#\Î . "Icirc")
107 (#\Ï . "Iuml")
108 (#\Ð . "ETH")
109 (#\Ñ . "Ntilde")
110 (#\Ò . "Ograve")
111 (#\Ó . "Oacute")
112 (#\Ô . "Ocirc")
113 (#\Õ . "Otilde")
114 (#\Ö . "Ouml")
115 (#\× . "times")
116 (#\Ø . "Oslash")
117 (#\Ù . "Ugrave")
118 (#\Ú . "Uacute")
119 (#\Û . "Ucirc")
120 (#\Ü . "Uuml")
121 (#\Ý . "Yacute")
122 (#\Þ . "THORN")
123 (#\ß . "szlig")
124 (#\à . "agrave")
125 (#\á . "aacute")
126 (#\â . "acirc")
127 (#\ã . "atilde")
128 (#\ä . "auml")
129 (#\å . "aring")
130 (#\æ . "aelig")
131 (#\ç . "ccedil")
132 (#\è . "egrave")
133 (#\é . "eacute")
134 (#\ê . "ecirc")
135 (#\ë . "euml")
136 (#\ì . "igrave")
137 (#\í . "iacute")
138 (#\î . "icirc")
139 (#\ï . "iuml")
140 (#\ð . "eth")
141 (#\ñ . "ntilde")
142 (#\ò . "ograve")
143 (#\ó . "oacute")
144 (#\ô . "ocirc")
145 (#\õ . "otilde")
146 (#\ö . "ouml")
147 (#\÷ . "divide")
148 (#\ø . "oslash")
149 (#\ù . "ugrave")
150 (#\ú . "uacute")
151 (#\û . "ucirc")
152 (#\ü . "uuml")
153 (#\ý . "yacute")
154 (#\þ . "thorn")
155 (#\ÿ . "yuml")
156 (#\Π. "OElig")
157 (#\œ . "oelig")
158 (#\Š . "Scaron")
159 (#\š . "scaron")
160 (#\Ÿ . "Yuml")
161 (#\ƒ . "fnof")
162 (#\ˆ . "circ")
163 (#\˜ . "tilde")
164 (#\Α . "Alpha")
165 (#\Β . "Beta")
166 (#\Γ . "Gamma")
167 (#\Δ . "Delta")
168 (#\Ε . "Epsilon")
169 (#\Ζ . "Zeta")
170 (#\Η . "Eta")
171 (#\Θ . "Theta")
172 (#\Ι . "Iota")
173 (#\Κ . "Kappa")
174 (#\Λ . "Lambda")
175 (#\Μ . "Mu")
176 (#\Ν . "Nu")
177 (#\Ξ . "Xi")
178 (#\Ο . "Omicron")
179 (#\Π . "Pi")
180 (#\Ρ . "Rho")
181 (#\Σ . "Sigma")
182 (#\Τ . "Tau")
183 (#\Υ . "Upsilon")
184 (#\Φ . "Phi")
185 (#\Χ . "Chi")
186 (#\Ψ . "Psi")
187 (#\Ω . "Omega")
188 (#\α . "alpha")
189 (#\β . "beta")
190 (#\γ . "gamma")
191 (#\δ . "delta")
192 (#\ε . "epsilon")
193 (#\ζ . "zeta")
194 (#\η . "eta")
195 (#\θ . "theta")
196 (#\ι . "iota")
197 (#\κ . "kappa")
198 (#\λ . "lambda")
199 (#\μ . "mu")
200 (#\ν . "nu")
201 (#\ξ . "xi")
202 (#\ο . "omicron")
203 (#\π . "pi")
204 (#\ρ . "rho")
205 (#\ς . "sigmaf")
206 (#\σ . "sigma")
207 (#\τ . "tau")
208 (#\υ . "upsilon")
209 (#\φ . "phi")
210 (#\χ . "chi")
211 (#\ψ . "psi")
212 (#\ω . "omega")
213 (#\ϑ . "thetasym")
214 (#\ϒ . "upsih")
215 (#\ϖ . "piv")
216 (#\  . "ensp")
217 (#\  . "emsp")
218 (#\  . "thinsp")
219 (#\– . "ndash")
220 (#\— . "mdash")
221 (#\‘ . "lsquo")
222 (#\’ . "rsquo")
223 (#\‚ . "sbquo")
224 (#\“ . "ldquo")
225 (#\” . "rdquo")
226 (#\„ . "bdquo")
227 (#\† . "dagger")
228 (#\‡ . "Dagger")
229 (#\• . "bull")
230 (#\… . "hellip")
231 (#\‰ . "permil")
232 (#\′ . "prime")
233 (#\″ . "Prime")
234 (#\‹ . "lsaquo")
235 (#\› . "rsaquo")
236 (#\‾ . "oline")
237 (#\⁄ . "frasl")
238 (#\€ . "euro")
239 (#\ℑ . "image")
240 (#\℘ . "weierp")
241 (#\ℜ . "real")
242 (#\™ . "trade")
243 (#\ℵ . "alefsym")
244 (#\← . "larr")
245 (#\↑ . "uarr")
246 (#\→ . "rarr")
247 (#\↓ . "darr")
248 (#\↔ . "harr")
249 (#\↵ . "crarr")
250 (#\⇐ . "lArr")
251 (#\⇑ . "uArr")
252 (#\⇒ . "rArr")
253 (#\⇓ . "dArr")
254 (#\⇔ . "hArr")
255 (#\∀ . "forall")
256 (#\∂ . "part")
257 (#\∃ . "exist")
258 (#\∅ . "empty")
259 (#\∇ . "nabla")
260 (#\∈ . "isin")
261 (#\∉ . "notin")
262 (#\∋ . "ni")
263 (#\∏ . "prod")
264 (#\∑ . "sum")
265 (#\− . "minus")
266 (#\∗ . "lowast")
267 (#\√ . "radic")
268 (#\∝ . "prop")
269 (#\∞ . "infin")
270 (#\∠ . "ang")
271 (#\∧ . "and")
272 (#\∨ . "or")
273 (#\∩ . "cap")
274 (#\∪ . "cup")
275 (#\∫ . "int")
276 (#\∴ . "there4")
277 (#\∼ . "sim")
278 (#\≅ . "cong")
279 (#\≈ . "asymp")
280 (#\≠ . "ne")
281 (#\≡ . "equiv")
282 (#\≤ . "le")
283 (#\≥ . "ge")
284 (#\⊂ . "sub")
285 (#\⊃ . "sup")
286 (#\⊄ . "nsub")
287 (#\⊆ . "sube")
288 (#\⊇ . "supe")
289 (#\⊕ . "oplus")
290 (#\⊗ . "otimes")
291 (#\⊥ . "perp")
292 (#\⋅ . "sdot")
293 (#\⋮ . "vellip")
294 (#\⌈ . "lceil")
295 (#\⌉ . "rceil")
296 (#\⌊ . "lfloor")
297 (#\⌋ . "rfloor")
298 (#\〈 . "lang")
299 (#\〉 . "rang")
300 (#\◊ . "loz")
301 (#\♠ . "spades")
302 (#\♣ . "clubs")
303 (#\♥ . "hearts")
304 (#\♦ . "diams"))))
305
306 (define (string->escaped-html s port)
307 "Write the HTML escaped form of S to PORT."
308 (define (escape c)
309 (let ((escaped (hash-ref %escape-chars c)))
310 (if escaped
311 (format port "&~a;" escaped)
312 (display c port))))
313 (string-for-each escape s))
314
315 (define (object->escaped-html obj port)
316 "Write the HTML escaped form of OBJ to PORT."
317 (string->escaped-html
318 (call-with-output-string (cut display obj <>))
319 port))
320
321 (define (attribute-value->html value port)
322 "Write the HTML escaped form of VALUE to PORT."
323 (if (string? value)
324 (string->escaped-html value port)
325 (object->escaped-html value port)))
326
327 (define (attribute->html attr value port)
328 "Write ATTR and VALUE to PORT."
329 (format port "~a=\"" attr)
330 (attribute-value->html value port)
331 (display #\" port))
332
333 (define (element->html tag attrs body port)
334 "Write the HTML TAG to PORT, where TAG has the attributes in the
335 list ATTRS and the child nodes in BODY."
336 (format port "<~a" tag)
337 (for-each (match-lambda
338 ((attr value)
339 (display #\space port)
340 (attribute->html attr value port)))
341 attrs)
342 (if (and (null? body) (self-closing-tag? tag))
343 (display " />" port)
344 (begin
345 (display #\> port)
346 (for-each (cut sxml->html <> port) body)
347 (format port "</~a>" tag))))
348
349 (define (doctype->html doctype port)
350 (format port "<!DOCTYPE ~a>" doctype))
351
352 (define* (sxml->html tree #:optional (port (current-output-port)))
353 "Write the serialized HTML form of TREE to PORT."
354 (match tree
355 (() *unspecified*)
356 (('doctype type)
357 (doctype->html type port))
358 ;; Unescaped, raw HTML output
359 (('raw html)
360 (display html port))
361 (((? symbol? tag) ('@ attrs ...) body ...)
362 (element->html tag attrs body port))
363 (((? symbol? tag) body ...)
364 (element->html tag '() body port))
365 ((nodes ...)
366 (for-each (cut sxml->html <> port) nodes))
367 ((? string? text)
368 (string->escaped-html text port))
369 ;; Render arbitrary Scheme objects, too.
370 (obj (object->escaped-html obj port))))