From c73384a44ee8e559414741d8034b47359723d196 Mon Sep 17 00:00:00 2001
From: Bo Yao <byao@mymakecents.com>
Date: Thu, 28 Jun 2018 10:09:21 -0400
Subject: [PATCH] escape and minify for production

---
 README.md        |  5 ++-
 flute.asd        |  4 ++-
 src/flute.lisp   | 92 ++++++++++++++----------------------------------
 src/package.lisp | 31 ++++++++++++++++
 src/util.lisp    | 72 +++++++++++++++++++++++++++++++++++++
 5 files changed, 136 insertions(+), 68 deletions(-)
 create mode 100644 src/package.lisp
 create mode 100644 src/util.lisp

diff --git a/README.md b/README.md
index e4b5b47..14cbab7 100644
--- a/README.md
+++ b/README.md
@@ -9,7 +9,10 @@
 
 # Usage
 
-[Examples of usage]
+## Minify for production
+```lisp
+(write root-element :pretty nil)
+```
 
 # License
 
diff --git a/flute.asd b/flute.asd
index e3948fa..b0e2ba5 100644
--- a/flute.asd
+++ b/flute.asd
@@ -5,7 +5,9 @@
   :components ((:module "src"
                 :serial t
                 :components
-                ((:file "flute"))))
+                ((:file "package")
+                 (:file "util")
+                 (:file "flute"))))
   :description "A beautiful, easilly composable html generation library"
   :long-description
   #.(uiop:read-file-string
diff --git a/src/flute.lisp b/src/flute.lisp
index 2f269ca..b539778 100644
--- a/src/flute.lisp
+++ b/src/flute.lisp
@@ -1,33 +1,3 @@
-(in-package :cl-user)
-(defpackage flute
-  (:use :cl)
-  (:import-from :assoc-utils
-                :alist
-                :alistp
-                :hash-alist
-                :aget
-                :delete-from-alistf)
-  (:import-from :let-over-lambda
-                :defmacro!
-                :mkstr
-                :flatten)
-  (:import-from :alexandria
-                :make-keyword)
-  (:export
-   ;; all html5 elements, e.g. div, nav, media, export in code
-   ;; except <time> and <map> conflicts with cl symbol, are defined and exported as |time|, |map|
-   :define-element
-   :attrs
-   :attrs-alist
-   :make-attrs
-   :copy-attrs
-   :html
-   :element-tag
-   :element-attrs
-   :element-children
-   :user-element-expand-to
-   :*expand-user-element*
-   :h))
 (in-package :flute)
 
 (defclass element ()
@@ -48,16 +18,36 @@
   ((expand-to :initarg :expand-to
               :accessor user-element-expand-to)))
 
-(defun make-builtin-element (&rest args &key tag attrs children)
-  (apply #'make-instance 'builtin-element args))
+(defun make-builtin-element (&key tag attrs children)
+  (make-instance 'builtin-element :tag tag :attrs attrs
+                 :children (escape-children children)))
 
-(defun make-builtin-element-with-prefix (&rest args &key tag attrs children prefix)
-  (apply #'make-instance 'builtin-element-with-prefix args))
+(defun make-builtin-element-with-prefix (&key tag attrs children prefix)
+  (make-instance 'builtin-element-with-prefix :tag tag :attrs attrs :prefix prefix
+                 :children (escape-children children)))
 
 (defun make-user-element (&rest args &key tag attrs children expand-to)
-  (apply #'make-instance 'user-element args))
+  (make-instance 'user-element :tag tag :attrs attrs :expand-to expand-to
+                 :children (escape-children children)))
 
-(defstruct attrs alist)
+(defstruct (attrs (:constructor %make-attrs))
+  alist)
+
+(defvar *escape-html* :utf8
+  "Specify the escape option when generate html, can be :UTF8, :ASCII, :ATTR or NIL.
+If :UTF8, escape only #\<, #\> and #\& in body, and \" in attribute keys. #\' will
+in attribute keys will not be escaped since flute will always use double quote for
+attribute keys.
+If :ASCII, besides what escaped in :UTF8, also escape all non-ascii characters.
+If :ATTR, only #\" in attribute values will be escaped.
+If NIL, nothing is escaped and programmer is responsible to escape elements properly.
+When given :ASCII and :ATTR, it's possible to insert html text as a children, e.g.
+(div :id \"container\" \"Some <b>text</b>\")")
+
+(defun make-attrs (&keys alist)
+  (if *escape-html*
+      (%make-attrs :alist (escape-attrs-alist alist))
+      (%make-attrs :alist alist)))
 
 (defmethod (setf attr) (value (attrs attrs) key)
   (setf (aget (attrs-alist) key) value))
@@ -101,16 +91,6 @@
     (t
      (values (make-attrs :alist nil) (flatten attrs-and-children)))))
 
-(defun plist-alist (plist)
-  (loop for (k v) on plist by #'cddr
-     collect (cons k v)))
-
-(defun alist-plist* (alist)
-  (mapcan (lambda (kv)
-            (list (string-downcase (car kv))
-                  (cdr kv)))
-          alist))
-
 (defvar *builtin-elements* (make-hash-table))
 
 (defun html (&rest attrs-and-children)
@@ -192,26 +172,6 @@
                     stream)
       (call-next-method)))
 
-(defun tree-leaves%% (tree test result)
-  (if tree
-    (if (listp tree)
-      (cons
-        (tree-leaves%% (car tree) test result)
-        (tree-leaves%% (cdr tree) test result))
-      (if (funcall test tree)
-        (funcall result tree)
-        tree))))
-
-(defmacro tree-leaves (tree test result)
-  `(tree-leaves%%
-     ,tree
-     (lambda (x)
-       (declare (ignorable x))
-       ,test)
-     (lambda (x)
-       (declare (ignorable x))
-       ,result)))
-
 (defmacro h (&body body)
   `(progn
      ,@(tree-leaves
diff --git a/src/package.lisp b/src/package.lisp
new file mode 100644
index 0000000..78d3206
--- /dev/null
+++ b/src/package.lisp
@@ -0,0 +1,31 @@
+(in-package :cl-user)
+(defpackage flute
+  (:use :cl)
+  (:import-from :assoc-utils
+                :alist
+                :alistp
+                :hash-alist
+                :aget
+                :delete-from-alistf)
+  (:import-from :let-over-lambda
+                :defmacro!
+                :mkstr
+                :flatten)
+  (:import-from :alexandria
+                :make-keyword)
+  (:export
+   ;; all html5 elements, e.g. div, nav, media, export in code except
+   ;; <time> and <map> conflicts with cl symbol, are defined and
+   ;; exported as |time|, |map|
+   :define-element
+   :attrs
+   :attrs-alist
+   :make-attrs
+   :copy-attrs
+   :html
+   :element-tag
+   :element-attrs
+   :element-children
+   :user-element-expand-to
+   :*expand-user-element*
+   :h))
diff --git a/src/util.lisp b/src/util.lisp
new file mode 100644
index 0000000..27035e3
--- /dev/null
+++ b/src/util.lisp
@@ -0,0 +1,72 @@
+(in-package :flute)
+
+(defun plist-alist (plist)
+  (loop for (k v) on plist by #'cddr
+     collect (cons k v)))
+
+(defun alist-plist* (alist)
+  (mapcan (lambda (kv)
+            (list (string-downcase (car kv))
+                  (cdr kv)))
+          alist))
+
+(defun tree-leaves%% (tree test result)
+  (if tree
+    (if (listp tree)
+      (cons
+        (tree-leaves%% (car tree) test result)
+        (tree-leaves%% (cdr tree) test result))
+      (if (funcall test tree)
+        (funcall result tree)
+        tree))))
+
+(defmacro tree-leaves (tree test result)
+  `(tree-leaves%%
+     ,tree
+     (lambda (x)
+       (declare (ignorable x))
+       ,test)
+     (lambda (x)
+       (declare (ignorable x))
+       ,result)))
+
+(defun utf8-html-escape-char-p (char)
+  (find char "<>&"))
+
+(defun ascii-html-escape-char-p (char)
+  (or (utf8-html-escape-char-p char)
+      (> (char-code char) 127)))
+
+(defun attr-value-escape-char-p (char)
+  (eql char #\"))
+
+(defun escape-char (char)
+  (case char
+    (#\< "&lt;")
+    (#\> "&gt;")
+    (#\& "&amp;")
+    (#\' "&#039;")
+    (#\" "&quot;")
+    (t (format nil "&#~d;" (char-code char)))))
+
+(defun escape-string (string &optional (test #'utf8-html-escape-char-p))
+  (with-output-to-string (s)
+    (loop
+       for c across string
+       do (write (if (funcall test c) (escape-char c) c) :stream s :escape nil))))
+
+(defun escape-attrs-alist (alist)
+  (mapcar (lambda (kv)
+            (cons (car kv)
+                  (escape-string (cdr kv) #'attr-value-escape-char-p)))
+          alist))
+
+(defun escape-children (children)
+  (mapcar (lambda (child)
+            (if (stringp child)
+                (case *escape-html*
+                  (:utf8 (escape-string child))
+                  (:ascii (escape-string child #'ascii-html-escape-char-p))
+                  (otherwise child))
+                child))
+          children))