Fix CL-WHO attr bugs: no escaping, poor constant handling.

CL-WHO tries to handle the case when attribute values are
constant NIL and T values, but it bungles it; it applies
the correct behavior only when the constants are literally
these symbols, not when they are constant expressions
which evaluate to these values.

Secondly, CL-WHO neglects to HTML-escape attribute values.
We fix this behavior and introduce a noesc operator to
selectively revert it, as well as a *cl-who-compat* special
to revert the behavior more pervasively, for the daredevils.

* packages.tl (tl-who): New symbols *cl-who-compat* and noesc.

* specials.tl (*cl-who-compat*): New special variable.

* who.tl (convert-attributes): When treating a constant
expression, evaluate it first, then check for nil or t.
Escape interpolated text with html-encode.
Check the original expression for (noesc ...) pattern,
or the presence of *cl-who-compat*. In these cases, don't
generate the escape call.

* test/simple.tl: New tests 28 to 37 providing some coverage
to all these changes.

* README.md: Document.

5 files changed, 150 insertions, 20 deletions

diff --git a/README.md b/README.md
index 71d6773..b443472 100644
--- a/README.md
+++ b/README.md
@@ -139,6 +139,48 @@ Here are the differences to be aware of:
     The binding construct `expander-let` must be used, or else the
     variable's global binding must be assigned.
 
+*   CL-WHO has some bugs around attribute handling. When the value of an
+    attribute is a constant expression, only the specific values `T`
+    and `NIL` are treated properly, not constant expressions which evaluate
+    to `T` and `NIL`. Then we see the mistaken attribute values `'NIL` and `'T'`:
+    This works properly in TL-WHO:
+
+        ::text
+        [1]> (in-package :cl-who)
+        #<PACKAGE CL-WHO>
+        WHO[2]> (with-html-output-to-string (str)
+                  (:foo :bar t))
+        "<foo bar='bar'></foo>"
+        WHO[3]> (with-html-output-to-string (str)
+                  (:foo :bar (quote t)))
+        "<foo bar='T'></foo>"
+        WHO[4]> (with-html-output-to-string (str)
+                  (:foo :bar nil))
+        "<foo></foo>"
+        WHO[5]> (with-html-output-to-string (str)
+                  (:foo :bar 'nil))
+        "<foo bar='NIL'></foo>"
+
+*   TL-WHO fixes the issue that CL-WHO doesn't HTML-escape the values of
+    attributes, and that its local macro `fmt` likewise doesn't escape.
+    This is a potential security issue, because if an untrusted value
+    is interpolated, it can be a vector for an injection attack.
+    The special variable `*cl-who-compat*` can be set true to disable the
+    escaping, but is not recommended.
+
+        ::text
+        [1]> (in-package :cl-who)
+        #<PACKAGE CL-WHO>
+        WHO[2]> (with-html-output-to-string (out)
+                  (:a :href "https://example.com'>malicious here</a><a href='blah" "click me"))
+        "<a href='https://example.com'>malicious here</a><a href='blah'>click me</a>"
+
+*   TL-WHO provides a `noesc` syntax. When the value of an attribute is
+    expressed as `(noesc <expr>)`, escaping is disabled:
+
+        ::text
+        (:a :href (noesc trusted-url) "click me")
+
 Additionally, users (of CL-WHO and TL-WHO alike) are advised to watch for the
 following issue: the CL-WHO documentation is not accurately maintained and
 makes some references to material that no longer exists in CL-WHO, such as the
diff --git a/packages.tl b/packages.tl
index eb62f6a..55c867c 100644
--- a/packages.tl
+++ b/packages.tl
@@ -34,6 +34,7 @@
           "*html-no-indent-tags*"
           "*html-empty-tags*"
           "*html-empty-tag-aware-p*"
+          "*cl-who-compat*"
           "conc"
           "convert-attributes"
           "convert-tag-to-string-list"
@@ -42,6 +43,7 @@
           "htm"
           "html-mode"
           "str"
+          "noesc"
           "with-html-output"
           "with-html-output-to-string"))
 
diff --git a/specials.tl b/specials.tl
index e743e1b..941bdf4 100644
--- a/specials.tl
+++ b/specials.tl
@@ -113,5 +113,13 @@
 ;; <tag></tag>
 (defvar *html-empty-tag-aware-p* t)
 
+;; Change certain TL-WHO behaviors to original CL-WHO behaviors. These
+;; are behaviors TL-WHO changed in order to improve the security.
+;; TL-WHO performs implicit HTML escaping on the output of the
+;; expressions that calculate attribute values. TL-WHO's fmt function
+;; also escapes the formatted output. If this varaible is twrue, these
+;; behaviors revert to the CL-WHO behaviors of not escaping.
+(defvar *cl-who-compat* nil)
+
 ;; Used for indentation.
 (defconstant +newline+ "\n")
diff --git a/test/simple.tl b/test/simple.tl
index 374bc7e..7645901 100644
--- a/test/simple.tl
+++ b/test/simple.tl
@@ -361,3 +361,72 @@
        <div>\n              \
        \  <p>Bar</p>\n      \
        </div>")
+
+;;; TL-WHO Tests
+
+;;; 28
+;;; Test that non-constant t attribute value treated same as constant t.
+(test (let ((attr-val t))
+        (with-html-output-to-string (out)
+          (:foo :bar attr-val)))
+      "<foo bar='bar'></foo>")
+
+;;; 29
+;;; Test that non-constant nil attribute value treated same as constant t.
+(test (let ((attr-val nil))
+        (with-html-output-to-string (out)
+          (:foo :bar attr-val)))
+      "<foo></foo>")
+
+;;; 30
+;;; Test that complex constant evaluating to t is treated right.
+(test (with-html-output-to-string (out)
+        (:foo :bar (quote t)))
+      "<foo bar='bar'></foo>")
+
+;;; 31
+;;; Test that complex constant nil attribute value treated right.
+(test (with-html-output-to-string (out)
+        (:foo :bar (quote nil)))
+      "<foo></foo>")
+
+;;; 32
+;;; Test that we escape a constant string attribute properly.
+(test (with-html-output-to-string (out)
+         (:foo :bar "'blah<tag>"))
+      "<foo bar='&#39;blah&lt;tag&gt;'></foo>")
+
+;;; 33
+;;; Test that we escape a non-constant string attribute properly.
+(test (let ((attr-val "'blah<tag>"))
+        (with-html-output-to-string (out)
+          (:foo :bar attr-val)))
+      "<foo bar='&#39;blah&lt;tag&gt;'></foo>")
+
+;;; 34
+;;; Test that noesc works for constant.
+(test (with-html-output-to-string (out)
+         (:foo :bar (noesc "'blah<tag>")))
+      "<foo bar=''blah<tag>'></foo>")
+
+;;; 35
+;;; Test that noesc works for non-constant.
+(test (let ((attr-val "'blah<tag>"))
+       (with-html-output-to-string (out)
+         (:foo :bar (noesc attr-val))))
+      "<foo bar=''blah<tag>'></foo>")
+
+;;; 36
+;;; Test that *cl-who-compat* defeats escaping for constant.
+(test (expander-let ((*cl-who-compat* t))
+        (with-html-output-to-string (out)
+          (:foo :bar (noesc "'blah<tag>"))))
+      "<foo bar=''blah<tag>'></foo>")
+
+;;; 37
+;;; Test that *cl-who-compat* defeats escaping for non-constant.
+(test (expander-let ((*cl-who-compat* t))
+        (let ((attr-val "'blah<tag>"))
+          (with-html-output-to-string (out)
+            (:foo :bar (noesc attr-val)))))
+      "<foo bar=''blah<tag>'></foo>")
diff --git a/who.tl b/who.tl
index 2683450..3c4a440 100644
--- a/who.tl
+++ b/who.tl
@@ -92,26 +92,35 @@
   (with-gensyms (=var=)
     (let ((aqc *attribute-quote-char*))
       (keep-matches (^(,orig-attr . ,val) attr-list)
-        (let ((attr (maybe-upcase orig-attr)))
-          (if val
-            (if (constantp val)
-              ;; Handle constant attribute value at macro time
-              (if (and *empty-attribute-syntax* (eq val t))
-                ` @attr`
-                ` @attr=@aqc@(if (eq val t)
-                               attr
-                               (tostringp (eval val)))@aqc`)
-              ;; For non-constant, do the same things as above but at runtime
-              ^(let ((,=var= ,val))
-                 (cond
-                   ((null ,=var=))
-                   ((eq ,=var= t)
-                    (str ,(if *empty-attribute-syntax*
-                            ^` @,attr`
-                            ^` @,attr=@,aqc@,attr@,aqc`)))
-                   (t
-                     (str ` @,attr=@,aqc@{,=var=}@,aqc`)))))))))))
-
+        (let ((attr (maybe-upcase orig-attr))
+              noesc)
+          (when-match (noesc . @rest) val
+            (set noesc t)
+            (set val ^(progn ,*rest)))
+          (if (constantp val)
+            ;; Handle constant attribute value at macro time
+            (let ((eval (eval val)))
+              (cond
+                ((null eval))
+                ((eq eval t)
+                 (if *empty-attribute-syntax*
+                   ` @attr`
+                   ` @attr=@aqc@attr@aqc`))
+                ((or noesc *cl-who-compat*) ;; no escaping in CL-WHO compat mode
+                  ` @attr=@aqc@(tostringp eval)@aqc`)
+                (t ` @attr=@aqc@(html-encode (tostringp eval))@aqc`)))
+            ;; For non-constant, do the same things as above but at runtime
+            ^(let ((,=var= ,val))
+               (cond
+                 ((null ,=var=))
+                 ((eq ,=var= t)
+                  (str ,(if *empty-attribute-syntax*
+                          ^` @,attr`
+                          ^` @,attr=@,aqc@,attr@,aqc`)))
+                 (t
+                   ,(if (or noesc *cl-who-compat*)
+                      ^(str ` @,attr=@,aqc@{,=var=}@,aqc`)
+                      ^(str ` @,attr=@,aqc@(html-encode ,=var=)@,aqc`)))))))))))
 
 ;; Used by process-tag to convert `HTML' into a list
 ;; of strings.  tag is a keyword symbol naming the outer tag, attr-list