From 993c263d29afcd8ea52064d1e886a4d759e88f8f Mon Sep 17 00:00:00 2001 From: Jakob L. Kreuze Date: Sat, 11 Jul 2026 15:09:00 -0400 Subject: First iteration of sxml->html --- tests/response.scm | 18 ++++++++++ tests/router.scm | 18 ++++++++++ tests/struct.scm | 18 ++++++++++ tests/sxml.scm | 87 +++++++++++++++++++++++++++++++++++++++++++++ weeb/sxml.scm | 101 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 242 insertions(+) create mode 100644 tests/sxml.scm create mode 100644 weeb/sxml.scm diff --git a/tests/response.scm b/tests/response.scm index e382169..2e36ba3 100644 --- a/tests/response.scm +++ b/tests/response.scm @@ -1,3 +1,21 @@ +;;; Weeb --- Web microframework for GNU Guile +;;; Copyright © 2026 Jakob Kreuze +;;; +;;; 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 . + (use-modules (srfi srfi-64) (weeb response) (weeb struct)) diff --git a/tests/router.scm b/tests/router.scm index 6f1ddfb..59ec793 100644 --- a/tests/router.scm +++ b/tests/router.scm @@ -1,3 +1,21 @@ +;;; Weeb --- Web microframework for GNU Guile +;;; Copyright © 2026 Jakob Kreuze +;;; +;;; 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 . + (use-modules (srfi srfi-11) (srfi srfi-64) (weeb router) diff --git a/tests/struct.scm b/tests/struct.scm index 7662fed..01c984d 100644 --- a/tests/struct.scm +++ b/tests/struct.scm @@ -1,3 +1,21 @@ +;;; Weeb --- Web microframework for GNU Guile +;;; Copyright © 2026 Jakob Kreuze +;;; +;;; 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 . + (use-modules (srfi srfi-64) (weeb struct)) diff --git a/tests/sxml.scm b/tests/sxml.scm new file mode 100644 index 0000000..569fae1 --- /dev/null +++ b/tests/sxml.scm @@ -0,0 +1,87 @@ +;;; Weeb --- Web microframework for GNU Guile +;;; Copyright © 2026 Jakob Kreuze +;;; +;;; 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 . + +(use-modules (srfi srfi-64) + (weeb sxml)) + +;; Private imports for testing purposes. +(define html-encode + (@@ (weeb sxml) html-encode)) + +(test-runner-current (test-runner-simple)) + +(test-begin "weeb-sxml") + +(test-group "html-encode" + (test-equal "encode simple text" "hello" (html-encode "hello")) + (test-equal "encode special characters" + "<b> & " '" + (html-encode " & \" '"))) + +(test-group "sxml->html-document" + (let ((doc '(html (body (p "Hello World"))))) + (test-equal "render simple document" + "

Hello World

" + (sxml->html-document doc)))) + +(test-group "sxml->html" + (test-equal "text node" + "just text" + (sxml->html "just text")) + + (test-equal "simple tag" + "text" + (sxml->html '(html "text"))) + + (test-equal "nested tags" + "
nested
" + (sxml->html '(div (span "nested")))) + + (test-equal "attributes" + "

content

" + (sxml->html '(p (@ (class "text") (id "main")) "content"))) + + (test-equal "multiple attributes" + "link" + (sxml->html '(a (@ (href "/") (rel "nofollow")) "link"))) + + (test-equal "self-closing tag" + "" + (sxml->html '(img (@ (src "logo.png"))))) + + (test-equal "html-encoded content" + "

<script>alert("xss")</script>

" + (sxml->html '(p ""))) + + (test-equal "no encoding for script" + "" + (sxml->html '(script "alert(\"1\" > \"2\");"))) + + (test-equal "deep nesting" + "
    • item
" + (sxml->html '(ul (li (ul (li "item")))))) + + (test-equal "empty non-self-closing tag" + "
" + (sxml->html '(div))) + + (test-equal "complex mix" + "

Title

Text

" + (sxml->html '(article (header (h1 "Title")) (p "Text"))))) + +(test-end) diff --git a/weeb/sxml.scm b/weeb/sxml.scm new file mode 100644 index 0000000..b51abbc --- /dev/null +++ b/weeb/sxml.scm @@ -0,0 +1,101 @@ +;;; Weeb --- Web microframework for GNU Guile +;;; Copyright © 2026 Jakob Kreuze +;;; +;;; 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 . + +(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 "")))) + ((? string?) (begin (display (html-encode tree)))) + ((? number?) (begin (display tree))))) + +(define (emit-sxml-document document) + (display "") + (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))) -- cgit v1.3