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