Many developments towards a real HTTP server
[mmondor.git] / mmsoftware / cl / server / html.lisp
CommitLineData
ee5b6ae3 1;;;; $Id: html.lisp,v 1.4 2011/08/27 00:47:53 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
0fb29c0d
MM
47 #:html-escape))
48
49(in-package :html)
50
ee5b6ae3
MM
51(defparameter *rcsid*
52 "$Id: html.lisp,v 1.4 2011/08/27 00:47:53 mmondor Exp $")
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)
190 (add (format nil "</~A>" tag))
191 (setf tag nil
192 close-p t))))))
193 out)))
194
195;;; Optimizes the tree produced by HTML-PARSE-R, concatenating strings.
196(defun html-coalesce (list)
197 (let ((out '())
198 (last nil))
199 (mapc
200 #'(lambda (i)
201 (let ((s (stringp i)))
202 (if (and last s)
203 (rplaca out (concatenate 'string (car out) i))
204 (progn
205 (setf last s)
206 (push i out)))))
207 list)
208 (reverse out)))
209
b8d52993 210(defmacro do-html (stream &body tree)
0fb29c0d
MM
211 "Utility macro to generate HTML easily from Common Lisp code.
212At compile time, the supplied TREE template is converted to a list
213of strings and objects, and the compiler generates code to output the
214list to the supplied STREAM. Objects are evaluated at runtime by the
215generated printing code.
216Note that tags and attributes are represented using keyword symbols and
217that sublists are used for content. Tags are automatically closed unless
218the tag keyword symbol begins with a '/'. Likewise, attributes without
ee5b6ae3 219a value \(such as OPTION's SELECTED attribute\) must also be prefixed with
0fb29c0d
MM
220'/', and will be expanded according to *HTML-MODE*. Literal text content
221should consist of double-quoted strings, and CL atoms and list forms may
222be used as placeholders for dynamic content to be generated at printing
223time. Lisp forms are allowed as attribute values or general content.
224In :XHTML *HTML-MODE*, the necessary bloat is generated for HTML and
225HEAD, single attributes are expanded redundantly, and non-closing tags
226are suffixed with ' /', automatically."
227 (let ((list (html-coalesce (reverse (html-parse-r tree))))
228 (s-stream (gensym)))
ee5b6ae3
MM
229 `(let ((*print-pretty* nil))
230 ,(if stream
231 `(let ((,s-stream ,stream))
232 ,@(mapcar #'(lambda (i)
233 (if (stringp i)
234 `(write-string ,i ,s-stream)
235 `(format ,s-stream "~A" ,i)))
236 list)
237 nil)
238 `(with-output-to-string (,s-stream)
239 ,@(mapcar #'(lambda (i)
240 (if (stringp i)
241 `(write-string ,i ,s-stream)
242 `(format ,s-stream "~A" ,i)))
243 list))))))
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
0fb29c0d
MM
276(defun html-escape (string)
277 "Returns a fresh copy of STRING which is safe for use within HTML.
278Note that for simplicity, efficiency and to allow nested DO-HTML forms,
279user code must explicitely use this function where necessary."
280 ;; A few macros for speed
d7ce97b7
MM
281 (declare (optimize (speed 3) (safety 0) (debug 0)))
282 (check-type string string)
0fb29c0d
MM
283 (macrolet ((add-char (c)
284 `(vector-push-extend ,c out 1024))
285 (add-string (s)
286 `(progn
287 ,@(loop
288 for c across s
289 collect `(vector-push-extend ,c out 1024))))
290 (subst-chars (list)
291 `(cond
292 ,@(loop
293 for p in list
294 collect
295 `((char= ,(first p) c) (add-string ,(second p))))
296 (t (add-char c)))))
297 (loop
298 with out = (make-array 1024
299 :element-type 'character
300 :adjustable t
301 :fill-pointer 0)
302 for c of-type character across string
303 do
304 (subst-chars ((#\< "&lt;")
305 (#\> "&gt;")
306 (#\& "&amp;")))
307 finally (return out))))
308
309
310
311;;; Tests/Examples
312
313#+test
314(defun http-reply (code message &optional description)
315 (let ((title (html-escape (format nil "~A - ~A" code message))))
316 (do-html t
317 (:html (:head (:title title))
318 (:body
319 (:h1 title)
b8d52993
MM
320 (do-html-when description
321 (do-html nil
322 (:p (html-escape description))))
0fb29c0d
MM
323 (:small
324 (html-escape (format nil "~A/~A"
325 (lisp-implementation-type)
326 (lisp-implementation-version)))))))))
327
328#+test
329(defun random-page (&key (trs 10) (tds 10) (rnd 1000))
330 (do-html t
331 (:html (:head (:title "Random page"))
332 (:body
333 (:h1 "Random page")
334 (:table
335 (do-html-loop (repeat trs)
336 (:tr
337 (do-html-loop (repeat tds)
338 (:td (random rnd))))))))))
339
340#+test
341(defun results-page (list &key (title "Results"))
342 (let ((title (html-escape title)))
343 (do-html t
344 (:html (:head (:title title))
345 (:body
346 (:h1 title)
347 (:table
348 (do-html-loop (for i in list)
349 (:tr (:td (html-escape (format nil "~S" i)))))))))))