- Add debugging notification
[mmondor.git] / mmsoftware / cl / server / test-httpd.lisp
1 ;;;; $Id: test-httpd.lisp,v 1.11 2011/08/30 01:23:59 mmondor Exp $
2 ;;;;
3 ;;;; Test/exemple minimal HTTP server
4 ;;;;
5 ;;;; Copyright (c) 2011, Matthew Mondor
6 ;;;; ALL RIGHTS RESERVED.
7
8
9 (declaim (optimize (speed 3) (safety 1) (debug 3)))
10
11 (eval-when (:compile-toplevel :load-toplevel)
12 (load "ecl-mp-server")
13 (load "html"))
14
15 (defpackage :httpd
16 (:use :cl :server :html))
17
18 (in-package :httpd)
19
20 (defparameter *rcsid*
21 "$Id: test-httpd.lisp,v 1.11 2011/08/30 01:23:59 mmondor Exp $")
22
23
24 (defparameter *request-timeout* 60)
25 (defparameter *request-max-size* 4096)
26 (defvar *vhost-default* nil)
27
28
29 (defstruct vhost
30 (hostname "" :type string)
31 (root "/" :type string)
32 (charset "UTF-8" :type string))
33
34 (defvar *vhosts* (make-hash-table :test #'equal))
35 (defvar *vhosts-lock* (mp:make-lock :name 'vhosts-lock))
36
37 (defun vhost-register (&key
38 (name "")
39 (aliases '())
40 (root "/")
41 (charset "UTF-8"))
42 (let ((vhost (make-vhost :hostname name
43 :root root
44 :charset charset)))
45 (mp:with-lock (*vhosts-lock*)
46 (setf (gethash (string-downcase name) *vhosts*) vhost)
47 (loop
48 for alias in aliases
49 do
50 (setf (gethash (string-downcase alias) *vhosts*) vhost))))
51 t)
52
53 (defun vhost-unregister (name)
54 (mp:with-lock (*vhosts-lock*)
55 (multiple-value-bind (vhost exists-p)
56 (gethash (string-downcase name) *vhosts*)
57 (when exists-p
58 (loop
59 for key being each hash-key of *vhosts* using (hash-value val)
60 when (eq val vhost) do (remhash key *vhosts*)))))
61 t)
62
63 (defun vhost-query (name &key (default nil))
64 (mp:with-lock (*vhosts-lock*)
65 (loop
66 repeat 2
67 do
68 (multiple-value-bind (vhost exists-p)
69 (gethash (string-downcase name) *vhosts*)
70 (cond ((and default *vhost-default* (not exists-p))
71 (setf name *vhost-default*))
72 (exists-p
73 (return vhost))
74 (t
75 (return nil)))))))
76
77
78 (defparameter *server-version*
79 (let ((parts (string-split *rcsid*
80 :separators '(#\Space #\,))))
81 (concatenate 'string
82 (svref parts 1) "/" (svref parts 3))))
83
84
85 ;;; URL Decoding
86
87 (defun utf-8-string-encode (string)
88 (let ((v (make-array (+ 5 (length string)) ; Best case but we might grow
89 :element-type '(unsigned-byte 8)
90 :adjustable t
91 :fill-pointer 0)))
92 (with-open-stream (s (ext:make-sequence-output-stream
93 v :external-format :utf-8))
94 (loop
95 for c across string
96 do
97 (write-char c s)
98 (let ((d (array-dimension v 0)))
99 (when (< (- d (fill-pointer v)) 5)
100 (adjust-array v (* 2 d))))))
101 v))
102
103 (defun utf-8-string-decode (bytes)
104 (macrolet ((add-char (c)
105 `(vector-push-extend ,c string 1024)))
106 (with-open-stream (s (ext:make-sequence-input-stream
107 bytes :external-format :utf-8))
108 (loop
109 with string = (make-array 1024
110 :element-type 'character
111 :adjustable t
112 :fill-pointer 0)
113 for c of-type character =
114 (handler-bind
115 ((ext:stream-decoding-error
116 #'(lambda (e)
117 (mapc #'(lambda (o)
118 ;; Assume LATIN-1 and import
119 (add-char (code-char o)))
120 (ext:character-decoding-error-octets e))
121 (invoke-restart 'continue)))
122 (end-of-file
123 #'(lambda (e)
124 (declare (ignore e))
125 (loop-finish))))
126 (read-char s))
127 do (add-char c)
128 finally (return string)))))
129
130 (defun url-decode (string)
131 (macrolet ((get-octet ()
132 `(if (= input-max input-pos)
133 (loop-finish)
134 (prog1
135 (aref input input-pos)
136 (the fixnum (incf (the fixnum input-pos))))))
137 (put-octet (o)
138 `(vector-push ,o output)))
139 (loop
140 with input = (utf-8-string-encode string)
141 with input-pos of-type fixnum = 0
142 with input-max of-type fixnum = (length input)
143 with output = (make-array (length input)
144 :element-type '(unsigned-byte 8)
145 :fill-pointer 0)
146 for o of-type '(unsigned-byte 8) = (get-octet)
147 when (= 37 o) do (let ((c1 (code-char (get-octet)))
148 (c2 (code-char (get-octet))))
149 (when (and (digit-char-p c1 16)
150 (digit-char-p c2 16))
151 (put-octet (parse-integer
152 (map 'string #'identity `(,c1 ,c2))
153 :radix 16))))
154 else when (= 43 o) do (put-octet 32)
155 else do (put-octet o)
156 finally (return (utf-8-string-decode output)))))
157
158
159 ;;; Supplied with a hash table and a string set statement in the form
160 ;;; "variable=value" or "variable[]=value", add the association binding.
161 ;;; If the variable name terminates with "[]", it denotes that the variable
162 ;;; is an array, in which case multiple values may be accumulated into it.
163 (defun property-set (ht str)
164 (let ((parts (string-split str :separators '(#\=) :max 2)))
165 (when (> (length parts) 0)
166 (let ((var (string-downcase (svref parts 0)))
167 (val (if (= 1 (length parts)) "" (svref parts 1)))
168 (array-p nil))
169 ;; Escape and sanity-check VAR
170 (setf var (url-decode var))
171 (when (every #'(lambda (c)
172 (or (alphanumericp c)
173 (member c '(#\- #\[ #\]) :test #'char=)))
174 var)
175 ;; Unescape VAL
176 (setf val (url-decode val))
177 ;; An array?
178 (let ((len (length var)))
179 (declare (type fixnum len))
180 (when (and (> len 2)
181 (char= #\] (schar var (- len 1)))
182 (char= #\[ (schar var (- len 2))))
183 (setf array-p t)))
184 (multiple-value-bind (o exists-p)
185 (gethash var ht)
186 (cond (array-p
187 ;; Array
188 (when (not exists-p)
189 (setf o (make-array 16
190 :element-type 'string
191 :adjustable t
192 :fill-pointer 0)
193 (gethash var ht) o))
194 (vector-push-extend val o 16))
195 (t
196 ;; Normal associative variable
197 (setf (gethash var ht) val)))))))))
198
199 (defun http-get-parse (ht str)
200 (loop
201 with parts = (string-split str
202 :separators '(#\&)
203 :trim-parts '(#\Newline #\Return))
204 for p across parts
205 do
206 (property-set ht p)))
207
208
209 ;;; XXX Should support options, like content-length, no-cache, etc...
210 ;;; We possibly also need a way to calculate content-length and send it,
211 ;;; to enhance performance.
212 (defun http-response-headers (stream code message)
213 (format stream
214 "HTTP/1.1 ~A ~A~C
215 Server: ~A~C
216 Connection: close~C
217 Content-Type: text/html; charset=UTF-8~C
218 ~C
219 "
220 code message #\Return
221 *server-version* #\Return
222 #\Return #\Return #\Return))
223
224 (defun http-error (stream code message &optional description)
225 (http-response-headers stream code message)
226 (let ((title (html-escape (format nil "~A - ~A" code message))))
227 (do-html stream
228 (:html (:head (:title title))
229 (:body
230 (:h1 title)
231 (do-html-when description
232 (:p (html-escape description)))
233 (:small (html-escape *server-version*)))))))
234
235 ;;; XXX Should we send :DEPRECATED-PROTOCOL for other methods than GET
236 ;;; for prehistoric requests?
237 ;;; Reads the HTTP client request from STREAM, and returns two values,
238 ;;; a status keyword symbol and a list consisting of the collected lines.
239 ;;; :NO-REQUEST no request was sent (empty request)
240 ;;; :DEPRECATED-PROTOCOL (HTTP < 1.0 GET request sent)
241 ;;; :REQUEST-SIZE-EXCEEDED request exceeded allowed request size
242 ;;; :REQUEST-TIMEOUT allowed time for request to complete exceeded
243 ;;; :SUCCESS success
244 (defun http-request-read (stream)
245 (loop
246 with max-time of-type integer = (+ (server-time) *request-timeout*)
247 with request-max-size of-type fixnum = *request-max-size*
248 for line = (line-read stream)
249 for words = (if (= nlines 0)
250 (string-split line :max 3)
251 #())
252 while (< chars request-max-size) ; Request size exceeded
253 while (< (server-time) max-time) ; Request timeout
254 until (string= "" line) ; End of HTTP/1.x request
255 until (and (= nlines 0) ; End of HTTP/0.x request
256 (= (length words) 2)
257 (string= "GET" (aref words 0)))
258 sum (length line) into chars of-type fixnum
259 count line into nlines of-type fixnum
260 collect line into lines
261 finally
262 (return
263 (values (cond
264 ((and (= nlines 0)
265 (= (length words) 0)) :no-request)
266 ((and (= nlines 0)
267 (= (length words) 2)
268 (string= "GET" (aref words 0)))
269 (push line lines)
270 :deprecated-protocol)
271 ((> chars request-max-size) :request-size-exceeded)
272 ((>= (server-time) max-time) :request-timeout)
273 (t :success))
274 lines))))
275
276 ;;; Request parsing preprocessor.
277 ;;; Extracts METHOD/PATH/PROTOCOL from the first request line and
278 ;;; coalesces continuating header lines. Returns the request line
279 ;;; as first value and the list of preprocessed lines as second value.
280 (defun http-request-parse-1 (lines)
281 (values (pop lines)
282 (loop
283 with list = '()
284 with last = nil
285 for line in lines
286 do
287 (cond ((and (let ((c (schar line 0)))
288 (or (char= #\Space c) (char= #\Tab c)))
289 last)
290 (setf (car last)
291 (concatenate 'string (car last) " "
292 (string-trim '(#\Space #\Tab)
293 line))))
294 (t
295 (let ((words
296 (string-split line
297 :separators '(#\:)
298 :trim-parts '(#\Space #\Tab)
299 :max 2)))
300 (when (= 2 (length words))
301 (push line list)
302 (setf last list)))))
303 finally (return list))))
304
305 (defstruct http-request
306 raw
307 protocol
308 (old-get nil)
309 method
310 host
311 (vhost nil)
312 path
313 query
314 post
315 (vars-get (make-hash-table :test 'equal))
316 (vars-post (make-hash-table :test 'equal))
317 (vars-cookie (make-hash-table :test 'equal))
318 agent
319 referer
320 (keep-alive 0)
321 (connection "close")
322 content-type
323 (content-length -1)
324 (modified-since -1)
325 (unmodified-since -1)
326 range)
327
328 ;;; List of headers we care about and functions to fill them.
329 ;;; CLOS could have been used instead after interning a keyword symbol
330 ;;; from the header variable string, but that would probably be slower.
331 (defparameter *header-table*
332 `(("host"
333 ,#'(lambda (o v)
334 (let ((pos (position #\: v :from-end t)))
335 (when pos
336 (setf v (subseq v 0 pos))))
337 (setf (http-request-host o) v
338 (http-request-vhost o) (vhost-query v :default t))))
339 ("user-agent"
340 ,#'(lambda (o v)
341 (setf (http-request-agent o) v)))
342 ("referer"
343 ,#'(lambda (o v)
344 (setf (http-request-agent o) v)))
345 ("keep-alive"
346 ,#'(lambda (o v)
347 (let ((i (handler-case
348 (parse-integer v)
349 (t ()
350 0))))
351 (setf (http-request-keep-alive o) i))))
352 ("connection"
353 ,#'(lambda (o v)
354 (setf (http-request-connection o) v)))
355 ("content-type"
356 ,#'(lambda (o v)
357 (setf (http-request-content-type o) v)))
358 ("content-length"
359 ,#'(lambda (o v)
360 (let ((i (handler-case
361 (parse-integer v)
362 (t ()
363 -1))))
364 (setf (http-request-content-length o) i))))
365 ("if-modified-since"
366 ,#'(lambda (o v)
367 (setf (http-request-modified-since o)
368 (server-time-rfc-parse v))))
369 ("if-unmodified-since"
370 ,#'(lambda (o v)
371 (setf (http-request-unmodified-since o)
372 (server-time-rfc-parse v))))
373 ("range"
374 ,#'(lambda (o v)
375 (setf (http-request-range o) v)))
376 ("cookie"
377 ,#'(lambda (o v)
378 (property-set (http-request-vars-cookie o) v)))))
379
380 ;;; Reads and parses POST data request if any
381 ;;; XXX Should check the content-length size doesn't exceed allowed limit
382 ;;; XXX Should use a short enough timeout
383 ;;; XXX Should handle UTF-8 decoding errors
384 ;;; Actually, those are not really expected since special characters
385 ;;; are sent escaped.
386 ;;; XXX Should at least also support "multipart/form-data" enctype
387 (defun http-post-parse (stream req)
388 (when (and (string= (http-request-method req) "POST")
389 (string= (http-request-content-type req)
390 "application/x-www-form-urlencoded")
391 (> (http-request-content-length req) 0))
392 (let ((pd
393 (handler-case
394 (loop
395 with length = (http-request-content-length req)
396 with vector = (make-array length
397 :element-type 'character
398 :initial-element #\Nul)
399 while (< read-length length)
400 sum (read-sequence vector stream
401 :start read-length) into read-length
402 finally (return vector))
403 (t ()
404 nil))))
405 (when pd
406 (http-get-parse (http-request-vars-post req) pd))
407 pd)))
408
409 ;;; Actual request parsing function.
410 (defun http-request-parse (lines stream)
411 ;; Preprocessing
412 (multiple-value-bind (request headers)
413 (http-request-parse-1 lines)
414 (let ((req (make-http-request))
415 (valid nil))
416 (setf (http-request-raw req) lines)
417
418 ;; Request method/path/protocol
419 (let ((words (string-split request :max 4)))
420 (cond ((and (= 2 (length words)) (string= "GET" (svref words 0)))
421 (setf (http-request-protocol req) "HTTP/0.0"
422 (http-request-old-get req) t
423 (http-request-method req) "GET"
424 (http-request-path req) (svref words 1)
425 valid t))
426 ((= 3 (length words))
427 (setf (http-request-protocol req) (svref words 2)
428 (http-request-method req) (svref words 0)
429 (http-request-path req) (svref words 1)
430 valid t))))
431
432 ;; Headers
433 (when (and valid (not (http-request-old-get req)))
434 (loop
435 for line in headers
436 for var = (string-trim
437 '(#\Space)
438 (string-downcase
439 (subseq line 0 (position #\: line))))
440 for val = (string-trim
441 '(#\Space)
442 (subseq line (1+ (position #\: line :start
443 (length var)))))
444 for fun = (second (find var *header-table*
445 :key #'first
446 :test #'string=))
447 when fun do (funcall fun req val)))
448
449 ;; XXX Reject pre 1.0 requests on dynamic applications
450
451 ;; XXX Error on other bad requests
452
453 ;; Separate path from query variables; fill in GET variables if any.
454 (let* ((path (http-request-path req))
455 (pos (position #\? path :test #'char=)))
456 (when pos
457 (let ((get (subseq path (1+ pos))))
458 (setf (http-request-path req) (subseq path 0 pos)
459 (http-request-query req) get)
460 (http-get-parse (http-request-vars-get req) get))))
461
462 ;; XXX Verify if resource exists (we should do this before reading
463 ;; any POST, ideally...
464
465 ;; Read and parse POST data if any
466 (setf (http-request-post req) (http-post-parse stream req))
467
468 ;; Finally return request object for eventual dispatching
469 req)))
470
471
472 ;;; Creates dynamic bindings for a set of variables defined in the
473 ;;; hash-table HT. May be useful to bind the cookie, get and post
474 ;;; variables when calling user code.
475 ;;; These variables are bound with names in the format $PREFIX-<variable>$.
476 ;;; An additional variable is bound to a list of lists holding all bound
477 ;;; variables, named $$PREFIX$$.
478 (defmacro with-ht-bind ((ht prefix) &body body)
479 (let ((s-ht (gensym))
480 (s-prefix (gensym))
481 (s-var (gensym))
482 (s-val (gensym))
483 (s-binding (gensym))
484 (s-vars (gensym))
485 (s-vals (gensym))
486 (s-bindings (gensym)))
487 `(loop
488 with ,s-ht = ,ht
489 with ,s-prefix = ,prefix
490 for ,s-var being each hash-key of ,s-ht using (hash-value ,s-val)
491 for ,s-binding = (intern (format nil "$~A-~A$"
492 (symbol-name ,s-prefix)
493 (string-upcase ,s-var)))
494 collect ,s-binding into ,s-vars
495 collect ,s-val into ,s-vals
496 collect `(,,s-binding ,,s-val) into ,s-bindings
497 finally
498 (progn
499 (push (intern (format nil "$$~A$$" (symbol-name ,s-prefix)))
500 ,s-vars)
501 (push ,s-bindings ,s-vals)
502 (return (progv ,s-vars ,s-vals
503 ,@body))))))
504
505 ;;; Utility function for user code to easily verify that the
506 ;;; wanted variables in the wanted category exist.
507 (defun http-required-vars (&key get post cookie)
508 (flet ((check (category-name category-var vars-list)
509 (every #'(lambda (var)
510 (or (member var category-var
511 :key #'first
512 :test #'eq)
513 (error "Required ~A variable ~S is unbound."
514 category-name var)))
515 vars-list)))
516 (declare (special $$get$$ $$post$$ $$cookie$$))
517 (when get
518 (check "GET" $$get$$ get))
519 (when post
520 (check "POST" $$post$$ post))
521 (when cookie
522 (check "COOKIE" $$cookie$$ cookie)))
523 t)
524
525
526 ;;; XXX Debugging
527 (defun beep ()
528 (handler-case
529 (with-open-file (s "/dev/speaker" :direction :output)
530 (write-string "O1L15D" s))
531 (t ()
532 nil)))
533 (defun dump-vars (ht)
534 (with-output-to-string (out)
535 (maphash #'(lambda (k v)
536 (format out "~A = ~S~%" k v))
537 ht)))
538 (defun req-var (req type var &optional (default ""))
539 (let ((ht (cond ((eq :get type)
540 (http-request-vars-get req))
541 ((eq :post type)
542 (http-request-vars-post req))
543 ((eq :cookie type)
544 (http-request-vars-cookie req)))))
545 (multiple-value-bind (val exists-p)
546 (gethash (string-downcase (symbol-name var)) ht)
547 (if exists-p
548 val
549 default))))
550
551 ;;; XXX Make it conditional on config to report via HTTP or log
552 (defmacro with-http-errors ((stream) &body body)
553 (let ((s-block (intern (symbol-name (gensym "BLOCK")) :keyword)))
554 `(block ,s-block
555 (let ((*debugger-hook* #'(lambda (condition hook)
556 (declare (ignore hook))
557 (http-error ,stream 500 "XXX")
558 (return-from ,s-block nil))))
559 ,@body))))
560
561 ;;; XXX Should dispatch requests to known resources as needed
562 ;;; XXX Should probably display HTTP errors for unhandled Lisp conditions
563 (defun http-serve (connection)
564 (beep)
565 (let ((stream (connection-stream connection)))
566 (multiple-value-bind (status lines)
567 (http-request-read stream)
568 (unless (eq :success status)
569 ;; XXX Report appropriate error
570 (http-error stream 403 "Error"
571 (format nil "Error: ~S" status))
572 (log-line "~X Invalid request: ~S"
573 (connection-session connection) status)
574 (finish-output stream)
575 (return-from http-serve nil))
576 (let ((req (http-request-parse lines stream)))
577
578 ;; XXX We should probably eventually disable connect/disconnect
579 ;; messages and format our output more appropriately for an HTTPd.
580 (log-line "~X ~S" (connection-session connection) req)
581
582 (http-response-headers stream 200 "Ok")
583 (do-html stream
584 (:html (:head (:title "Interactively developed test server"))
585 (:body
586 (:h1 "Interactively developed test server")
587 (:p "This page, forms and server code may change anytime "
588 "without interruption; a live SWANK connection is "
589 "maintained from Emacs and SLIME, and the system is "
590 "developed interactively on spare time.")
591 (:h2 "Location")
592 (:p "IP address/port: "
593 (connection-address-string connection) ":"
594 (connection-port connection))
595 (:h2 "Test form")
596 (:form :action (html-escape
597 (format nil
598 "/foo.lisp?id=~64,'0X" (random
599 #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)))
600 :method "post"
601 "First name: "
602 (:/input :name "first-name"
603 :type "text"
604 :size "32"
605 :maxlength "64"
606 :value (html-escape
607 (req-var req :post :first-name
608 "First name")))
609 (:/br)
610 "Last name: "
611 (:/input :name "last-name"
612 :type "text"
613 :size "32"
614 :maxlength "64"
615 :value (html-escape
616 (req-var req :post :last-name
617 "Last name")))
618 (:/br)
619 (do-html-loop (for i from 1 to 10
620 for s = (format nil "~2,'0D" i)
621 for v = (format nil "box-~2,'0D" i))
622 "Box " s
623 ;; XXX If we allowed user code for the tag name,
624 ;; this would have been smaller.
625 (let* ((a (req-var req :post :box[] nil))
626 (c (if a (find v a :test #'string=) nil)))
627 (do-html-if c
628 (:/input :name "box[]"
629 :type "checkbox"
630 :value v
631 :/checked)
632 (:/input :name "box[]"
633 :type "checkbox"
634 :value v))))
635 (:/br)
636 (:textarea :name "message"
637 :rows 10
638 :cols 60
639 (html-escape
640 (req-var req :post :message
641 "Message text.")))
642 (:/br)
643 (:/input :type "submit" :value "Post"))
644 (:h2 "Browser request")
645 (:pre
646 (do-html-loop (for line in lines)
647 (html-escape (format nil "~A~%" line))))
648 (:p (:code
649 (html-escape (format nil "~S~%" req))))
650 (:h2 "Path")
651 (html-escape (format nil "~A~%"
652 (http-request-path req)))
653 (do-html-when (http-request-query req)
654 (:h2 "GET data")
655 (:pre
656 (html-escape (format nil "~A~%"
657 (http-request-query req))))
658 (:pre
659 (html-escape (dump-vars (http-request-vars-get req)))))
660 (do-html-when (http-request-post req)
661 (:h2 "POST data")
662 (:pre
663 (html-escape (format nil "~A~%"
664 (http-request-post req))))
665 (:pre
666 (html-escape (dump-vars
667 (http-request-vars-post req)))))
668 (do-html-when (> (hash-table-count
669 (http-request-vars-cookie req)) 0)
670 (:h2 "COOKIE data")
671 (:pre
672 (html-escape (dump-vars
673 (http-request-vars-cookie req)))))
674 (:h2 "Server information")
675 (do-html-loop
676 (with packages = (list-all-packages)
677 for p in packages
678 for s = (find-symbol "*RCSID*" p)
679 for v = (if (and s (boundp s))
680 (html-escape (symbol-value s)) nil)
681 when v)
682 (:code v) (:/br))
683 (:code (html-escape (lisp-implementation-type)) " "
684 (html-escape (lisp-implementation-version)))
685 (:p (:a :href "http://validator.w3.org/check?uri=referer"
686 (:/img :src
687 "http://www.w3.org/Icons/valid-xhtml10"
688 :alt "Valid XHTML 1.0 Transitional"
689 :height "31"
690 :width "88"))))))
691 (format stream "~%")
692 (finish-output stream)))))
693
694
695 ;;; Function called to serve exceeded connections.
696 (defun http-overflow (connection reason)
697 (declare (ignore reason)) ; XXX
698 (let ((stream (connection-stream connection)))
699 (http-error stream 403.9 "Too many connections"
700 "Connection limit exceeded for your address. Try again later.")
701 (finish-output stream)))
702
703
704 (defun httpd-init ()
705 (vhost-register :name "gw.pulsar-zone.net"
706 :aliases '("behemoth.xisop" "localhost")
707 :root "/home/www/pulsar-zone.net/"
708 :charset "UTF-8")
709 (server-init (make-server-config :listen-address "0.0.0.0"
710 :listen-port 7777
711 :serve-function 'http-serve
712 :overflow-function 'http-overflow))
713 t)
714
715 (defvar *initialized* (httpd-init))
716
717 (defun httpd-cleanup ()
718 (server-cleanup)
719 (setf *initialized* nil))