-
Notifications
You must be signed in to change notification settings - Fork 0
/
cgi.lisp
578 lines (500 loc) · 16.3 KB
/
cgi.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
;#!/usr/local/bin/clisp
;;
; NAME: cgi.lisp
;
; STARTED: 010722
; MODIFICATIONS:
;
; PURPOSE:
;
;
;
; CALLING SEQUENCE:
;
;
; INPUTS:
;
; OUTPUTS:
;
; EXAMPLE:
;
; NOTES:
;
;;
(load "utils.lisp")
;;;;
;;;; HTML tag functions
;;;;
(defconstant background-color "#CCDDFF")
(defconstant text-color "#000000")
;;;
;;; Main paired-tag function. First element of content list may be optional
;;; list of attributes.
;;;
(defun make-tag (tag content)
(let ((attributes-list (if (listp (car content))
(pop content)
nil)))
(format nil "<~A~A>~A</~A>" tag
(make-attributes attributes-list)
(join content)
tag)) )
;;;
;;; XHTML-compliant for standalone tags.
;;;
(defun make-solo-tag (tag content)
(let ((attributes-list (if (listp (car content))
(pop content)
nil)))
(format nil "<~A~A />" tag
(make-attributes attributes-list))) )
;;;
;;; Create string of attributes/values for an HTML tag. The attributes, if
;;; any, are expected to come in a list of keywords and values. A keyword
;;; is expected to be paired with a value string or number following it. If a
;;; keyword is followed by another keyword (or by nothing), the first is
;;; assumed to be one of the few standalone attributes such as CHECKED,
;;; SELECTED, or NOSHADE. In such a case, the value of the attribute is
;;; simply the attribute itself to comply with the XHTML standard.
;;;
;;; Any empty string following a keyword causes that keyword to be removed
;;; from the final attributes string.
;;;
;;; Example: '(:border 1 :nowrap :width "80%")
;;; -> "border=\"1\" nowrap=\"nowrap\" width=\"80%\""
;;;
(defun make-attributes (attributes-list &optional (attributes-string ""))
(cond ((null attributes-list) attributes-string)
((not (keywordp (car attributes-list))) 'missing-keyword)
((or (keywordp (cadr attributes-list)) ;No value to go with keyword.
(null (cdr attributes-list)))
(make-attributes (cdr attributes-list)
(concatenate 'string
attributes-string
(format nil
" ~(~A~)=\"~:*~(~A~)\""
(car attributes-list)))) )
(t
(make-attributes (cddr attributes-list)
(concatenate 'string
attributes-string
(if (equal (cadr attributes-list) "")
""
(format nil
" ~(~A~)=\"~A\""
(car attributes-list)
(cadr attributes-list)))) ))) )
; (defun h1 (&optional (text ""))
; (format nil "<h1>~A</h1>" text) )
(defun html (&rest content)
(make-tag "html" content) )
(defun head (&rest content)
(make-tag "head" content) )
(defun title (&rest content)
(make-tag "title" content) )
(defun meta (&rest content)
(make-solo-tag "meta" content) )
;;;
;;; Get comments correct here.
;;; Only add the comment strings if there is actual content for the tag.
;;; If the only arg is a list of attributes, don't add comments.
;;;
(defun style (&rest content)
(apply #'style-script "style" content))
(defun script (&rest content)
(apply #'style-script "script" content))
(let ((open-comment (format nil "<!--~%"))
(close-comment "//-->"))
(defun style-script (tag-name &rest content)
(cond ((listp (car content))
(if (cdr content)
(let ((attributes (pop content)))
(push open-comment content)
(push attributes content))))
(content (push open-comment content)))
(make-tag tag-name (if (cdr content)
(append content
(list close-comment))
content))))
(defun body (&rest content)
(cond ((listp (car content))
(unless (member :bgcolor (car content))
(push background-color (car content))
(push :bgcolor (car content)))
(unless (member :text (car content))
(push text-color (car content))
(push :text (car content)))
(make-tag "body" content))
(t (make-tag "body" (cons (list :bgcolor background-color
:text text-color)
content)))) )
(defun div (&rest content)
(make-tag "div" content) )
(defun span (&rest content)
(make-tag "span" content) )
;;;
;;; Table tags
;;;
; (defun table (&rest args)
; ; &key (border "" border-flag) (width "" width-flag)
; ; (height "" height-flag) (cellpadding "" pad-flag)
; ; (cellspacing "" space-flag) (align "" align-flag)
; ; (bgcolor "" bgcolor-flag) &allow-other-keys)
; (let ((border (or (second (member :border args)) ""))
; (width (or (second (member :width args)) ""))
; (height (or (second (member :height args)) ""))
; (cellpadding (or (second (member :cellpadding args)) ""))
; (cellspacing (or (second (member :cellspacing args)) ""))
; (align (or (second (member :align args)) ""))
; (bgcolor (or (second (member :bgcolor args)) "")))
; ; (border (if border-flag
; ; (format nil " border=\"~A\"" border)
; ; border))
; ; (width (if width-flag
; ; (format nil " width=\"~A\"" width)
; ; width))
; ; (height (if height-flag
; ; (format nil " height=\"~A\"" height)
; ; height))
; ; (cellpadding (if pad-flag
; ; (format nil " cellpadding=\"~A\"" cellpadding)
; ; cellpadding))
; ; (cellspacing (if space-flag
; ; (format nil " cellspacing=\"~A\"" cellspacing)
; ; cellspacing))
; ; (align (if align-flag
; ; (format nil " align=\"~A\"" align)
; ; align))
; ; (bgcolor (if bgcolor-flag
; ; (format nil " bgcolor=\"~A\"" bgcolor)
; ; bgcolor)))
; (format nil "<table~A~A~A~A~A~A~A>~A</table>" border width height
; cellpadding cellspacing align bgcolor args))
; (format t "~A~%" args))
; (defun table (&rest table-content)
; (format nil "<table~A>~A</table>"
; (join (make-attributes (remove-if-not #'listp table-content)))
; (join (remove-if #'listp table-content))) )
; (defun tr (&rest row-content)
; (format nil "<tr~A>~A</tr>"
; (join (make-attributes (remove-if-not #'listp row-content)))
; (join (remove-if #'listp row-content))) )
; (defun td (&rest cell-content)
; (format nil "<td~A>~A</td>"
; (join (make-attributes (remove-if-not #'listp cell-content)))
; (join (remove-if #'listp cell-content))) )
; (defun strong (&optional (text ""))
; (format nil "<strong>~A</strong>" text) )
(defun table (&rest content)
(make-tag "table" content) )
(defun tr (&rest content)
(make-tag "tr" content) )
(defun th (&rest content)
(make-tag "th" content) )
(defun td (&rest content)
(make-tag "td" content) )
(defun h1 (&rest content)
(make-tag "h1" content) )
(defun h2 (&rest content)
(make-tag "h2" content) )
(defun ul (&rest content)
(make-tag "ul" content) )
(defun li (&rest content)
(make-tag "li" content) )
(defun strong (&rest content)
(make-tag "strong" content) )
(defun em (&rest content)
(make-tag "em" content) )
(defun u (&rest content)
(make-tag "u" content))
(defun sup (&rest content)
(make-tag "sup" content) )
(defun sub (&rest content)
(make-tag "sub" content) )
(defun p (&rest content)
(make-tag "p" content) )
(defun a (&rest content)
(make-tag "a" content) )
(defun font (&rest content)
(make-tag "font" content) )
(defun img (&rest content)
(make-solo-tag "img" content) )
(defun hr (&rest content)
(make-solo-tag "hr" content) )
(defun br (&rest content)
(make-solo-tag "br" content) )
;;;
;;; !?????????????????
;;;
(defun -- (&rest content)
(make-solo-tag "!--" content) )
;;;
;;; Form tags
;;;
(defun form (&rest content)
(make-tag "form" content) )
(defun input (&rest content)
(make-solo-tag "input" content) )
; (defun start-form (&key (method "" method-flag) (action "" action-flag)
; (name "" name-flag))
; (let ((action (if action-flag
; (format nil " action=\"~A\"" action)
; action))
; (name (if name-flag
; (format nil " name=\"~A\"" name)
; name))
; (method (if method-flag
; (format nil " method=\"~A\"" method)
; method)))
; (format nil "<form~A~A~A>" name method action)) )
; (defun end-form ()
; (format nil "</form>") )
; (defun textfield (&key (name "" name-flag))
; (let ((name (if name-flag
; (format nil " name=\"~A\"" name)
; name)))
; (format nil "<input type=\"text\"~A>" name)) )
; (defun submit (&key (name "" name-flag) (value "" value-flag))
; (let ((name (if name-flag
; (format nil " name=\"~A\"" name)
; name))
; (value (if value-flag
; (format nil " value=\"~A\"" value)
; value)))
; (format nil "<input type=\"submit\"~A~A>" name value)) )
; (defun textfield (&rest content)
; (make-solo-tag "input" (cons '(type "text") content)) )
; (defun submit (&rest content)
; (make-solo-tag "input" (cons '(type "submit") content)) )
;;;
;;; Get form data from either POST or GET request.
;;; Returns an association list, where the car of each sublist is
;;; the name of some form element and the cdr contains the value(s)
;;; for the element. (Checkboxes may have multiple values associated
;;; with a single element.) All names/values are strings.
;;;
;;; If no form data have been submitted, then FORM-DATA-RAW will either
;;; be an empty string or NIL.
;;;
; (defun get-form-data ()
; (let ((form-data-raw (cond ((equal (system::getenv "REQUEST_METHOD") "GET")
; (system::getenv "QUERY_STRING"))
; ((equal (system::getenv "REQUEST_METHOD") "POST")
; (read-post-data)))) )
; (cond ((or (null form-data-raw)
; (string= form-data-raw ""))
; nil)
; (t (let ((form-fields (split form-data-raw #\&)))
; (let ((form-values (mapcar #'(lambda (s)
; (split s #\=))
; form-fields)))
; (consolidate (uri-unencode form-values)))) ))) )
;;;
;;; These probably only work in CLISP.
;;;
(defun get-request-method ()
(getenv "REQUEST_METHOD"))
(defun get-query-string ()
(getenv "QUERY_STRING"))
(defun get-form-data ()
(let* ((request-method (get-request-method))
; (let* ((request-method (find-request-method))
(form-data-raw (cond ((equal request-method "GET")
(get-query-string))
((equal request-method "POST")
(read-post-data))
(t nil)))
(form-data (make-hash-table :test #'equal)))
(cond ((or (null form-data-raw)
(string= form-data-raw ""))
nil)
(t (let ((key-value-a-list
(mapcar #'(lambda (s)
(split s #\=))
(split form-data-raw #\&))))
(dolist (pair key-value-a-list form-data)
(let ((key (uri-unencode (car pair)))
(value (uri-unencode (cadr pair))))
(multiple-value-bind (form-value flag)
(gethash key form-data)
(if flag
(if (listp form-value)
(push value (gethash key form-data))
(setf (gethash key form-data)
(list value form-value)))
(setf (gethash key form-data) value)))) )))) ))
(defun get-content-length ()
(let ((content-length (or (getenv "CONTENT_LENGTH") "0")))
(parse-integer content-length)))
;;;
;;; This is pretty retarded...
;;; Isn't there some way to just read N bytes from a stream?!
;;;
; (defun read-post-data (&optional (s nil) (n (read-from-string (system::getenv "CONTENT_LENGTH"))))
; (cond ((zerop n) (coerce (reverse s) 'string))
; (t (read-post-data (cons (read-char) s) (- n 1)))) )
(defun read-post-data ()
(let* ((data (make-string (get-content-length)))
(content-read (read-sequence data *standard-input*)))
(if (= content-read (get-content-length))
data
nil)))
(let ((safe '(#\- #\_ #\. #\! #\~ #\* #\' #\( #\))))
(defun encode-string (s)
(cond ((string= s "") "")
(t (let ((ch (character (subseq s 0 1))))
(cond ((or (char-not-greaterp #\A ch #\Z)
(char<= #\0 ch #\9)
(member ch safe))
(concatenate 'string (list ch) (encode-string (subseq s 1))))
(t (concatenate 'string (format nil "%~2X" (char-code ch))
(encode-string (subseq s 1)))) )))) ))
#|
$toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
Netscape 4.7/6 encode all of $mark chars but '-', '_', '.', and '*'
$mark = q(-_.!~*'()); #'; emacs
$unreserved = "A-Za-z0-9\Q$mark\E";
$uric = quotemeta($reserved) . $unreserved . "%";
|#
;;;
;;; Unencode an a-list of pairs of form elements and their associated
;;; values.
;;;
(defun uri-unencode (a-list)
(labels ((unencode-aux (l)
(list (unencode-string (car l))
(unencode-string (cadr l))))
(unencode-string (s)
(unhexify (substitute #\Space #\+ s))))
(let ((result ()))
(dolist (pair a-list (nreverse result))
(push (unencode-aux pair) result)))) )
;;;
;;; Convert each sequence of '%XX' in a string into its corresponding
;;; character. The 'XX' is assumed to represent a hexadecimal integer.
;;; If it isn't actually a hex number, the sequence is converted to a
;;; space.
;;;
(defun unhexify (s)
(let ((pos (position #\% s)))
(cond ((null pos) s)
(t (concatenate 'string
(subseq s 0 pos)
(string (code-char
(or (parse-integer s
:radix 16
:start (+ pos 1)
:end (+ pos 3)
:junk-allowed t)
(char-code #\Space))))
(unhexify (subseq s (+ pos 3)))) ))) )
(defun uri-unencode (s)
(let ((pos (position #\% s)))
(cond ((null pos) s)
(t (concatenate 'string
(subseq s 0 pos)
(string (code-char
(or (parse-integer s
:radix 16
:start (+ pos 1)
:end (+ pos 3)
:junk-allowed t)
(char-code #\Space))))
(uri-unencode (subseq s (+ pos 3)))) ))) )
;;;
;;; Consolidate an association list (of strings) so that all values
;;; associated with a given key are placed in the same sublist.
;;;
;;; E.g., ((a 1) (b 2) (a 3) (c 4) (b 5) (a 6)) -> ((a 1 3 6) (b 2 5) (c 4))
;;;
(defun consolidate (a-list)
(cond ((null a-list) nil)
((member (caar a-list) (cdr a-list) :key #'car :test #'equal)
(cons (remove nil
(append (car a-list)
(mapcar #'(lambda (l) ;(remove nil) is safe since we
;assume elements are strings?
;; If a sublist contains the
;; current key as its key return
;; the second element. Otherwise
;; return nil.
(if (equal (caar a-list) (car l))
(cadr l)
nil))
(cdr a-list))))
(consolidate (remove (caar a-list) (cdr a-list) :key #'car :test #'equal))))
(t (cons (car a-list) (consolidate (cdr a-list)))) ) )
;;;
;;; Get the value of a given parameter or return names of all parameters.
;;; Assumes FORM-DATA is an a-list where keys/vals are strings. Thus, if
;;; no val is found for a given key return empty string rather than empty
;;; list: "" vs. nil.
;;;
(defun param (form-data &optional field-name)
(cond (field-name (or (second (assoc field-name form-data :test #'equal))
""))
(t (mapcar #'first form-data))) )
(defun display-form-data (form-data-a-list)
(table '(border 0) '(cellspacing 0)
(tr
(th '(colspan 3) '(bgcolor "#EEEEEE") "Submitted Form Data"))
(tr
(td '(align "center") '(bgcolor "red") "Form Field")
(td '(bgcolor "red") " ")
(td '(align "center") '(bgcolor "yellow") "Value"))
(form-data-rows form-data-a-list)))
(defun form-data-rows (form-data-a-list)
(join (mapcar #'(lambda (x)
(tr
(td '(align "right") '(bgcolor "red")
(font '(color "blue") (car x)))
(td '(bgcolor "red") "=")
(td '(align "left") '(bgcolor "yellow")
(strong "[ " (join (cdr x) ", ") " ]")) ))
form-data-a-list)) )
(defun output-html (html-tags)
(dolist (tag html-tags)
(format t "~A~%" (eval tag))) )
;;;
;;; Generic HTML header.
;;;
(defun start-html (&optional (mime-type "text/html"))
(format nil "Content-type: ~A~%~%" mime-type))
(defun header (&key (title "" title-flag) (script "" script-flag)
(onload "" onload-flag) (bgcolor "#FFFFFF" bgcolor-flag)
(text "#000000" text-flag))
(let ((title (if title-flag
(concatenate 'string
": "
title)
title))
(script (if script-flag
(format nil "
<script language=\"JavaScript\">
<!--
~A
//-->
</script>" script)
script))
(onload (if onload-flag
(concatenate 'string
" onload=\""
onload
"\"")
onload)))
(format nil "
<html>
<head>
<title>Dave's CGI Factory~A</title>
~A
</head>
<body bgcolor=\"~A\" text=\"~A\"~A>
<div align=\"center\">" title script bgcolor text onload)) )
;;;
;;; Generic HTML footer.
;;;
(defun end-html ()
(format nil "
</div>
</body>
</html>~%") )