Initial import in server of an HTML template compiler
authorMatthew Mondor <mmondor@pulsar-zone.net>
Fri, 19 Aug 2011 11:48:25 +0000 (11:48 +0000)
committerMatthew Mondor <mmondor@pulsar-zone.net>
Fri, 19 Aug 2011 11:48:25 +0000 (11:48 +0000)
mmsoftware/cl/server/html.lisp [new file with mode: 0644]

diff --git a/mmsoftware/cl/server/html.lisp b/mmsoftware/cl/server/html.lisp
new file mode 100644 (file)
index 0000000..2bcf4d8
--- /dev/null
@@ -0,0 +1,324 @@
+;;;; $Id: html.lisp,v 1.1 2011/08/19 11:48:25 mmondor Exp $
+
+#|
+
+Copyright (c) 2011, Matthew Mondor
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
+USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+|#
+
+;;;; html.lisp - HTML template compiler and utilities for Common Lisp
+
+;;;; XXX TODO XXX
+;;;; - Also add a few URL utilities (i.e. to create and properly escape
+;;;;   or unescape them).
+
+
+(declaim (optimize (speed 3) (safety 1) (debug 1)))
+
+(defpackage :html
+  (:use :cl)
+  (:export #:*html-mode*
+          #:do-html
+          #:do-html-loop
+          #:html-escape))
+
+(in-package :html)
+
+
+(defparameter *html-mode* :xhtml
+  "Affects the HTML output format; expected values are :XHTML or :HTML.")
+
+
+;;; Given keyword SYMBOL, returns two values: the tag name string and
+;;; a boolean on if the tag should be matched with a closing tag.
+(defun symbol-tag (symbol)
+  (let* ((name (string-downcase (symbol-name symbol)))
+        (not-close-p (char= #\/ (schar name 0)))
+        (tag (if not-close-p (subseq name 1) name)))
+    (values tag (not not-close-p))))
+
+;;; Returns T if we consider ITEM to be Common Lisp to expand at runtime.
+(defun lispp (item)
+  (and (not (keywordp item))
+       (not (stringp item))
+       (or (atom item)
+          (and (listp item)
+               (not (keywordp (first item)))))))
+
+;;; Parses tag and its attributes if any, starting at LIST.
+;;; Returns the tag name, if it must be matched by a closing tag,
+;;; its attributes list as well as the tree position at which to resume
+;;; parsing.
+;;; The returned list is left in reverse-order which is better for our
+;;; caller, HTML-PARSE-R.
+(defun html-tag-parse (list)
+  (macrolet ((add (i)
+              `(push ,i attr)))
+    (let* ((tag nil)
+          (close-p nil)
+          (attr '())
+          (attr-state :symbol)
+          (position
+           (loop
+              for c on list
+              do
+              (block nil
+                (let ((i (car c)))
+
+                  ;; Tag itself, init state
+                  (when (null tag)
+                    (multiple-value-bind (tag-name tag-close-p)
+                        (symbol-tag i)
+                      (setf tag tag-name
+                            close-p tag-close-p)
+                      (add (format nil "<~A" tag-name)))
+                    (when (and (eq :html i) (eq :xhtml *html-mode*))
+                      (add (copy-seq
+                            " xmlns=\"http://www.w3.org/1999/xhtml\"")))
+                    (return))
+
+                  ;; Attributes if any
+                  (when (and (eq :symbol attr-state)
+                             (keywordp i))
+                    (multiple-value-bind (tag-name tag-close-p)
+                        (symbol-tag i)
+                      (cond ((and (not tag-close-p)
+                                  (eq :xhtml *html-mode*))
+                             (add (format nil " ~A=\"~A\""
+                                          tag-name tag-name)))
+                            (tag-close-p
+                             (add (format nil " ~A=" tag-name))
+                             (setf attr-state :value))
+                            (t
+                             (add (format nil " ~A" tag-name)))))
+                    (return))
+                  (when (and (eq :value attr-state)
+                             (or (stringp i)
+                                 (lispp i)))
+                    (cond ((stringp i)
+                           (add (format nil "\"~A\"" i)))
+                          ((lispp i)
+                           (add (copy-seq "\""))
+                           (add i)
+                           (add (copy-seq "\""))))
+                    (setf attr-state :symbol)
+                    (return)))
+
+                (loop-finish))
+              finally
+                (progn
+                  (add (copy-seq
+                        (if (and (eq :xhtml *html-mode*)
+                                 (not close-p))
+                            " />"
+                            ">")))
+                  (return c)))))
+      (values tag close-p attr position))))
+
+;;; Recursive tree parsing function
+(defun html-parse-r (tree)
+  (macrolet ((add (i)
+              `(push ,i out)))
+    (let ((out '())
+         (tag nil)
+         (close-p t))
+      (loop
+        for c on tree
+        do
+        (block nil
+          (tagbody
+           continue
+             (let ((i (car c))
+                   (last-p (null (cdr c))))
+
+               ;; Ready to scan a new tag
+               (when (and (null tag) (keywordp i))
+                 (multiple-value-bind (tag-name tag-close-p tag-list pos)
+                     (html-tag-parse c)
+                   (when (and (eq :html i) (eq :xhtml *html-mode*))
+                     (add (copy-seq
+"<?xml version=\"1.0\" encoding=\"UTF-8\"?>
+<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"
+ \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">
+")))
+                   (setf out (append tag-list out)
+                         tag tag-name
+                         close-p tag-close-p
+                         c pos)
+                   (when (and (eq :head i) (eq :xhtml *html-mode*))
+                     (add (copy-seq "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />")))
+                   (if c (go continue) (return))))
+
+               ;; Content
+               (cond ((stringp i)
+                      (add (copy-seq i)))
+                     ((lispp i)
+                      (add i))
+                     ((listp i)
+                      (setf out (append (html-parse-r i) out))))
+
+               ;; Close tag if needed
+               (when (and last-p tag close-p)
+                 (add (format nil "</~A>" tag))
+                 (setf tag nil
+                       close-p t))))))
+      out)))
+
+;;; Optimizes the tree produced by HTML-PARSE-R, concatenating strings.
+(defun html-coalesce (list)
+  (let ((out '())
+       (last nil))
+    (mapc
+     #'(lambda (i)
+         (let ((s (stringp i)))
+              (if (and last s)
+                         (rplaca out (concatenate 'string (car out) i))
+                                (progn
+                                   (setf last s)
+                                    (push i out)))))
+     list)
+    (reverse out)))
+
+(defmacro do-html (stream tree)
+  "Utility macro to generate HTML easily from Common Lisp code.
+At compile time, the supplied TREE template is converted to a list
+of strings and objects, and the compiler generates code to output the
+list to the supplied STREAM.  Objects are evaluated at runtime by the
+generated printing code.
+Note that tags and attributes are represented using keyword symbols and
+that sublists are used for content.  Tags are automatically closed unless
+the tag keyword symbol begins with a '/'.  Likewise, attributes without
+a value (such as OPTION's SELECTED attribute) must also be prefixed with
+'/', and will be expanded according to *HTML-MODE*.  Literal text content
+should consist of double-quoted strings, and CL atoms and list forms may
+be used as placeholders for dynamic content to be generated at printing
+time.  Lisp forms are allowed as attribute values or general content.
+In :XHTML *HTML-MODE*, the necessary bloat is generated for HTML and
+HEAD, single attributes are expanded redundantly, and non-closing tags
+are suffixed with ' /', automatically."
+  (let ((list (html-coalesce (reverse (html-parse-r tree))))
+       (s-stream (gensym)))
+    (if stream
+       `(let ((,s-stream ,stream))
+          ,@(mapcar #'(lambda (i)
+                        (if (stringp i)
+                            `(write-string ,i ,s-stream)
+                            `(format ,s-stream "~A" ,i)))
+                    list)
+          nil)
+       `(with-output-to-string (,s-stream)
+          ,@(mapcar #'(lambda (i)
+                        (if (stringp i)
+                            `(write-string ,i ,s-stream)
+                            `(format ,s-stream "~A" ,i)))
+                    list)))))
+
+(defmacro do-html-loop ((&body loop-clauses) &body body)
+  "This macro provides an easy interface to produce HTML markup with loops.
+Useful within DO-HTML forms.  LOOP-CLAUSES are passed as-is to LOOP and
+BODY is expected to be an HTML template, and the variables bound by
+LOOP-CLAUSEs are available for use in the template.
+The results are returned as a string.  Do not forget to use HTML-ESCAPE
+where appropriate."
+  (let ((s-stream (gensym)))
+    `(with-output-to-string (,s-stream)
+       (loop
+         ,@loop-clauses
+         do
+           (do-html ,s-stream
+             ,@body)))))
+
+(defun html-escape (string)
+  "Returns a fresh copy of STRING which is safe for use within HTML.
+Note that for simplicity, efficiency and to allow nested DO-HTML forms,
+user code must explicitely use this function where necessary."
+  ;; A few macros for speed
+  (macrolet ((add-char (c)
+              `(vector-push-extend ,c out 1024))
+            (add-string (s)
+              `(progn
+                 ,@(loop
+                      for c across s
+                      collect `(vector-push-extend ,c out 1024))))
+            (subst-chars (list)
+              `(cond
+                 ,@(loop
+                      for p in list
+                      collect
+                        `((char= ,(first p) c) (add-string ,(second p))))
+                 (t (add-char c)))))
+    (loop
+       with out = (make-array 1024
+                             :element-type 'character
+                             :adjustable t
+                             :fill-pointer 0)
+       for c of-type character across string
+       do
+        (subst-chars ((#\< "&lt;")
+                      (#\> "&gt;")
+                      (#\& "&amp;")))
+       finally (return out))))
+
+
+
+;;; Tests/Examples
+
+#+test
+(defun http-reply (code message &optional description)
+  (let ((title (html-escape (format nil "~A - ~A" code message))))
+    (do-html t
+      (:html (:head (:title title))
+            (:body
+             (:h1 title)
+             (if description
+                 (do-html nil
+                   (:p (html-escape description)))
+                 "")
+             (:small
+              (html-escape (format nil "~A/~A"
+                                   (lisp-implementation-type)
+                                   (lisp-implementation-version)))))))))
+
+#+test
+(defun random-page (&key (trs 10) (tds 10) (rnd 1000))
+  (do-html t
+    (:html (:head (:title "Random page"))
+          (:body
+           (:h1 "Random page")
+           (:table
+            (do-html-loop (repeat trs)
+              (:tr
+               (do-html-loop (repeat tds)
+                 (:td (random rnd))))))))))
+
+#+test
+(defun results-page (list &key (title "Results"))
+  (let ((title (html-escape title)))
+    (do-html t
+      (:html (:head (:title title))
+            (:body
+             (:h1 title)
+             (:table
+              (do-html-loop (for i in list)
+                (:tr (:td (html-escape (format nil "~S" i)))))))))))