blob: b51abbce9b5ff1690f5391996c91f04369136f94 (
plain)
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
|
;;; Weeb --- Web microframework for GNU Guile
;;; Copyright © 2026 Jakob Kreuze <zerodaysfordays@sdf.org>
;;;
;;; This file is part of Weeb.
;;;
;;; Weeb is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU Affero General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; Weeb 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 Affero General
;;; Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with Weeb. If not, see <https://www.gnu.org/licenses/>.
(define-module (weeb sxml)
#:use-module (ice-9 match)
#:use-module (ice-9 string-fun)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (sxml->html
sxml->html-document))
(define (self-closing? tag-name)
(memq tag-name '(img br hr input)))
(define (emit-raw? tag-name)
(memq tag-name '(style script)))
(define (sxml-tag? elt)
(match elt
((_tag-name ('@ _attr ...) _content ...) #t)
((_tag-name _content ...) #t)
(_ #f)))
(define (extract-tag-name tag)
(first tag))
(define (extract-attributes tag)
(match tag
((_tag-name ('@ attrs ...) _content ...) attrs)
(_ '())))
(define (extract-children tag)
(match tag
((_tag-name ('@ _attrs ...) content ...) content)
((_tag-name content ...) content)
(_ '())))
;; TODO: We should probably encode other entities as well, but there are
;; hundreds, so we need a more efficient way of substituting first.
(define (html-encode str)
(define %entities
'((#\& . "&")
(#\< . "<")
(#\> . ">")
(#\" . """)
(#\' . "'")))
(define (iter s replace)
(match replace
(((char . entity) rest ...)
(iter (string-replace-substring s (string char) entity) rest))
(() s)))
(iter str %entities))
(define (emit-sxml-tree tree)
(match tree
((? sxml-tag?)
(let ((tag-name (extract-tag-name tree)))
(display "<")
(display tag-name)
(for-each (match-lambda
((key value)
(display " ")
(display key)
(display "=\"")
(display value)
(display "\"")))
(extract-attributes tree))
(display ">")
(unless (self-closing? tag-name)
(if (emit-raw? tag-name)
(display (second tree))
(for-each emit-sxml-tree (extract-children tree)))
(display "</")
(display tag-name)
(display ">"))))
((? string?) (begin (display (html-encode tree))))
((? number?) (begin (display tree)))))
(define (emit-sxml-document document)
(display "<!DOCTYPE html>")
(emit-sxml-tree document))
(define (sxml->html tree)
(with-output-to-string (cut emit-sxml-tree tree)))
(define (sxml->html-document tree)
(with-output-to-string (cut emit-sxml-document tree)))
|
© 2015 - 2026 Jakob L. Kreuze
