First iteration of sxml->html

5 files changed, 242 insertions, 0 deletions

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 <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/>.
+
 (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 <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/>.
+
 (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 <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/>.
+
 (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 <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/>.
+
+(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"
+    "&lt;b&gt; &amp; &quot; &#39;"
+    (html-encode "<b> & \" '")))
+
+(test-group "sxml->html-document"
+  (let ((doc '(html (body (p "Hello World")))))
+    (test-equal "render simple document"
+      "<!DOCTYPE html><html><body><p>Hello World</p></body></html>"
+      (sxml->html-document doc))))
+
+(test-group "sxml->html"
+  (test-equal "text node"
+    "just text"
+    (sxml->html "just text"))
+
+  (test-equal "simple tag"
+    "<html>text</html>"
+    (sxml->html '(html "text")))
+
+  (test-equal "nested tags"
+    "<div><span>nested</span></div>"
+    (sxml->html '(div (span "nested"))))
+
+  (test-equal "attributes"
+    "<p class=\"text\" id=\"main\">content</p>"
+    (sxml->html '(p (@ (class "text") (id "main")) "content")))
+
+  (test-equal "multiple attributes"
+    "<a href=\"/\" rel=\"nofollow\">link</a>"
+    (sxml->html '(a (@ (href "/") (rel "nofollow")) "link")))
+
+  (test-equal "self-closing tag"
+    "<img src=\"logo.png\">"
+    (sxml->html '(img (@ (src "logo.png")))))
+
+  (test-equal "html-encoded content"
+    "<p>&lt;script&gt;alert(&quot;xss&quot;)&lt;/script&gt;</p>"
+    (sxml->html '(p "<script>alert(\"xss\")</script>")))
+  
+  (test-equal "no encoding for script"
+    "<script>alert(\"1\" > \"2\");</script>"
+    (sxml->html '(script "alert(\"1\" > \"2\");")))
+
+  (test-equal "deep nesting"
+    "<ul><li><ul><li>item</li></ul></li></ul>"
+    (sxml->html '(ul (li (ul (li "item"))))))
+
+  (test-equal "empty non-self-closing tag"
+    "<div></div>"
+    (sxml->html '(div)))
+
+  (test-equal "complex mix"
+    "<article><header><h1>Title</h1></header><p>Text</p></article>"
+    (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 <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
+    '((#\& . "&amp;")
+      (#\< . "&lt;")
+      (#\> . "&gt;")
+      (#\" . "&quot;")
+      (#\' . "&#39;")))
+  (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)))