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