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