Add DO-HTML-COND
[mmondor.git] / mmsoftware / cl / server / html.lisp
1 ;;;; $Id: html.lisp,v 1.6 2011/08/27 03:45:50 mmondor Exp $
2
3 #|
4
5 Copyright (c) 2011, Matthew Mondor
6 All rights reserved.
7
8 Redistribution and use in source and binary forms, with or without
9 modification, are permitted provided that the following conditions
10 are met:
11 1. Redistributions of source code must retain the above copyright
12 notice, this list of conditions and the following disclaimer.
13 2. 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
17 THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
18 IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
19 OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
20 IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
21 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
22 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
23 USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24 THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
26 THIS 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 ;;; XXX If SAFETY is 1 compiling code using DO-HTML may segfault!
38 (declaim (optimize (speed 3) (safety 3) (debug 1)))
39
40 (defpackage :html
41 (:use :cl)
42 (:export #:*html-mode*
43 #:do-html
44 #:do-html-loop
45 #:do-html-when
46 #:do-html-unless
47 #:do-html-if
48 #:do-html-cond
49 #:html-escape))
50
51 (in-package :html)
52
53 (defparameter *rcsid*
54 "$Id: html.lisp,v 1.6 2011/08/27 03:45:50 mmondor Exp $")
55
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)
75 (not (keywordp (first item)))
76 (not (stringp (first item)))))))
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)
192 (add (format nil "</~A>" tag))
193 (setf tag nil
194 close-p t))))))
195 out)))
196
197 ;;; Optimizes the tree produced by HTML-PARSE-R, concatenating strings.
198 (defun html-coalesce (list)
199 (let ((out '())
200 (last nil))
201 (mapc
202 #'(lambda (i)
203 (let ((s (stringp i)))
204 (if (and last s)
205 (rplaca out (concatenate 'string (car out) i))
206 (progn
207 (setf last s)
208 (push i out)))))
209 list)
210 (reverse out)))
211
212 (defmacro do-html (stream &body tree)
213 "Utility macro to generate HTML easily from Common Lisp code.
214 At compile time, the supplied TREE template is converted to a list
215 of strings and objects, and the compiler generates code to output the
216 list to the supplied STREAM. Objects are evaluated at runtime by the
217 generated printing code.
218 Note that tags and attributes are represented using keyword symbols and
219 that sublists are used for content. Tags are automatically closed unless
220 the tag keyword symbol begins with a '/'. Likewise, attributes without
221 a value \(such as OPTION's SELECTED attribute\) must also be prefixed with
222 '/', and will be expanded according to *HTML-MODE*. Literal text content
223 should consist of double-quoted strings, and CL atoms and list forms may
224 be used as placeholders for dynamic content to be generated at printing
225 time. Lisp forms are allowed as attribute values or general content.
226 In :XHTML *HTML-MODE*, the necessary bloat is generated for HTML and
227 HEAD, single attributes are expanded redundantly, and non-closing tags
228 are suffixed with ' /', automatically."
229 (let ((list (html-coalesce (reverse (html-parse-r tree))))
230 (s-stream (gensym)))
231 `(let ((*print-pretty* nil))
232 ,(if stream
233 `(let ((,s-stream ,stream))
234 ,@(mapcar #'(lambda (i)
235 (if (stringp i)
236 `(write-string ,i ,s-stream)
237 `(format ,s-stream "~A" ,i)))
238 list)
239 nil)
240 `(with-output-to-string (,s-stream)
241 ,@(mapcar #'(lambda (i)
242 (if (stringp i)
243 `(write-string ,i ,s-stream)
244 `(format ,s-stream "~A" ,i)))
245 list))))))
246
247 (defmacro do-html-loop ((&body loop-clauses) &body body)
248 "This macro provides an easy interface to produce HTML markup with loops.
249 Useful within DO-HTML forms. LOOP-CLAUSES are passed as-is to LOOP and
250 BODY is expected to be an HTML template, and the variables bound by
251 LOOP-CLAUSEs are available for use in the template.
252 The results are returned as a string. Do not forget to use HTML-ESCAPE
253 where appropriate."
254 (let ((s-stream (gensym)))
255 `(with-output-to-string (,s-stream)
256 (loop
257 ,@loop-clauses
258 do
259 (do-html ,s-stream
260 ,@body)))))
261
262 (defmacro do-html-when (condition &body body)
263 "Similar to WHEN, but returns an empty string otherwise, and includes an
264 implicit DO-HTML NIL. For use within DO-HTML forms."
265 `(if ,condition
266 (do-html nil
267 ,@body)
268 ""))
269
270 (defmacro do-html-unless (condition &body body)
271 "Similar to UNLESS, but returns an empty string otherwise, and includes an
272 implicit DO-HTML NIL. For use within DO-HTML forms."
273 `(if (not ,condition)
274 (do-html nil
275 ,@body)
276 ""))
277
278 (defmacro do-html-if (condition do else)
279 `(if ,condition
280 (do-html nil
281 ,do)
282 (do-html nil
283 ,else)))
284
285 (defmacro do-html-cond (&body clauses)
286 `(cond
287 ,@(mapcar #'(lambda (clause)
288 (destructuring-bind (condition &body form) clause
289 `(,condition
290 (do-html nil
291 ,@form))))
292 clauses)))
293
294 (defun html-escape (string)
295 "Returns a fresh copy of STRING which is safe for use within HTML.
296 Note that for simplicity, efficiency and to allow nested DO-HTML forms,
297 user code must explicitely use this function where necessary."
298 ;; A few macros for speed
299 (declare (optimize (speed 3) (safety 0) (debug 0)))
300 (check-type string string)
301 (macrolet ((add-char (c)
302 `(vector-push-extend ,c out 1024))
303 (add-string (s)
304 `(progn
305 ,@(loop
306 for c across s
307 collect `(vector-push-extend ,c out 1024))))
308 (subst-chars (list)
309 `(cond
310 ,@(loop
311 for p in list
312 collect
313 `((char= ,(first p) c) (add-string ,(second p))))
314 (t (add-char c)))))
315 (loop
316 with out = (make-array 1024
317 :element-type 'character
318 :adjustable t
319 :fill-pointer 0)
320 for c of-type character across string
321 do
322 (subst-chars ((#\< "&lt;")
323 (#\> "&gt;")
324 (#\& "&amp;")))
325 finally (return out))))
326
327
328
329 ;;; Tests/Examples
330
331 #+test
332 (defun http-reply (code message &optional description)
333 (let ((title (html-escape (format nil "~A - ~A" code message))))
334 (do-html t
335 (:html (:head (:title title))
336 (:body
337 (:h1 title)
338 (do-html-when description
339 (do-html nil
340 (:p (html-escape description))))
341 (:small
342 (html-escape (format nil "~A/~A"
343 (lisp-implementation-type)
344 (lisp-implementation-version)))))))))
345
346 #+test
347 (defun random-page (&key (trs 10) (tds 10) (rnd 1000))
348 (do-html t
349 (:html (:head (:title "Random page"))
350 (:body
351 (:h1 "Random page")
352 (:table
353 (do-html-loop (repeat trs)
354 (:tr
355 (do-html-loop (repeat tds)
356 (:td (random rnd))))))))))
357
358 #+test
359 (defun results-page (list &key (title "Results"))
360 (let ((title (html-escape title)))
361 (do-html t
362 (:html (:head (:title title))
363 (:body
364 (:h1 title)
365 (:table
366 (do-html-loop (for i in list)
367 (:tr (:td (html-escape (format nil "~S" i)))))))))))