Minor optimization
[mmondor.git] / mmsoftware / cl / server / html.lisp
CommitLineData
d7ce97b7 1;;;; $Id: html.lisp,v 1.2 2011/08/19 11:58:25 mmondor Exp $
0fb29c0d
MM
2
3#|
4
5Copyright (c) 2011, Matthew Mondor
6All rights reserved.
7
8Redistribution and use in source and binary forms, with or without
9modification, are permitted provided that the following conditions
10are met:
111. Redistributions of source code must retain the above copyright
12 notice, this list of conditions and the following disclaimer.
132. Redistributions in binary form must reproduce the above copyright
14 notice, this list of conditions and the following disclaimer in the
15 documentation and/or other materials provided with the distribution.
16
17THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
18IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
19OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
20IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
21INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
22BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
23USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
26THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27
28|#
29
30;;;; html.lisp - HTML template compiler and utilities for Common Lisp
31
32;;;; XXX TODO XXX
33;;;; - Also add a few URL utilities (i.e. to create and properly escape
34;;;; or unescape them).
35
36
37(declaim (optimize (speed 3) (safety 1) (debug 1)))
38
39(defpackage :html
40 (:use :cl)
41 (:export #:*html-mode*
42 #:do-html
43 #:do-html-loop
44 #:html-escape))
45
46(in-package :html)
47
48
49(defparameter *html-mode* :xhtml
50 "Affects the HTML output format; expected values are :XHTML or :HTML.")
51
52
53;;; Given keyword SYMBOL, returns two values: the tag name string and
54;;; a boolean on if the tag should be matched with a closing tag.
55(defun symbol-tag (symbol)
56 (let* ((name (string-downcase (symbol-name symbol)))
57 (not-close-p (char= #\/ (schar name 0)))
58 (tag (if not-close-p (subseq name 1) name)))
59 (values tag (not not-close-p))))
60
61;;; Returns T if we consider ITEM to be Common Lisp to expand at runtime.
62(defun lispp (item)
63 (and (not (keywordp item))
64 (not (stringp item))
65 (or (atom item)
66 (and (listp item)
67 (not (keywordp (first item)))))))
68
69;;; Parses tag and its attributes if any, starting at LIST.
70;;; Returns the tag name, if it must be matched by a closing tag,
71;;; its attributes list as well as the tree position at which to resume
72;;; parsing.
73;;; The returned list is left in reverse-order which is better for our
74;;; caller, HTML-PARSE-R.
75(defun html-tag-parse (list)
76 (macrolet ((add (i)
77 `(push ,i attr)))
78 (let* ((tag nil)
79 (close-p nil)
80 (attr '())
81 (attr-state :symbol)
82 (position
83 (loop
84 for c on list
85 do
86 (block nil
87 (let ((i (car c)))
88
89 ;; Tag itself, init state
90 (when (null tag)
91 (multiple-value-bind (tag-name tag-close-p)
92 (symbol-tag i)
93 (setf tag tag-name
94 close-p tag-close-p)
95 (add (format nil "<~A" tag-name)))
96 (when (and (eq :html i) (eq :xhtml *html-mode*))
97 (add (copy-seq
98 " xmlns=\"http://www.w3.org/1999/xhtml\"")))
99 (return))
100
101 ;; Attributes if any
102 (when (and (eq :symbol attr-state)
103 (keywordp i))
104 (multiple-value-bind (tag-name tag-close-p)
105 (symbol-tag i)
106 (cond ((and (not tag-close-p)
107 (eq :xhtml *html-mode*))
108 (add (format nil " ~A=\"~A\""
109 tag-name tag-name)))
110 (tag-close-p
111 (add (format nil " ~A=" tag-name))
112 (setf attr-state :value))
113 (t
114 (add (format nil " ~A" tag-name)))))
115 (return))
116 (when (and (eq :value attr-state)
117 (or (stringp i)
118 (lispp i)))
119 (cond ((stringp i)
120 (add (format nil "\"~A\"" i)))
121 ((lispp i)
122 (add (copy-seq "\""))
123 (add i)
124 (add (copy-seq "\""))))
125 (setf attr-state :symbol)
126 (return)))
127
128 (loop-finish))
129 finally
130 (progn
131 (add (copy-seq
132 (if (and (eq :xhtml *html-mode*)
133 (not close-p))
134 " />"
135 ">")))
136 (return c)))))
137 (values tag close-p attr position))))
138
139;;; Recursive tree parsing function
140(defun html-parse-r (tree)
141 (macrolet ((add (i)
142 `(push ,i out)))
143 (let ((out '())
144 (tag nil)
145 (close-p t))
146 (loop
147 for c on tree
148 do
149 (block nil
150 (tagbody
151 continue
152 (let ((i (car c))
153 (last-p (null (cdr c))))
154
155 ;; Ready to scan a new tag
156 (when (and (null tag) (keywordp i))
157 (multiple-value-bind (tag-name tag-close-p tag-list pos)
158 (html-tag-parse c)
159 (when (and (eq :html i) (eq :xhtml *html-mode*))
160 (add (copy-seq
161"<?xml version=\"1.0\" encoding=\"UTF-8\"?>
162<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"
163 \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">
164")))
165 (setf out (append tag-list out)
166 tag tag-name
167 close-p tag-close-p
168 c pos)
169 (when (and (eq :head i) (eq :xhtml *html-mode*))
170 (add (copy-seq "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />")))
171 (if c (go continue) (return))))
172
173 ;; Content
174 (cond ((stringp i)
175 (add (copy-seq i)))
176 ((lispp i)
177 (add i))
178 ((listp i)
179 (setf out (append (html-parse-r i) out))))
180
181 ;; Close tag if needed
182 (when (and last-p tag close-p)
183 (add (format nil "</~A>" tag))
184 (setf tag nil
185 close-p t))))))
186 out)))
187
188;;; Optimizes the tree produced by HTML-PARSE-R, concatenating strings.
189(defun html-coalesce (list)
190 (let ((out '())
191 (last nil))
192 (mapc
193 #'(lambda (i)
194 (let ((s (stringp i)))
195 (if (and last s)
196 (rplaca out (concatenate 'string (car out) i))
197 (progn
198 (setf last s)
199 (push i out)))))
200 list)
201 (reverse out)))
202
203(defmacro do-html (stream tree)
204 "Utility macro to generate HTML easily from Common Lisp code.
205At compile time, the supplied TREE template is converted to a list
206of strings and objects, and the compiler generates code to output the
207list to the supplied STREAM. Objects are evaluated at runtime by the
208generated printing code.
209Note that tags and attributes are represented using keyword symbols and
210that sublists are used for content. Tags are automatically closed unless
211the tag keyword symbol begins with a '/'. Likewise, attributes without
212a value (such as OPTION's SELECTED attribute) must also be prefixed with
213'/', and will be expanded according to *HTML-MODE*. Literal text content
214should consist of double-quoted strings, and CL atoms and list forms may
215be used as placeholders for dynamic content to be generated at printing
216time. Lisp forms are allowed as attribute values or general content.
217In :XHTML *HTML-MODE*, the necessary bloat is generated for HTML and
218HEAD, single attributes are expanded redundantly, and non-closing tags
219are suffixed with ' /', automatically."
220 (let ((list (html-coalesce (reverse (html-parse-r tree))))
221 (s-stream (gensym)))
222 (if stream
223 `(let ((,s-stream ,stream))
224 ,@(mapcar #'(lambda (i)
225 (if (stringp i)
226 `(write-string ,i ,s-stream)
227 `(format ,s-stream "~A" ,i)))
228 list)
229 nil)
230 `(with-output-to-string (,s-stream)
231 ,@(mapcar #'(lambda (i)
232 (if (stringp i)
233 `(write-string ,i ,s-stream)
234 `(format ,s-stream "~A" ,i)))
235 list)))))
236
237(defmacro do-html-loop ((&body loop-clauses) &body body)
238 "This macro provides an easy interface to produce HTML markup with loops.
239Useful within DO-HTML forms. LOOP-CLAUSES are passed as-is to LOOP and
240BODY is expected to be an HTML template, and the variables bound by
241LOOP-CLAUSEs are available for use in the template.
242The results are returned as a string. Do not forget to use HTML-ESCAPE
243where appropriate."
244 (let ((s-stream (gensym)))
245 `(with-output-to-string (,s-stream)
246 (loop
247 ,@loop-clauses
248 do
249 (do-html ,s-stream
250 ,@body)))))
251
252(defun html-escape (string)
253 "Returns a fresh copy of STRING which is safe for use within HTML.
254Note that for simplicity, efficiency and to allow nested DO-HTML forms,
255user code must explicitely use this function where necessary."
256 ;; A few macros for speed
d7ce97b7
MM
257 (declare (optimize (speed 3) (safety 0) (debug 0)))
258 (check-type string string)
0fb29c0d
MM
259 (macrolet ((add-char (c)
260 `(vector-push-extend ,c out 1024))
261 (add-string (s)
262 `(progn
263 ,@(loop
264 for c across s
265 collect `(vector-push-extend ,c out 1024))))
266 (subst-chars (list)
267 `(cond
268 ,@(loop
269 for p in list
270 collect
271 `((char= ,(first p) c) (add-string ,(second p))))
272 (t (add-char c)))))
273 (loop
274 with out = (make-array 1024
275 :element-type 'character
276 :adjustable t
277 :fill-pointer 0)
278 for c of-type character across string
279 do
280 (subst-chars ((#\< "&lt;")
281 (#\> "&gt;")
282 (#\& "&amp;")))
283 finally (return out))))
284
285
286
287;;; Tests/Examples
288
289#+test
290(defun http-reply (code message &optional description)
291 (let ((title (html-escape (format nil "~A - ~A" code message))))
292 (do-html t
293 (:html (:head (:title title))
294 (:body
295 (:h1 title)
296 (if description
297 (do-html nil
298 (:p (html-escape description)))
299 "")
300 (:small
301 (html-escape (format nil "~A/~A"
302 (lisp-implementation-type)
303 (lisp-implementation-version)))))))))
304
305#+test
306(defun random-page (&key (trs 10) (tds 10) (rnd 1000))
307 (do-html t
308 (:html (:head (:title "Random page"))
309 (:body
310 (:h1 "Random page")
311 (:table
312 (do-html-loop (repeat trs)
313 (:tr
314 (do-html-loop (repeat tds)
315 (:td (random rnd))))))))))
316
317#+test
318(defun results-page (list &key (title "Results"))
319 (let ((title (html-escape title)))
320 (do-html t
321 (:html (:head (:title title))
322 (:body
323 (:h1 title)
324 (:table
325 (do-html-loop (for i in list)
326 (:tr (:td (html-escape (format nil "~S" i)))))))))))