Link to test-httpd.lisp's /chat
[mmondor.git] / mmsoftware / cl / server / html.lisp
CommitLineData
2ceabfee 1;;;; $Id: html.lisp,v 1.8 2011/09/09 15:52:33 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
ee5b6ae3
MM
37;;; XXX If SAFETY is 1 compiling code using DO-HTML may segfault!
38(declaim (optimize (speed 3) (safety 3) (debug 1)))
0fb29c0d
MM
39
40(defpackage :html
41 (:use :cl)
42 (:export #:*html-mode*
43 #:do-html
44 #:do-html-loop
b8d52993
MM
45 #:do-html-when
46 #:do-html-unless
d6cb5819 47 #:do-html-if
1cce9d74 48 #:do-html-cond
0fb29c0d
MM
49 #:html-escape))
50
51(in-package :html)
52
ee5b6ae3 53(defparameter *rcsid*
2ceabfee 54 "$Id: html.lisp,v 1.8 2011/09/09 15:52:33 mmondor Exp $")
ee5b6ae3 55
0fb29c0d
MM
56
57(defparameter *html-mode* :xhtml
58 "Affects the HTML output format; expected values are :XHTML or :HTML.")
59
60
61;;; Given keyword SYMBOL, returns two values: the tag name string and
62;;; a boolean on if the tag should be matched with a closing tag.
63(defun symbol-tag (symbol)
64 (let* ((name (string-downcase (symbol-name symbol)))
65 (not-close-p (char= #\/ (schar name 0)))
66 (tag (if not-close-p (subseq name 1) name)))
67 (values tag (not not-close-p))))
68
69;;; Returns T if we consider ITEM to be Common Lisp to expand at runtime.
70(defun lispp (item)
71 (and (not (keywordp item))
72 (not (stringp item))
73 (or (atom item)
74 (and (listp item)
ee5b6ae3
MM
75 (not (keywordp (first item)))
76 (not (stringp (first item)))))))
0fb29c0d
MM
77
78;;; Parses tag and its attributes if any, starting at LIST.
79;;; Returns the tag name, if it must be matched by a closing tag,
80;;; its attributes list as well as the tree position at which to resume
81;;; parsing.
82;;; The returned list is left in reverse-order which is better for our
83;;; caller, HTML-PARSE-R.
84(defun html-tag-parse (list)
85 (macrolet ((add (i)
86 `(push ,i attr)))
87 (let* ((tag nil)
88 (close-p nil)
89 (attr '())
90 (attr-state :symbol)
91 (position
92 (loop
93 for c on list
94 do
95 (block nil
96 (let ((i (car c)))
97
98 ;; Tag itself, init state
99 (when (null tag)
100 (multiple-value-bind (tag-name tag-close-p)
101 (symbol-tag i)
102 (setf tag tag-name
103 close-p tag-close-p)
104 (add (format nil "<~A" tag-name)))
105 (when (and (eq :html i) (eq :xhtml *html-mode*))
106 (add (copy-seq
107 " xmlns=\"http://www.w3.org/1999/xhtml\"")))
108 (return))
109
110 ;; Attributes if any
111 (when (and (eq :symbol attr-state)
112 (keywordp i))
113 (multiple-value-bind (tag-name tag-close-p)
114 (symbol-tag i)
115 (cond ((and (not tag-close-p)
116 (eq :xhtml *html-mode*))
117 (add (format nil " ~A=\"~A\""
118 tag-name tag-name)))
119 (tag-close-p
120 (add (format nil " ~A=" tag-name))
121 (setf attr-state :value))
122 (t
123 (add (format nil " ~A" tag-name)))))
124 (return))
125 (when (and (eq :value attr-state)
126 (or (stringp i)
127 (lispp i)))
128 (cond ((stringp i)
129 (add (format nil "\"~A\"" i)))
130 ((lispp i)
131 (add (copy-seq "\""))
132 (add i)
133 (add (copy-seq "\""))))
134 (setf attr-state :symbol)
135 (return)))
136
137 (loop-finish))
138 finally
139 (progn
140 (add (copy-seq
141 (if (and (eq :xhtml *html-mode*)
142 (not close-p))
143 " />"
144 ">")))
145 (return c)))))
146 (values tag close-p attr position))))
147
148;;; Recursive tree parsing function
149(defun html-parse-r (tree)
150 (macrolet ((add (i)
151 `(push ,i out)))
152 (let ((out '())
153 (tag nil)
154 (close-p t))
155 (loop
156 for c on tree
157 do
158 (block nil
159 (tagbody
160 continue
161 (let ((i (car c))
162 (last-p (null (cdr c))))
163
164 ;; Ready to scan a new tag
165 (when (and (null tag) (keywordp i))
166 (multiple-value-bind (tag-name tag-close-p tag-list pos)
167 (html-tag-parse c)
168 (when (and (eq :html i) (eq :xhtml *html-mode*))
169 (add (copy-seq
170"<?xml version=\"1.0\" encoding=\"UTF-8\"?>
171<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"
172 \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">
173")))
174 (setf out (append tag-list out)
175 tag tag-name
176 close-p tag-close-p
177 c pos)
178 (when (and (eq :head i) (eq :xhtml *html-mode*))
179 (add (copy-seq "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />")))
180 (if c (go continue) (return))))
181
182 ;; Content
183 (cond ((stringp i)
184 (add (copy-seq i)))
185 ((lispp i)
186 (add i))
187 ((listp i)
188 (setf out (append (html-parse-r i) out))))
189
190 ;; Close tag if needed
191 (when (and last-p tag close-p)
9b7bce70
MM
192 (add (if (string-equal "html" tag)
193 (format nil "</~A>~%" tag)
194 (format nil "</~A>" tag)))
0fb29c0d
MM
195 (setf tag nil
196 close-p t))))))
197 out)))
198
199;;; Optimizes the tree produced by HTML-PARSE-R, concatenating strings.
200(defun html-coalesce (list)
201 (let ((out '())
202 (last nil))
203 (mapc
204 #'(lambda (i)
205 (let ((s (stringp i)))
206 (if (and last s)
207 (rplaca out (concatenate 'string (car out) i))
208 (progn
209 (setf last s)
210 (push i out)))))
211 list)
212 (reverse out)))
213
b8d52993 214(defmacro do-html (stream &body tree)
0fb29c0d
MM
215 "Utility macro to generate HTML easily from Common Lisp code.
216At compile time, the supplied TREE template is converted to a list
217of strings and objects, and the compiler generates code to output the
218list to the supplied STREAM. Objects are evaluated at runtime by the
219generated printing code.
220Note that tags and attributes are represented using keyword symbols and
221that sublists are used for content. Tags are automatically closed unless
222the tag keyword symbol begins with a '/'. Likewise, attributes without
ee5b6ae3 223a value \(such as OPTION's SELECTED attribute\) must also be prefixed with
0fb29c0d
MM
224'/', and will be expanded according to *HTML-MODE*. Literal text content
225should consist of double-quoted strings, and CL atoms and list forms may
226be used as placeholders for dynamic content to be generated at printing
227time. Lisp forms are allowed as attribute values or general content.
228In :XHTML *HTML-MODE*, the necessary bloat is generated for HTML and
229HEAD, single attributes are expanded redundantly, and non-closing tags
230are suffixed with ' /', automatically."
231 (let ((list (html-coalesce (reverse (html-parse-r tree))))
232 (s-stream (gensym)))
ee5b6ae3
MM
233 `(let ((*print-pretty* nil))
234 ,(if stream
235 `(let ((,s-stream ,stream))
236 ,@(mapcar #'(lambda (i)
237 (if (stringp i)
238 `(write-string ,i ,s-stream)
239 `(format ,s-stream "~A" ,i)))
240 list)
241 nil)
242 `(with-output-to-string (,s-stream)
243 ,@(mapcar #'(lambda (i)
244 (if (stringp i)
245 `(write-string ,i ,s-stream)
246 `(format ,s-stream "~A" ,i)))
247 list))))))
0fb29c0d
MM
248
249(defmacro do-html-loop ((&body loop-clauses) &body body)
250 "This macro provides an easy interface to produce HTML markup with loops.
251Useful within DO-HTML forms. LOOP-CLAUSES are passed as-is to LOOP and
252BODY is expected to be an HTML template, and the variables bound by
253LOOP-CLAUSEs are available for use in the template.
254The results are returned as a string. Do not forget to use HTML-ESCAPE
255where appropriate."
256 (let ((s-stream (gensym)))
257 `(with-output-to-string (,s-stream)
258 (loop
259 ,@loop-clauses
260 do
261 (do-html ,s-stream
262 ,@body)))))
263
b8d52993
MM
264(defmacro do-html-when (condition &body body)
265 "Similar to WHEN, but returns an empty string otherwise, and includes an
266implicit DO-HTML NIL. For use within DO-HTML forms."
267 `(if ,condition
268 (do-html nil
269 ,@body)
270 ""))
271
272(defmacro do-html-unless (condition &body body)
273 "Similar to UNLESS, but returns an empty string otherwise, and includes an
274implicit DO-HTML NIL. For use within DO-HTML forms."
275 `(if (not ,condition)
276 (do-html nil
277 ,@body)
278 ""))
279
d6cb5819
MM
280(defmacro do-html-if (condition do else)
281 `(if ,condition
282 (do-html nil
283 ,do)
284 (do-html nil
285 ,else)))
286
1cce9d74
MM
287(defmacro do-html-cond (&body clauses)
288 `(cond
289 ,@(mapcar #'(lambda (clause)
290 (destructuring-bind (condition &body form) clause
291 `(,condition
292 (do-html nil
293 ,@form))))
294 clauses)))
295
0fb29c0d
MM
296(defun html-escape (string)
297 "Returns a fresh copy of STRING which is safe for use within HTML.
298Note that for simplicity, efficiency and to allow nested DO-HTML forms,
299user code must explicitely use this function where necessary."
300 ;; A few macros for speed
d7ce97b7
MM
301 (declare (optimize (speed 3) (safety 0) (debug 0)))
302 (check-type string string)
0fb29c0d
MM
303 (macrolet ((add-char (c)
304 `(vector-push-extend ,c out 1024))
305 (add-string (s)
306 `(progn
307 ,@(loop
308 for c across s
309 collect `(vector-push-extend ,c out 1024))))
310 (subst-chars (list)
311 `(cond
312 ,@(loop
313 for p in list
314 collect
315 `((char= ,(first p) c) (add-string ,(second p))))
316 (t (add-char c)))))
317 (loop
318 with out = (make-array 1024
319 :element-type 'character
320 :adjustable t
321 :fill-pointer 0)
322 for c of-type character across string
323 do
324 (subst-chars ((#\< "&lt;")
325 (#\> "&gt;")
2ceabfee
MM
326 (#\& "&amp;")
327 (#\U00A0 "&nbsp;")))
0fb29c0d
MM
328 finally (return out))))
329
330
331
332;;; Tests/Examples
333
334#+test
335(defun http-reply (code message &optional description)
336 (let ((title (html-escape (format nil "~A - ~A" code message))))
337 (do-html t
338 (:html (:head (:title title))
339 (:body
340 (:h1 title)
b8d52993
MM
341 (do-html-when description
342 (do-html nil
343 (:p (html-escape description))))
0fb29c0d
MM
344 (:small
345 (html-escape (format nil "~A/~A"
346 (lisp-implementation-type)
347 (lisp-implementation-version)))))))))
348
349#+test
350(defun random-page (&key (trs 10) (tds 10) (rnd 1000))
351 (do-html t
352 (:html (:head (:title "Random page"))
353 (:body
354 (:h1 "Random page")
355 (:table
356 (do-html-loop (repeat trs)
357 (:tr
358 (do-html-loop (repeat tds)
359 (:td (random rnd))))))))))
360
361#+test
362(defun results-page (list &key (title "Results"))
363 (let ((title (html-escape title)))
364 (do-html t
365 (:html (:head (:title title))
366 (:body
367 (:h1 title)
368 (:table
369 (do-html-loop (for i in list)
370 (:tr (:td (html-escape (format nil "~S" i)))))))))))