- Reworked the HTTP-REPLY object. Notably, the headers are now alists for
[mmondor.git] / mmsoftware / cl / server / httpd.lisp
CommitLineData
451d8738 1;;;; $Id: httpd.lisp,v 1.11 2012/09/10 21:47:49 mmondor Exp $
c0aa17ee
MM
2
3#|
4
5Copyright (c) 2012, 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;;;; Interactively developed test/exemple HTTP server
31
32;;;; XXX TODO XXX
33;;;; - There is a race condition related to MP:PROCESS-KILL used by the
34;;;; thread manager of ecl-mp-server.lisp.
35;;;; Try an alternative ecl-mp-server, which launches a configured number
36;;;; of fixed accept-threads, which then delegate FDs to a dynamic pool
37;;;; of threads. Use the new MP:MAILBOX API for interthread communication,
38;;;; and introduce a special message to notify an extraneous thread to exit.
39;;;; To mitigate this, we currently configure the server to not downscale
40;;;; the threads pool.
c0aa17ee
MM
41;;;; - Perhaps make the interface to HTTP-REPLY, HTTP-REPLY-SEND and
42;;;; HTTP-ERROR better so that user code doesn't always have to carry
43;;;; and care about STREAM, etc. *CONNECTION* already holds it...
44;;;; - Implement RANGE
c0aa17ee
MM
45;;;; - Perhaps support chunked streams
46;;;; - Multipart POST parsing so that files can be uploaded.
47;;;; Unfortunately, the silly standard does not make Content-Length
48;;;; obligatory, so less efficient ad-hoc line-based parsing must be used
49;;;; when it's absent.
50;;;; - Session helper code, with support for session ID cookie and
51;;;; anti-XSS GET session-tied IDs, URL generator to use these IDs,
52;;;; user session-specific variables/objects
a837d3f7 53;;;; - Possibly also generic authentication features (HTTP and form-based)
c0aa17ee
MM
54;;;; - Form generator with form-instance IDs for matching responses to
55;;;; queries
c0aa17ee
MM
56;;;; - Possibly implement simple filter types to allow the equivalent to the
57;;;; following directive for Apache+secmod:
58;;;; SecRule HTTP_User-Agent "GSLFbot" "deny,log,status:403"
59;;;; Determine if we should support these per-vhost, global or both.
60;;;; We might also want to define a hook system for configuration files
61;;;; to easily create custom filter code.
62;;;; - Perhaps make error handlers configurable. This could either be done
63;;;; using CLOS generic functions or a simpler, possibly faster dispatch
64;;;; system. Maybe also make the page indexer configurable.
a837d3f7
MM
65;;;; - Make dynamic dispatching matching more powerful such that user
66;;;; code could perform custom dispatching, i.e. all of / with path
67;;;; supplied, all of /foo/<n> with <n> supplied, etc.
68;;;; - Perhaps consider CLOS to allow user code to customize dispatching
69;;;; and error pages... but also test the performance impact.
c0aa17ee
MM
70
71
72
73(declaim (optimize (speed 3) (safety 1) (debug 3)))
74
4bcf8ca1
MM
75#+:mm-ecl-standalone
76(setf *load-verbose* nil)
77(eval-when (:compile-toplevel #-:mm-ecl-standalone :load-toplevel)
c0aa17ee
MM
78 (load "ecl-mp-server")
79 (load "html")
80 (load "character"))
81
82(defpackage :httpd
83 (:use :cl :server :html :character)
84 (:export #:httpd-config
85 #:make-httpd-config
86 #:httpd-init
87 #:vhost
88 #:make-vhost
89 #:vhost-register
90 #:vhost-unregister
91 #:vhost-handler-register
92 #:vhost-handler-list
93 #:vhost-handler-unregister
94 #:mime-register
95 #:mime-unregister
96 #:mime-query
97 #:mime-load
98 #:mime-reload
99 #:http-reply
100 #:make-http-reply
451d8738
MM
101 #:http-reply-header-set
102 #:http-reply-header-get
103 #:http-reply-header-unset
104 #:http-reply-header-set-nocache
c0aa17ee
MM
105 #:http-reply-content-add
106 #:http-reply-log-time
107 #:http-reply-flush
108 #:http-reply-send
109 #:http-error
110 #:http-redirect
111 #:url-decode
112 #:url-encode
113 #:req-var
22b9809f 114 #:with-http-let
451d8738 115 #:range-validate
c0aa17ee
MM
116 #:debug-feature))
117
118(in-package :httpd)
119
120(defparameter *rcsid*
451d8738 121 "$Id: httpd.lisp,v 1.11 2012/09/10 21:47:49 mmondor Exp $")
c0aa17ee
MM
122
123(defparameter *server-version*
124 (let ((parts (string-split *rcsid*
125 :separators '(#\Space #\,))))
126 (concatenate 'string
127 (svref parts 1) "/" (svref parts 3))))
128
129
130(defstruct (httpd-config (:conc-name config-))
131 (server-config nil :type (or null
132 server:server-config))
133 ;; Supported DEBUG features:
134 ;; :log-requests :log-connections :log-errors :test :beep
135 (debug '(:log :log-errors :test) :type list)
136
51017907
MM
137 ;; For the standalone-mode swank server
138 (swank-create-server t :type boolean)
139 (swank-loader "/home/foo/slime/swank-loader" :type string)
140 (swank-address "127.0.0.1" :type string)
141 (swank-port 4005 :type fixnum)
142
c0aa17ee
MM
143 (request-timeout 60 :type fixnum)
144 (request-max-size 4096 :type fixnum)
145 (request-keepalive-timeout 20 :type fixnum)
146 (request-keepalive-max 100 :type fixnum)
147 (request-log t :type boolean)) ; XXX Optional?
148
149(defvar *config* (make-httpd-config :server-config (make-server-config)))
150
151
152;;; Paths
153
154(defvar *path-max* 255)
155(defvar *path-valid-char-table*
156 (make-valid-character-table (character-intervals
157 '(#\a #\z)
158 '(#\A #\Z)
159 '(#\0 #\9)
160 #\. #\/ #\- #\_)))
161
162;;; Returns copy of PATH or NIL. Always begins with "/", with multiple
163;;; "/" collapsed into one. Makes sure that PATH only contains allowed
164;;; characters (in *PATH-VALID-CHAR-TABLE*) and is shorter than *PATH-MAX*.
165;;; Does not allow '.' at the start of PATH or after any '/'.
166(defun path-valid (path)
167 (let ((out (make-array (1+ (length path))
168 :element-type 'character
169 :fill-pointer 0)))
170 (macrolet ((add-char (c)
171 `(vector-push ,c out)))
172 (add-char #\/)
173 (if
174 (loop
175 with char-table = *path-valid-char-table*
176 with last of-type character = #\/
177 for c of-type character across path
178 do
179 (block continue
180 (when (char= #\/ last)
181 ;; Collapse multiple '/' and prohibit '.' at start
182 (if (char= #\/ c)
183 (return-from continue)
184 (when (char= #\. c)
185 (return nil))))
186 (unless (character-valid-p char-table c)
187 (return nil))
188 (add-char c)
189 (setf last c))
190 finally (return out))
191 (if (> (length out) *path-max*)
192 nil
193 out)
194 nil))))
195
196(defstruct path
197 real virtual)
198
199;;; Should always be called when processing user-supplied paths.
200;;; The application should then only trust the objects returned by
201;;; this function. Returns NIL if the path is invalid. On success,
202;;; returns a PATH object with:
203;;; REAL: System-wide absolute real fullpath, to be used to access the
204;;; file/directory in question
205;;; VIRTUAL: The virtual root based absolute fullpath, useful to report
206;;; to the user.
207;;; Note that supplied ROOT should previously have been passed through
208;;; PATH-VALID, and that both ROOT and PATH should be absolute paths.
209(defun path-valid-virtual (root path)
210 (let* ((virtual (path-valid (concatenate 'string "/" path)))
211 (real (if virtual (path-valid (concatenate 'string
212 "/" root "/" virtual))
213 nil)))
214 (if (and virtual real)
215 (make-path :real real
216 :virtual virtual)
217 nil)))
218
219(defun path-extension (path)
220 (let ((dot (position #\. path
221 :test #'char=
222 :from-end t)))
223 (if dot
224 (string-downcase (subseq path (1+ dot)))
225 nil)))
226
227
228;;; VHosts
229
230(defvar *vhost-default* nil)
231
232(defstruct vhost
233 (hostname "" :type string :read-only t)
234 (root "/" :type string)
235 (index "/index.html" :type string)
236 (charset :utf-8 :type keyword)
237 (autoindex nil :type boolean)
238 (post-max-size 1048576 :type integer)
239 (post-timeout 240 :type fixnum)
240 (%handlers (make-hash-table :test #'equal) :type hash-table :read-only t))
241
242(defvar *vhosts* (make-hash-table :test #'equal))
243(defvar *vhosts-lock* (mp:make-lock :name 'vhosts-lock))
244
245(defun vhost-register (vhost &key (aliases '()) (default nil))
246 (check-type vhost vhost)
247 (check-type aliases list)
248 (check-type default boolean)
249 (with-accessors ((name vhost-hostname)
250 (root vhost-root)
251 (index vhost-index)) vhost
252 (unless (path-valid root)
253 (error "Invalid root path \"~A\"" root))
254 (unless (path-valid index)
255 (error "Invalid index path \"~A\"" index))
256 (mp:with-lock (*vhosts-lock*)
257 (let ((vhosts *vhosts*))
258 (setf (gethash (string-downcase name) vhosts) vhost)
259 (loop
260 for alias in aliases
261 do
262 (setf (gethash (string-downcase alias) vhosts) vhost))
263 (when default
264 (setf *vhost-default* vhost)))))
265 t)
266
267(defun vhost-unregister (name)
268 (mp:with-lock (*vhosts-lock*)
269 (let ((vhosts *vhosts*))
270 (multiple-value-bind (vhost exists-p)
271 (gethash (string-downcase name) vhosts)
272 (when exists-p
273 (loop
274 for key being each hash-key of vhosts using (hash-value val)
275 when (eq val vhost) do (remhash key vhosts))))))
276 t)
277
278(defun vhost-query (name &key (default nil))
279 (mp:with-lock (*vhosts-lock*)
280 (multiple-value-bind (vhost exists-p)
281 (gethash (string-downcase name) *vhosts*)
282 (let ((vhost-default *vhost-default*))
283 (cond ((and default vhost-default (not exists-p))
284 vhost-default)
285 (exists-p
286 vhost)
287 (t
288 nil))))))
289
290;;; User-supplied paths should be passed through this function, returning
291;;; NIL or an object supplied by PATH-VALID-VIRTUAL on VHOST's ROOT and
292;;; PATH.
293(defun vhost-path (vhost path)
294 (path-valid-virtual (vhost-root vhost) path))
295
296;;; VHost dynamic handlers
297(defun vhost-handler-register (vhost-name handlers)
298 (let ((vhost (vhost-query vhost-name)))
299 (check-type vhost vhost)
300 (check-type handlers list)
301 (mp:with-lock (*vhosts-lock*)
302 (mapc #'(lambda (l)
303 (destructuring-bind (path function) l
304 (check-type path string)
305 (let ((vpath (string-downcase (path-valid path))))
306 (setf (gethash vpath (vhost-%handlers vhost))
307 function))))
308 handlers)))
309 nil)
310
311(defun vhost-handler-list (vhost-name)
312 (let* ((vhost (vhost-query vhost-name))
313 (list '()))
314 (when vhost
315 (mp:with-lock (*vhosts-lock*)
316 (maphash #'(lambda (k v)
317 (push `(,k ,v) list))
318 (vhost-%handlers vhost))))
319 (sort list #'string< :key #'first)))
320
321(defun vhost-handler-unregister (vhost-name handlers)
322 (let ((vhost (vhost-query vhost-name)))
323 (when (and vhost handlers)
324 (mp:with-lock (*vhosts-lock*)
325 (mapc #'(lambda (s)
326 (check-type s string)
327 (let ((function (gethash s (vhost-%handlers vhost))))
328 (when function
329 (remhash s (vhost-%handlers vhost)))))
330 handlers)))))
331
332(defun vhost-handler-query (vhost vpath)
333 (let ((function nil))
334 (mp:with-lock (*vhosts-lock*)
335 (let ((fun (gethash vpath (vhost-%handlers vhost))))
336 (setf function fun)))
337 function))
338
339
340;;; Mime types
341
342(defvar *mime-type-table* (make-hash-table :test #'equal))
343(defvar *mime-type-lock* (mp:make-lock :name 'mime-type-lock))
344(defvar *mime-type-file* "mime-types.lisp")
345(defvar *mime-types*)
346
347(defun mime-register (mimetype extensions)
348 (let ((type (string-downcase mimetype)))
349 (mp:with-lock (*mime-type-lock*)
350 (mapc #'(lambda (e)
351 (setf (gethash (string-downcase e) *mime-type-table*) type))
352 extensions))
353 type))
354
355(defun mime-register-list (types)
356 (mapc #'(lambda (type)
357 (destructuring-bind (mimetype extensions) type
358 (mime-register mimetype extensions)))
359 types)
360 t)
361
362(defun mime-unregister (extension)
363 (mp:with-lock (*mime-type-lock*)
364 (let ((table *mime-type-table*))
365 (multiple-value-bind (type exists-p)
366 (gethash (string-downcase extension) table)
367 (when exists-p
368 (loop
369 for key being each hash-key of table using (hash-value val)
370 when (eq val type) do (remhash key table))))))
371 t)
372
373(defun mime-query (extension &optional (default "application/octet-stream"))
374 (mp:with-lock (*mime-type-lock*)
375 (multiple-value-bind (type exists-p)
376 (gethash (string-downcase extension) *mime-type-table*)
377 (if exists-p
378 type
379 default))))
380
381(defun mime-load (file)
382 (load file)
383 (setf *mime-type-file* file)
384 (mime-register-list *mime-types*))
385
386(defun mime-reload ()
387 (load *mime-type-file*)
388 (mime-register-list *mime-types*))
389
390
391;;; HTTP reply
392
393;;; Dynamically bound to request object for us
394(defvar *request* nil)
395
396;;; Useful to elegantly longjmp back to the request reader as soon as a
397;;; request is flushed.
398(define-condition http-reply-signal
399 (simple-error)
400 ())
401
402(define-condition http-reply-signal-no-keepalive
403 (http-reply-signal)
404 ())
405
451d8738
MM
406(defstruct (http-reply (:constructor %make-http-reply))
407 (date (server-time-rfc) :type string)
408 (code 200 :type real)
409 (description "Ok" :type string)
410 (mime-type "text/html" :type string)
411 (charset :utf-8 :type keyword)
412 (headers '() :type list)
413 (content '() :type list)
414 (protocol 0.9 :type float)
415 (no-keepalive nil :type boolean)
416 (flush-log t :type boolean)
417 (flush-len t :type boolean)
418 (flush-signal t :type boolean))
419
420(defun make-http-reply (&rest keys)
421 (let* ((reply (apply #'%make-http-reply keys))
422 (request *request*))
423 (setf (http-reply-headers reply)
424 (list `("Server" . ,*server-version*)
425 '("Accept-Ranges" . "bytes")))
426 (when request
427 (setf (http-reply-charset reply)
428 (vhost-charset (http-request-vhost request))
429 (http-reply-protocol reply)
430 (let ((protocol (http-request-protocol request)))
431 (if protocol
432 protocol
433 0.9))
434 (http-reply-charset reply)
435 (vhost-charset (http-request-vhost request))))
436 reply))
437
438(defun http-reply-header-set (reply &rest pairs)
439 (with-accessors ((headers http-reply-headers)) reply
440 (loop
441 for pair in pairs
442 do
443 (destructuring-bind (key fmt &rest fmt-args) pair
444 (let* ((match (assoc key headers :test #'string-equal))
445 (line (if fmt-args
446 (apply #'format nil fmt fmt-args)
447 fmt)))
448 (if match
449 (rplacd match line)
450 (setf headers (acons key line headers)))))))
451 (values))
452
453(defun http-reply-header-get (reply key)
454 (assoc key (http-reply-headers reply) :test #'string-equal))
455
456(defun http-reply-header-unset (reply key)
457 (with-accessors ((headers http-reply-headers)) reply
458 (let ((match (assoc key headers :test #'string-equal)))
459 (if match
460 (rplacd match nil))))
461 (values))
462
463(defun http-reply-header-set-nocache (reply)
464 ;; We can't use PAIRLIS as we're later iterating through the list
465 ;; which must be a set, and PAIRLIS may insert or append...
466 (http-reply-header-set
467 reply
468 '("Expires" "Mon, 26 Jul 1997 05:00:00 GMT")
469 `("Last-Modified" ,(http-reply-date reply))
470 '("Cache-Control" "no-cache, must-revalidate")
471 '("Pragma" "no-cache")))
472
473(defvar *crlf* (concatenate 'string '(#\Return #\LineFeed)))
474
475(defun http-reply-headers-string (reply)
476 (with-output-to-string (out)
477 (loop
478 with crlf = *crlf*
479 with alist = (sort (http-reply-headers reply) ; XXX Unecessary to
480 #'string-lessp :key #'car) ; sort, only fancy
481 for item in alist
482 for (key . line) = item
483 when line
484 do
485 (format out "~:(~A~): ~A~A" key line crlf)
486 finally (write-string crlf out))))
c0aa17ee
MM
487
488(defun http-reply-content-add (reply content)
489 (push content (http-reply-content reply)))
490
491(defun http-reply-log-time (&optional (ut (server-time)))
492 (let ((months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
493 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
494 (multiple-value-bind
495 (second minute hour date month year)
496 (decode-universal-time ut 0)
497 (format nil "[~2,'0D/~A/~4,'0D:~2,'0D:~2,'0D:~2,'0D -0000]"
498 date (svref months (1- month)) year
499 hour minute second))))
500
501;;; Should only be called once per HTTP-REPLY object.
502;;; If size is not provided or is zero, signal HTTP-REPLY-SIGNAL.
503(defun http-reply-flush (reply stream &optional (size nil))
504 (let* ((config *config*)
505 (request *request*)
506 (encoding (if request
507 (vhost-charset (http-request-vhost request))
508 (vhost-charset *vhost-default*)))
509 (content (if (eq :utf-8 encoding)
510 (mapcar #'utf-8-string-encode
511 (http-reply-content reply))
512 (http-reply-content reply)))
513 (content-len (if size
514 size
515 (loop
516 for s in content
517 sum (length s) into len of-type fixnum
451d8738 518 finally (return len)))))
c0aa17ee
MM
519
520 (when request
521 (let ((connection *connection*))
522 (when (http-reply-no-keepalive reply)
451d8738 523 (setf (http-request-keep-alive request) nil))
c0aa17ee
MM
524 (macrolet ((field (f &optional (type :string))
525 `(let ((%f ,f))
526 ,(if (eq type :string)
527 `(if %f %f "-")
528 `(if (zerop %f) "-" %f)))))
451d8738
MM
529 (when (and (config-request-log config)
530 (http-reply-flush-log reply))
c0aa17ee
MM
531 (log-line-nostamp "~X ~A - - ~A ~A ~S ~A ~A \"~A\" \"~A\""
532 (connection-session connection)
533 (connection-address-string connection)
534 (http-reply-log-time)
535 (vhost-hostname (http-request-vhost request))
536 (first (http-request-raw request))
537 (http-reply-code reply)
538 (field content-len :integer)
539 (field (http-request-referer request))
540 (field (http-request-agent request)))))))
541
542 (when (> (http-reply-protocol reply) 0.9)
543 (with-accessors ((headers http-reply-headers)) reply
451d8738
MM
544 (http-reply-header-set
545 reply
546 (list "Date" (http-reply-date reply)))
547 (when (http-reply-flush-len reply)
548 (http-reply-header-set
549 reply
550 (list "Content-Length" "~D" content-len)
551 (list "Content-Type" "~A; charset=~A"
552 (http-reply-mime-type reply)
553 (symbol-name (http-reply-charset reply)))))
c0aa17ee
MM
554 (if (and request
555 (http-request-keep-alive request))
556 (when (= 1.0 (http-request-protocol request))
451d8738
MM
557 (http-reply-header-set
558 reply
559 (list "Keep-Alive" "timeout=~D, max=~D"
560 (config-request-keepalive-timeout config)
561 (config-request-keepalive-max config))
562 '("Connection" "Keep-Alive")))
563 (http-reply-header-set reply
564 '("Connection" "close")))
565 (format stream "HTTP/1.1 ~A ~A~A"
566 (http-reply-code reply)
567 (http-reply-description reply)
568 *crlf*)
569 (write-string (http-reply-headers-string reply) stream)))
c0aa17ee
MM
570 (unless size
571 (loop
572 with rcontent = (reverse content)
573 for s in rcontent
574 do
575 (write-sequence s stream)))
576 (finish-output stream))
451d8738
MM
577 (when (and (http-reply-flush-signal reply)
578 (or (null size) (zerop size)))
a837d3f7
MM
579 (error (if (http-reply-no-keepalive reply)
580 'http-reply-signal-no-keepalive
581 'http-reply-signal)))
c0aa17ee
MM
582 t)
583
584(defun http-reply-send (stream string)
585 (http-reply-flush (make-http-reply :content (list string)) stream))
586
587(defun http-error (stream code message &optional fmt &rest fmt-args)
588 (let ((reply (make-http-reply :code code
589 :description message
590 :no-keepalive t))
591 (description (if fmt
451d8738
MM
592 (if fmt-args
593 (apply #'format nil fmt fmt-args)
594 nil)
c0aa17ee 595 nil)))
451d8738 596 (http-reply-header-set-nocache reply)
c0aa17ee
MM
597 (http-reply-content-add
598 reply
599 (let ((title (html-escape (format nil "~A - ~A" code message))))
600 (do-html nil
601 (:html (:head (:title title))
602 (:body
603 (:h1 title)
604 (do-html-when description
605 (:p (html-escape description)))
606 (:small (html-escape *server-version*)))))))
607 (http-reply-flush reply stream)))
608
609(defun http-error-unimplemented (stream)
610 (let ((reply (make-http-reply :code 501
611 :description "Method Not Implemented"
612 :no-keepalive t)))
451d8738
MM
613 (http-reply-header-set-nocache reply)
614 (http-reply-header-set reply '("Allow" "GET, HEAD, POST"))
c0aa17ee
MM
615 (http-reply-content-add
616 reply
617 (let ((title "501 - Method Not Implemented"))
618 (do-html nil
619 (:html (:head (:title title))
620 (:body
621 (:h1 title)
622 (:small (html-escape *server-version*)))))))
623 (http-reply-flush reply stream)))
624
625(defun http-redirect (stream req vpath)
626 (let* ((vhost (http-request-vhost req))
627 (path (vhost-path vhost vpath))
628 (reply (make-http-reply :code 301
629 :description "Moved Permanently"
630 :charset (vhost-charset vhost)))
631 (movedto (format nil "http://~A~A"
632 (http-request-host req)
633 (if path (path-virtual path) nil)))
634 (title "301 - Moved Permanently"))
635 (unless path
636 (http-error stream 403 "Forbidden"
a837d3f7 637 "You do not have the permission to access this resource."))
451d8738
MM
638 (http-reply-header-set-nocache reply)
639 (http-reply-header-set reply (list "Location" "~A" movedto))
c0aa17ee
MM
640 (http-reply-content-add
641 reply
642 (do-html nil
643 (:html (:head (:title title))
644 (:body
645 (:h1 title)
646 (:p
647 "The document was permanently moved to "
648 (:a :href movedto
649 movedto) ".")
650 (:small (html-escape *server-version*))))))
651 (http-reply-flush reply stream)))
652
653(defun http-index-time (&optional (ut (server-time)))
654 (let ((months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
655 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
656 (multiple-value-bind
657 (second minute hour date month year)
658 (decode-universal-time ut 0)
659 (format nil "~2,'0D-~A-~4,'0D~C~2,'0D:~2,'0D:~2,'0D"
660 date (svref months (1- month)) year #\U00A0
661 hour minute second))))
662
663(defun http-index-size (bytes)
664 (format nil "~,3F&nbsp;KB" (float (/ bytes 1024))))
665
666(defun http-send-index (stream path)
667 (let ((title (html-escape (format nil "Index of ~A" (path-virtual path))))
668 (dirs
669 (sort (remove-if-not
670 #'path-valid
671 (mapcar #'(lambda (d)
672 (concatenate 'string
673 (car (last (pathname-directory d)))
674 "/"))
675 (directory
676 (concatenate 'string
677 (path-real path) "/*/"))))
678 #'string-lessp))
679 (files
680 (sort (remove-if-not
681 #'path-valid
682 (mapcar #'file-namestring
683 (directory
684 (concatenate 'string
685 (path-real path) "/*.*"))))
686 #'string-lessp)))
687 (http-reply-send
688 stream
689 (do-html nil
690 (:html (:head (:title title))
691 (:body :style "background: #d0d0d0;"
692 (:h1 title)
693 (:/hr)
694 (:ul (:li (:a :href "../"
695 (:code "../") " (Parent directory)")))
696 (do-html-unless (or dirs files)
697 (:/hr)
698 (:h2 "Directory empty."))
699 (do-html-when dirs
700 (:/hr)
701 (:h2 "Directories")
702 (:ul
703 (do-html-loop (for i in dirs
704 for l = (html-escape i))
705 (:li (:a :href l (:code l))))))
706 (do-html-when files
707 (:/hr)
708 (:h2 "Files")
709 (:table :cellpadding "3"
710 (:tr (:th :width "70%" :align "left" (:b "Name"))
711 (:th :width "10%" :align "right" (:b "Size"))
712 (:th :width "20%" :align "center"
713 (:b "Modified&nbsp;(UTC)")))
714 (do-html-loop (for i in files
715 for c from 0
716 for color = (if (evenp c)
717 "#b0b0b0"
718 "#c0c0c0")
719 for l = (html-escape i)
720 for rpath = (concatenate 'string
721 (path-real path)
722 "/" i)
723 for lastmod = (html-escape
724 (http-index-time
725 (file-write-date rpath)))
a837d3f7
MM
726 for size = (handler-case
727 (with-open-file
728 (s rpath
729 :direction :input)
730 (file-length s))
731 (file-error ()
732 nil))
733 unless size do (incf c)
734 when size)
c0aa17ee
MM
735 (:tr :style (format nil "background: ~A;" color)
736 (:td (:a :href l (:code l)))
737 (:td :align "right" (:code (http-index-size size)))
738 (:td :align "center" (:code lastmod))))))
739 (:/hr)
740 (:small (html-escape *server-version*))))))))
741
742
743;;; HTTP request parsing
744
745;;; Decodes the URL supplied in STRING to another string, returning it.
746(defun url-decode (string)
747 (macrolet ((get-octet ()
748 `(if (= input-max input-pos)
749 (loop-finish)
750 (prog1
751 (aref input input-pos)
752 (the fixnum (incf (the fixnum input-pos))))))
753 (put-octet (o)
754 `(vector-push ,o output)))
755 (loop
756 with input = (utf-8-string-encode string)
757 with input-pos of-type fixnum = 0
758 with input-max of-type fixnum = (length input)
759 with output = (make-array (length input)
760 :element-type '(unsigned-byte 8)
761 :fill-pointer 0)
762 for o of-type (unsigned-byte 8) = (get-octet)
763 when (= 37 o) do (let ((c1 (code-char (get-octet)))
764 (c2 (code-char (get-octet))))
765 (when (and (digit-char-p c1 16)
766 (digit-char-p c2 16))
767 (put-octet (parse-integer
768 (map 'string #'identity `(,c1 ,c2))
769 :radix 16))))
770 else when (= 43 o) do (put-octet 32)
771 else do (put-octet o)
772 finally (return (utf-8-string-decode output)))))
773
774(defvar *url-safe-char-table*
775 (make-valid-character-table
776 (character-intervals '(#\A #\Z)
777 '(#\a #\z)
778 '(#\0 #\9))))
779
780;;; Encodes the supplied URL in STRING to another string, returning it.
781(defun url-encode (string)
782 (flet ((url-encode-char (c)
783 (if (character-valid-p *url-safe-char-table* c)
784 c
785 (reduce #'(lambda (a b)
786 (concatenate 'string a b))
787 (map 'list #'(lambda (o)
788 (format nil "%~2,'0X" o))
789 (utf-8-string-encode (string c)))))))
790 (with-output-to-string (out)
791 (with-input-from-string (in string)
792 (loop
793 for c = (handler-case
794 (read-char in)
795 (end-of-file ()
796 nil))
797 for toc = (if c (url-encode-char c) nil)
798 while toc
799 when (characterp toc) do (write-char toc out)
800 else do (write-string toc out))))))
801
802;;; Supplied with a hash table and a string set statement in the form
803;;; "variable=value" or "variable[]=value", add the association binding.
804;;; If the variable name terminates with "[]", it denotes that the variable
805;;; is an array, in which case multiple values may be accumulated into it.
806(defun property-set (ht str)
807 (let ((parts (string-split str :separators '(#\=) :max 2)))
808 (when (= (length parts) 2)
809 (let ((var (string-downcase (svref parts 0)))
810 (val (if (= 1 (length parts)) "" (svref parts 1)))
811 (array-p nil))
812 ;; Escape and sanity-check VAR
813 (setf var (url-decode var))
814 (when (and (> (length var) 0)
815 (every #'(lambda (c)
816 (or (alphanumericp c)
817 (member c '(#\- #\[ #\]) :test #'char=)))
818 var))
819 ;; Unescape VAL
820 (setf val (url-decode val))
821 ;; An array?
822 (let ((len (length var)))
823 (declare (type fixnum len))
824 (when (and (> len 2)
825 (char= #\] (schar var (- len 1)))
826 (char= #\[ (schar var (- len 2))))
827 (setf array-p t)))
828 (multiple-value-bind (o exists-p)
829 (gethash var ht)
830 (cond (array-p
831 ;; Array
832 (when (not exists-p)
833 (setf o (make-array 16
834 :element-type 'string
835 :adjustable t
836 :fill-pointer 0)
837 (gethash var ht) o))
838 (vector-push-extend val o 16))
839 (t
840 ;; Normal associative variable
841 (setf (gethash var ht) val)))))))))
842
843(defun http-get-parse (ht str)
844 (loop
845 with parts = (string-split str
846 :separators '(#\&)
847 :trim-parts '(#\Newline #\Return))
848 for p across parts
849 do
850 (property-set ht p)))
851
852;;; Reads the HTTP client request from STREAM, and returns two values,
853;;; a status keyword symbol and a list consisting of the collected lines.
854;;; :NO-REQUEST no request was sent (empty request)
855;;; :REQUEST-SIZE-EXCEEDED request exceeded allowed request size
856;;; :REQUEST-TIMEOUT allowed time for request to complete exceeded
857;;; :SUCCESS success
858(defun http-request-read (stream)
859 (loop
860 with config = *config*
861 with max-time of-type integer = (+ (server-time)
862 (config-request-timeout config))
863 with request-max-size of-type fixnum = (config-request-max-size config)
864 with timeout-signal = nil
865 for line = (handler-case
866 (line-read stream)
867 (sb-bsd-sockets:operation-timeout-error ()
868 (setf timeout-signal t)
869 "<TIMEOUT>"))
870 for words = (if (= nlines 0)
871 (string-split line :max 3)
872 #())
873 until timeout-signal ; Timeout signal
874 while (< chars request-max-size) ; Request size exceeded
875 while (< (server-time) max-time) ; Request timeout
876 until (string= "" line) ; End of HTTP/1.x request
877 until (and (= nlines 0) ; End of HTTP/0.x request
878 (< (length words) 3))
879 sum (length line) into chars of-type fixnum
880 count line into nlines of-type fixnum
881 collect line into lines
882 finally
883 (return
884 (values (cond
885 ((and (= nlines 0)
886 (= (length words) 0))
887 :no-request)
888 ((> chars request-max-size)
889 :request-size-exceeded)
890 ((or (>= (server-time) max-time)
891 timeout-signal)
892 :request-timeout)
893 ((and (= nlines 0)
894 (< (length words) 3))
895 (push line lines)
896 :success)
897 (t
898 :success))
899 lines))))
900
901;;; Request parsing preprocessor.
451d8738 902;;; Extracts query from the first request line and coalesces continuing
c0aa17ee
MM
903;;; header lines. Returns the request line as first value and the list
904;;; of preprocessed lines as second value.
905(defun http-request-parse-1 (lines)
906 (values (pop lines)
907 (loop
908 with list = '()
909 with last = nil
910 for line in lines
911 do
912 (cond ((and (let ((c (schar line 0)))
913 (or (char= #\Space c) (char= #\Tab c)))
914 last)
915 (setf (car last)
916 (concatenate 'string (car last) " "
917 (string-trim '(#\Space #\Tab)
918 line))))
919 (t
920 (let ((words
921 (string-split line
922 :separators '(#\:)
923 :trim-parts '(#\Space #\Tab)
924 :max 2)))
925 (when (= 2 (length words))
926 (push line list)
927 (setf last list)))))
928 finally (return list))))
929
930
931(defstruct http-request
932 (raw nil)
933 (protocol 0.9 :type (or null float))
934 (method nil)
935 (host nil)
936 (vhost *vhost-default*)
937 (path nil)
938 (query nil)
939 (post nil)
940 (vars-get (make-hash-table :test 'equal))
941 (vars-post (make-hash-table :test 'equal))
942 (vars-cookie (make-hash-table :test 'equal))
943 (agent nil)
944 (referer nil)
945 (keep-alive nil :type boolean)
946 (content-type "application/x-www-form-urlencoded")
947 (content-length -1 :type integer)
948 (modified-since nil)
949 (unmodified-since nil)
950 (range nil))
951
952(defun http-request-disable-keepalive (request)
953 (setf (http-request-keep-alive request) nil))
954
451d8738
MM
955;;; Parses an HTTP Range of the format [bytes=][from]-[to][,[from]-[to]...]
956;;; and returns a list of (or null integer) pairs. The range is not
957;;; checked for sanity yet, as this also requires knowing the size of
958;;; the resource. NIL is returned if the range(s) could not be parsed.
959;;; User code may use RANGE-VALIDATE to perform further validation and
960;;; processing.
961(defun range-parse (line)
962 (let* ((pos (search "bytes=" line :test #'string-equal))
963 (spos (if pos 6 0)))
964 ;; LOOP has better inlining potential than MAP below and is as clean
965 (loop
966 with l = (loop
967 with v = (string-split line
968 :separators '(#\,)
969 :start spos
970 :max 16)
971 for p across v
972 collect (concatenate 'string " " p " "))
973 for p in l
974 collect (loop
975 with v = (string-split p
976 :separators '(#\-)
977 :trim-parts '(#\Space)
978 :max 2)
979 for n across v
980 collect (parse-integer n :junk-allowed t)))))
981
982;;; This part of RFC 2616 seems to have been designed for humans, yet
983;;; software must deal with it, but this is a common theme in HTTP, like
984;;; the parsing of RFC 822/850/1123 dates intended for humans.
985;;; XXX Eventually cleanup this messy function
986(defun range-validate (req size)
987 "Attempts to validate client-provided range(s), if supplied.
988SIZE specifies the size of the resource to serve (i.e. a file length).
989On success, returns a list of pre-processed range pair(s) filled with actual
990byte offsets. On failure, returns :NOT-SATISFIABLE or NIL (empty list).
991The returned range has any overlapping ranges optimized and any redundant
992contiguous ranges coalesced for the caller. If the result only consists of
993a single range covering the whole document, NIL is returned."
994 (unless (http-request-range req)
995 (return-from range-validate nil))
996 ;; First convert human-friendly ambiguous ranges to actual byte ranges
997 (let* ((byte-ranges
998 (loop
999 with ranges = (http-request-range req)
1000 for r in ranges
1001 for (from to) = r
1002 do
1003 (cond ((null from)
1004 (when (null to)
1005 (return nil))
1006 (if (>= to size)
1007 (setf from 0
1008 to (1- size))
1009 (setf from (- size to)
1010 to (1- size))))
1011 ((null to)
1012 (when (null from)
1013 (return nil))
1014 (setf to (1- size)))
1015 (t
1016 (when (>= to size)
1017 (setf to (1- size)))))
1018 (unless (<= from to)
1019 (return nil))
1020 (unless (< to size)
1021 (return :not-satisfiable))
1022 collect (list from to)))
1023
1024 ;; Optimize any overlapping ranges, eliminating redundant ones
1025 (optimized-ranges
1026 (loop
1027 for r1 in byte-ranges
1028 for r2 = (loop
1029 for r3 in byte-ranges
1030 when (and (<= (first r1) (second r3))
1031 (>= (second r1) (first r3)))
1032 collect r3)
1033 for optimized = (list (reduce #'min r2 :key #'first)
1034 (reduce #'max r2 :key #'second))
1035 unless (member optimized final
1036 :test #'(lambda (a b)
1037 (and (= (first a) (first b))
1038 (= (second a) (second b)))))
1039 collect optimized into final
1040 finally (return (sort final #'(lambda (a b)
1041 (< (first a) (first b)))))))
1042
1043 ;; Coalesce any redundant contiguous ranges together
1044 (coalesced-ranges
1045 (loop
1046 for r on optimized-ranges
1047 when (and (cdr r)
1048 (= (second (car r))
1049 (1- (first (cadr r)))))
1050 collect (prog1
1051 (list (first (car r)) (second (cadr r)))
1052 (setf r (cdr r)))
1053 else
1054 collect (car r))))
1055
1056 ;; If there only remains a single range which covers the whole
1057 ;; document, ignore it.
1058 (if (and coalesced-ranges
1059 (destructuring-bind (from to) (first coalesced-ranges)
1060 (and (= 0 from) (= (1- size) to))))
1061 nil
1062 coalesced-ranges)))
1063
1064
c0aa17ee
MM
1065;;; List of headers we care about and functions to fill them.
1066;;; We later on fill a hash table using this list for fast lookups.
1067;;; CLOS could have been used instead after interning a keyword symbol
1068;;; from the header variable string, but that would probably be slower.
1069;;; The performance of a large COND, or of running this list, would vary
1070;;; depending on the order of received headers and number of headers we care
1071;;; about.
1072(defparameter *header-list*
1073 `(("host"
1074 ,#'(lambda (o v)
1075 (let* ((pos (position #\: v :from-end t))
1076 (h (if pos (subseq v 0 pos) v)))
1077 (setf (http-request-host o) v
1078 (http-request-vhost o) (vhost-query h :default t)))))
1079 ("user-agent"
1080 ,#'(lambda (o v)
1081 (setf (http-request-agent o) v)))
1082 ("referer"
1083 ,#'(lambda (o v)
1084 (setf (http-request-referer o) v)))
1085 ("connection"
1086 ,#'(lambda (o v)
1087 (cond ((string-equal "keep-alive" v)
1088 (setf (http-request-keep-alive o) t))
1089 ((string-equal "close" v)
1090 (setf (http-request-keep-alive o) nil)))))
1091 ("content-type"
1092 ,#'(lambda (o v)
1093 (setf (http-request-content-type o) v)))
1094 ("content-length"
1095 ,#'(lambda (o v)
1096 (let ((i (handler-case
1097 (parse-integer v)
1098 (t ()
1099 -1))))
1100 (setf (http-request-content-length o) i))))
1101 ("if-modified-since"
1102 ,#'(lambda (o v)
1103 (setf (http-request-modified-since o)
1104 (server-time-rfc-parse v))))
1105 ("if-unmodified-since"
1106 ,#'(lambda (o v)
1107 (setf (http-request-unmodified-since o)
1108 (server-time-rfc-parse v))))
1109 ("range"
1110 ,#'(lambda (o v)
451d8738 1111 (setf (http-request-range o) (range-parse v))))
c0aa17ee
MM
1112 ("cookie"
1113 ,#'(lambda (o v)
1114 (property-set (http-request-vars-cookie o) v)))))
1115
1116(defparameter *header-table*
1117 (let ((ht (make-hash-table :test 'equal)))
1118 (mapc #'(lambda (l)
1119 (destructuring-bind (field function) l
1120 (setf (gethash field ht) function)))
1121 *header-list*)
1122 ht))
1123
451d8738 1124
c0aa17ee
MM
1125;;; Reads and parses POST data request if any
1126;;; XXX Should at least also support "multipart/form-data" enctype
1127(defun http-post-parse (stream)
1128 (let* ((req *request*)
1129 (req-length (http-request-content-length req))
1130 (req-vhost (http-request-vhost req))
1131 (req-type (let* ((type (http-request-content-type req))
1132 (pos (position #\; type)))
1133 (if pos
1134 (subseq type 0 pos)
1135 type))))
1136 (unless (eq (http-request-method req) :post)
1137 (return-from http-post-parse))
1138 (unless (string= req-type "application/x-www-form-urlencoded")
1139 (http-error stream 415 "Unsupported Media Type"
1140 "The POST enctype \"~A\" is unsupported." req-type))
1141 (when (= -1 req-length)
1142 (http-error stream 411 "Length Required"))
1143 (unless (< 0 req-length (vhost-post-max-size req-vhost))
1144 (http-error stream 413 "Request Entity Too Large"))
1145 (let ((pd
1146 (handler-case
1147 (loop
1148 with max-time of-type integer = (+ (server-time)
1149 (vhost-post-timeout
1150 req-vhost))
1151 with timeout-signal = nil
1152 with vector = (make-array req-length
1153 :element-type 'character
1154 :initial-element #\Nul)
1155 sum (handler-case
1156 (read-sequence vector stream
1157 :start read-length)
1158 (simple-error ()
1159 (setf timeout-signal t)
1160 0)) into read-length
1161 until timeout-signal
1162 while (< (server-time) max-time)
1163 while (< read-length req-length)
1164 finally
1165 (progn
1166 (when (or (>= (server-time) max-time)
1167 timeout-signal)
1168 (http-error stream 408 "Request Timeout"))
1169 (return vector)))
1170 (ext:stream-decoding-error ()
1171 (http-error stream 500 "Internal Server Error"
1172 "Character decoding error.")))))
1173 (if pd
1174 (progn
1175 (http-get-parse (http-request-vars-post req) pd)
1176 pd)
1177 nil))))
1178
1179;;; To avoid constant INTERNing, simply match method strings to keywords.
1180;;; Matching symbols using EQ afterwards is simple and as efficient as matching
1181;;; numbers.
1182(defun method-keyword (method)
1183 (let* ((methods #("GET" "POST" "HEAD" "PUT"
1184 "DELETE" "TRACE" "CONNECT" "OPTIONS"))
1185 (keywords #(:get :post :head :put
1186 :delete :trace :connect :options))
1187 (pos (position method methods :test #'string=)))
1188 (if pos
1189 (svref keywords pos)
1190 :unknown)))
1191
1192;;; Used to parse the HTTP version
1193(defun parse-float (string)
1194 (when (char= #\. (char string 0))
1195 (setf string (concatenate 'string "0" string)))
1196 (let ((w (string-split string :separators '(#\.) :max 2)))
1197 (if (= 2 (length w))
1198 (let ((i1 (handler-case
1199 (parse-integer (aref w 0))
1200 (t ()
1201 nil)))
1202 (i2 (handler-case
1203 (parse-integer (aref w 1))
1204 (t ()
1205 nil))))
1206 (if (and i1 i2)
1207 (float (+ i1 (/ i2 (expt 10 (length (aref w 1))))))
1208 nil))
1209 nil)))
1210
1211;;; Parse supplied HTTP version STRING, returning NIL on error or
1212;;; a floating point representing the number.
1213(defun version-parse (string)
1214 (let ((w (string-split string :separators '(#\/) :max 2)))
1215 (if (and (= 2 (length w))
1216 (string-equal "HTTP" (aref w 0)))
1217 (parse-float (aref w 1))
1218 nil)))
1219
1220;;; Actual request parsing function.
1221(defun http-request-parse (lines stream)
1222 ;; Preprocessing
1223 (multiple-value-bind (request headers)
1224 (http-request-parse-1 lines)
1225 (let ((req (make-http-request))
1226 (valid nil))
1227 (setf (http-request-raw req) lines)
1228
1229 ;; Request method/path/protocol
1230 (let* ((words (string-split request :max 4))
1231 (nwords (length words)))
1232 (cond ((< nwords 3)
1233 (setf (http-request-method req) (method-keyword
1234 (svref words 0))
1235 (http-request-path req) (if (= 2 (length words))
1236 (svref words 1)
1237 "/")
1238 valid t))
1239 ((= 3 nwords)
1240 (setf (http-request-protocol req) (version-parse
1241 (svref words 2))
1242 (http-request-method req) (method-keyword
1243 (svref words 0))
1244 (http-request-path req) (svref words 1)
1245 valid t))))
1246
1247 ;; Keep-Alive on by default for >= HTTP/1.1, headers might change it
1248 (let ((protocol (http-request-protocol req)))
1249 (when (and protocol (>= protocol 1.1))
1250 (setf (http-request-keep-alive req) t)))
1251
1252 ;; Headers
1253 (when valid
1254 (loop
1255 with header-table = *header-table*
1256 for line in headers
1257 for var = (string-trim
1258 '(#\Space)
1259 (string-downcase
1260 (subseq line 0 (position #\: line))))
1261 for val = (string-trim
1262 '(#\Space)
1263 (subseq line (1+ (position #\: line :start
1264 (length var)))))
1265 for fun = (gethash var header-table)
451d8738
MM
1266 when fun do (ignore-errors ; Extra parsing carefulness
1267 (funcall fun req val))))
c0aa17ee
MM
1268
1269 ;; Separate path from query variables; fill in GET variables if any.
1270 (let* ((path (http-request-path req))
1271 (pos (position #\? path :test #'char=))
1272 (epos (position #\; path :test #'char= :from-end t)))
1273 (when pos
1274 (let ((get (subseq path (1+ pos) (if epos epos (length path)))))
1275 (setf (http-request-path req) (subseq path 0 pos)
1276 (http-request-query req) get)
1277 (http-get-parse (http-request-vars-get req) get))))
1278
1279 ;; Read and parse POST data if any
1280 (let ((*request* req))
1281 (setf (http-request-post req) (http-post-parse stream)))
1282
1283 ;; Finally return request object for eventual dispatching
1284 req)))
1285
1286
38e2dc27
MM
1287;;; HTTP variable access for user code
1288
c0aa17ee
MM
1289(defun req-var (req type &optional name default)
1290 "Queries the request environment REQ for a variable of TYPE :GET, :POST
1291or :COOKIE, named NAME \(may be a symbol or a string\). DEFAULT is
1292returned if no such binding exists \(which defaults to NIL\). If NAME is
1293omited, a list is returned of all variable bindings of the specified TYPE."
38e2dc27 1294 (let ((ht (cond ((eq :get type) ; CASE might not use EQ
c0aa17ee
MM
1295 (http-request-vars-get req))
1296 ((eq :post type)
1297 (http-request-vars-post req))
1298 ((eq :cookie type)
1299 (http-request-vars-cookie req))
1300 (t (error "TYPE not one of :GET :POST :COOKIE")))))
1301 (cond ((null name)
1302 (loop
1303 for key being each hash-key of ht using (hash-value val)
1304 collect `(,key ,val)))
1305 (t
1306 (multiple-value-bind (val exists-p)
1307 (gethash (string-downcase (string name)) ht)
1308 (if exists-p
1309 val
1310 default))))))
1311
1312(defmacro with-http-let (req bindings &body body)
1313 "Helper macro for REQ-VAR. Permits to perform multiple local bindings
1314with variables bound in the request environment REQ. BINDINGS consists of
1315a list of LET-like bindings with the following elements:
1316\(VAR TYPE &optional NAME DEFAULT\) where VAR is the variable to lexically
1317bind, TYPE is one of :GET, :POST or :COOKIE, NAME is the name of the
1318variable in the environment \(represented by a symbol or string\), and
1319DEFAULT is the default value to bind to VAR if NAME is not bound \(defaults
1320to NIL\). If NAME is omited, a list of all bound variables of TYPE in
1321REQ is bound to VAR."
1322 (let ((s-req (gensym)))
1323 `(let ((,s-req ,req))
1324 (let (,@(loop
1325 for binding in bindings
1326 for (var type name default) = binding
1327 collect `(,var (req-var ,s-req ,type ,name ,default))))
1328 ,@body))))
1329
1330
1331;;; Debugging
1332
1333(defvar *debug* '(:log :log-errors :test))
1334
1335(defun debug-feature (keyword)
1336 (let ((debug *debug*))
1337 (and debug (position keyword debug :test #'eq))))
1338
1339(defun beep ()
451d8738
MM
1340 (ignore-errors
1341 (with-open-file (s "/dev/speaker" :direction :output)
1342 (write-string "O1L15D" s))))
c0aa17ee
MM
1343
1344(defun dump-vars (ht)
1345 (with-output-to-string (out)
1346 (maphash #'(lambda (k v)
1347 (format out "~A = ~S~%" k v))
1348 ht)))
1349
1350
1351(defun html-test-page (req connection)
1352 (http-reply-send
1353 (connection-stream connection)
1354 (do-html nil
9fd068a8
MM
1355 (:html (:head (:title "Interactively developed test server")
1356 (:/link :rel "stylesheet"
1357 :href "/css/test.css"
1358 :type "text/css"))
c0aa17ee
MM
1359 (:body
1360 (:h1 "Interactively developed test server")
1361 (:p "This page, forms and server code may change anytime "
38e2dc27
MM
1362 "without interruption; a live SWANK connection can "
1363 "be maintained from Emacs and SLIME to the server, and "
1364 "the system is developed interactively as spare time "
1365 "permits. A particularity of Lisp is that it can be "
1366 "used as a scripting language interactively, with wanted "
451d8738 1367 "modified code blocks reapplied in the live image. "
9fd068a8 1368 "These code blocks may be reapplied as compiled bytecode "
38e2dc27 1369 "for interpretation (or in this case, using ECL, be "
451d8738
MM
1370 "recompiled efficiently to C, linked as a dynamic "
1371 "loadable module and reloaded immediately, which typing "
1372 "C-c C-c on a code block in Emacs automates).")
c0aa17ee
MM
1373 (:p
1374 "Follow " (:a :href "/" "this link") " to proceed to a "
1375 "mirror of my site hosted on this test server.")
1376 (:p
1377 "The source code of this server is also available "
1378 (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
1379 :target "_blank"
1380 "here") ".")
1381 (:p
1382 "The first test application can be found "
1383 (:a :href "/chat" "here") ", and a second one to help "
1384 "accumulate name suggestions for this server "
1385 (:a :href "/names" "here") ".")
1386
c0aa17ee
MM
1387 (:h2 "Test form")
1388 (:form :action (html-escape
1389 (format nil
1390 "/test?id=~64,'0X" (random
1391 #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)))
1392 :method "post"
1393 "First name: "
1394 (:/input :name "first-name"
1395 :type "text"
1396 :size "32"
1397 :maxlength "64"
1398 :value (html-escape
1399 (req-var req :post :first-name
1400 "First name")))
1401 (:/br)
1402 "Last name: "
1403 (:/input :name "last-name"
1404 :type "text"
1405 :size "32"
1406 :maxlength "64"
1407 :value (html-escape
1408 (req-var req :post :last-name
1409 "Last name")))
1410 (:/br)
1411 (do-html-loop (for i from 1 to 10
1412 for s = (format nil "~2,'0D" i)
1413 for v = (format nil "box-~2,'0D" i))
1414 "Box " s
1415 (let* ((a (req-var req :post :box[] nil))
1416 (c (if a (find v a :test #'string=) nil)))
1417 (do-html-if c
1418 (:/input :name "box[]"
1419 :type "checkbox"
1420 :value v
1421 :/checked)
1422 (:/input :name "box[]"
1423 :type "checkbox"
1424 :value v))))
1425 (:/br)
1426 (:textarea :name "message"
1427 :rows 10
1428 :cols 60
1429 (html-escape
1430 (req-var req :post :message
1431 "Message text.")))
1432 (:/br)
38e2dc27
MM
1433 (:/input :type "submit" :value "Post message"))
1434 (:h2 "Test form 2 (multipart/form-data)")
1435 (:p (:em "This test is expected to fail for now."))
c0aa17ee
MM
1436 (:form :action "/test"
1437 :method "post"
1438 :enctype "multipart/form-data"
1439 (:/input :name "description"
1440 :type "text"
1441 :size "32"
1442 :maxlength "64"
1443 :value (html-escape
1444 (req-var req :post :description
38e2dc27 1445 "File description")))
c0aa17ee
MM
1446 (:/br)
1447 (:/input :name "file"
1448 :type "file"
1449 :size "32"
1450 :maxlength "64"
1451 :value "File to send")
1452 (:/br)
1453 (:/input :type "submit"
38e2dc27
MM
1454 :value "Upload file"))
1455
1456 (:h2 "Client information")
1457 (:h3 "Originator")
1458 (:p (connection-address-string connection) ":"
1459 (connection-port connection))
1460 (:h3 "Browser request")
c0aa17ee
MM
1461 (:pre
1462 (do-html-loop (for line in (http-request-raw req))
1463 (html-escape (format nil "~A~%" line))))
38e2dc27
MM
1464
1465 (:h2 "Request state information")
1466 (:h3 "Path and VHost")
1467 (:p (html-escape (format nil "~S on ~S"
1468 (http-request-path req)
1469 (vhost-hostname
1470 (http-request-vhost req)))))
c0aa17ee 1471 (do-html-when (http-request-query req)
38e2dc27 1472 (:h3 "GET variables")
c0aa17ee
MM
1473 (:pre
1474 (html-escape (format nil "~A~%"
1475 (http-request-query req))))
1476 (:pre
1477 (html-escape (dump-vars (http-request-vars-get req)))))
1478 (do-html-when (http-request-post req)
38e2dc27 1479 (:h3 "POST variables")
c0aa17ee
MM
1480 (:pre
1481 (html-escape (format nil "~A~%"
1482 (http-request-post req))))
1483 (:pre
1484 (html-escape (dump-vars
1485 (http-request-vars-post req)))))
1486 (do-html-when (> (hash-table-count
1487 (http-request-vars-cookie req)) 0)
38e2dc27 1488 (:h3 "COOKIE variables")
c0aa17ee
MM
1489 (:pre
1490 (html-escape (dump-vars
1491 (http-request-vars-cookie req)))))
38e2dc27 1492
c0aa17ee
MM
1493 (:h2 "Server information")
1494 (:p *server-version* " "
1495 (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
1496 :target "_blank"
1497 "(Source available here)."))
1498 (:p (do-html-loop
1499 (with packages = (list-all-packages)
1500 for p in packages
1501 for s = (find-symbol "*RCSID*" p)
1502 for v = (if (and s (boundp s))
1503 (html-escape (symbol-value s)) nil)
1504 when v)
1505 (:code v) (:/br)))
1506 (:p "HTTP server uptime: " (server-uptime))
1507 (:code (html-escape (lisp-implementation-type)) " "
1508 (html-escape (lisp-implementation-version)) " ("
1509 (html-escape (first (mp::uname))) ")")
1510 (:p (:a :href "http://validator.w3.org/check?uri=referer"
1511 (:/img :src "/images/valid-xhtml.png"
1512 :alt "Valid XHTML 1.0 Transitional"
1513 :height "31"
1514 :width "88"))))))))
1515
1516(defun http-dynamic-dispatch (req connection path)
1517 (let ((method (http-request-method req))
1518 (stream (connection-stream connection)))
1519 (cond
1520 ;; HEAD not allowed for HTTP/0.9
1521 ((and (< (http-request-protocol req) 1.0) (eq :head method))
1522 (http-error stream 400 "Bad Request"
1523 "HTTP versions <= 0.9 have no HEAD method."))
1524 ;; Allow these for dynamic handlers
1525 ((member method '(:get :head :post) :test #'eq))
1526 ;; But forbid these
1527 ((member method '(:options :delete :trace) :test #'eq)
1528 (http-error stream 405 "Method Not Allowed"
1529 "Method not allowed for dynamic handlers."))
1530 ((eq :connect method)
1531 (http-error stream 405 "NO CARRIER")) ; Easter egg
1532 ;; Any other is unimplemented for dynamic content
1533 (t
1534 (http-error-unimplemented stream)))
1535 (unless path
1536 (http-error stream 403 "Forbidden"
1537 "You do not have the permission to access that resource.")))
1538
1539 (let ((vpath (path-virtual path)))
1540 (when (debug-feature :test)
1541 (when (string= "/test" vpath)
1542 (html-test-page req connection)))
1543 (let ((fun (vhost-handler-query (http-request-vhost req) vpath)))
1544 (when fun
a837d3f7
MM
1545 (handler-case
1546 (funcall fun req connection)
e45c0358
MM
1547 ((not (or http-reply-signal http-reply-signal-nokeepalive)) (c)
1548 (log-error c)
a837d3f7
MM
1549 (http-error (connection-stream connection) 500 "Internal Error"
1550 "A temporary internal error has occurred.")))
c0aa17ee
MM
1551 (return-from http-dynamic-dispatch t))))
1552 nil)
1553
1554(defun http-static-dispatch (req connection path)
1555 (let ((vhost (http-request-vhost req))
1556 (stream (connection-stream connection))
1557 truepath)
1558
1559 ;; Allowed method?
1560 (let ((method (http-request-method req)))
1561 (cond
1562 ;; HEAD not allowed for HTTP/0.9
1563 ((and (< (http-request-protocol req) 1.0) (eq :head method))
1564 (http-error stream 400 "Bad Request"
1565 "HTTP versions <= 0.9 have no HEAD method."))
1566 ;; Allow these for static content
1567 ((member method '(:get :head) :test #'eq))
1568 ;; But forbid these
1569 ((member method '(:options :delete :trace :post)
1570 :test #'eq)
1571 (http-error stream 405 "Method Not Allowed"
1572 "Method not allowed for static resources."))
1573 ((eq :connect method)
1574 (http-error stream 405 "NO CARRIER")) ; Easter egg
1575 ;; Any other is unimplemented for static content
1576 (t
1577 (http-error-unimplemented stream))))
1578 (unless path
1579 (http-error stream 403 "Forbidden"
1580 "You do not have the permission to access that resource."))
1581
a837d3f7
MM
1582 ;; File/directory exists? 404 if not, 403 on error.
1583 (handler-case
1584 (unless (setf truepath (probe-file (path-real path)))
1585 (http-error stream 404 "Not Found"
1586 "\"~A\" could not be found."
1587 (path-virtual path)))
1588 (file-error ()
1589 (http-error stream 403 "Forbidden"
1590 "You do not have the permission to access \"~A\"."
1591 (path-virtual path))))
c0aa17ee
MM
1592
1593 ;; If a directory, send index file if exists, but 403 otherwise.
1594 (let ((s-truepath (directory-namestring truepath)))
1595 (when (and (= 0 (length (file-namestring truepath)))
1596 (eql (position #\/ s-truepath :test #'char= :from-end t)
1597 (1- (length s-truepath))))
1598 ;; Points to a directory, make sure that "/" is part of the path
1599 ;; not to confuse browsers
1600 (let ((vpath (path-virtual path)))
1601 (unless (char= #\/ (schar vpath (1- (length vpath))))
1602 (http-redirect stream req (concatenate 'string
1603 vpath "/"))))
1604 ;; Check if we can find the index
1605 (let ((tp
1606 (probe-file
1607 (path-valid (concatenate 'string
1608 "/" (path-real path) "/"
1609 (vhost-index vhost))))))
1610 (setf truepath nil)
1611 (if tp
1612 (setf truepath tp)
1613 (if (vhost-autoindex vhost)
1614 (http-send-index stream path)
1615 (http-error stream 403 "Forbidden"
1616 "You do not have the permission to access \"~A\"."
1617 (path-virtual path)))))))
1618
1619 ;; Prepare to send file
1620 (when truepath
1621 (let* ((mime-type (mime-query
1622 (path-extension (file-namestring truepath))))
1623 (reply (make-http-reply :mime-type mime-type
1624 :charset (vhost-charset vhost)))
1625 (lastmodsecs (file-write-date truepath))
1626 (lastmod (server-time-rfc lastmodsecs)))
1627
1628 ;; If-modified/If-unmodified
1629 (let ((modified-since (http-request-modified-since req)))
1630 (when (and modified-since
1631 (<= lastmodsecs modified-since))
1632 (setf (http-reply-code reply) 304
1633 (http-reply-description reply) "Not Modified")
1634 (http-reply-flush reply stream 0)))
1635 (let ((unmodified-since (http-request-unmodified-since req)))
1636 (when (and unmodified-since
1637 (> lastmodsecs unmodified-since))
1638 (setf (http-reply-code reply) 412
1639 (http-reply-description reply) "Precondition Failed")
1640 (http-reply-flush reply stream 0)))
1641
c0aa17ee 1642 ;; Finally send file (except for HEAD)
451d8738
MM
1643 (http-reply-header-set reply (list "Last-Modified" "~A" lastmod))
1644
a837d3f7
MM
1645 (handler-case
1646 (progn
1647 (with-open-file (in truepath
1648 :direction :input
1649 :element-type '(unsigned-byte 8))
451d8738
MM
1650 (let* ((size (file-length in))
1651 (ranges (range-validate req size)))
1652 (when (eq :not-satisfiable ranges)
1653 (http-error stream 416
1654 "Requested Range Not Satisfiable"))
1655
1656 (cond ((null ranges)
1657
1658 ;; Optimized for full file transfer
1659 (http-reply-flush reply stream size)
1660 (unless (eq :head (http-request-method req))
1661 (loop
1662 with seq = *buffer*
1663 with seqsize of-type fixnum = (array-dimension seq 0)
1664 for len of-type fixnum = (read-sequence seq in)
1665 do (write-sequence seq stream :end len)
1666 while (= seqsize len))
1667 (finish-output stream)))
1668
1669 (t
1670
1671 ;; Transfer ranges
1672 (let ((multiple-ranges-p (> (length ranges) 1))
1673 (offset 0)
1674 (boundary-string nil))
1675 (cond (multiple-ranges-p
1676 ;; XXX Perhaps use BASE64 instead of 16 below
1677 (setf boundary-string (format nil "~64,'0X" (random #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
1678 (http-reply-flush-signal reply) nil
1679 (http-reply-flush-len reply) nil
1680 (http-reply-code reply) 206
1681 (http-reply-description reply) "Partial Content")
1682 (http-reply-header-set
1683 reply
1684 (list "Content-Type"
1685 "multipart/byteranges; boundary=~A"
1686 boundary-string))
1687 (http-reply-flush reply stream)
1688 (http-reply-header-set
1689 reply
1690 (list "Content-Type" "~A; charset=~A"
1691 (http-reply-mime-type reply)
1692 (symbol-name (http-reply-charset reply))))
1693 (http-reply-header-unset reply "Date")
1694 (http-reply-header-unset reply "Last-Modified")
1695 (http-reply-header-unset reply "Server"))
1696 (t
1697 (setf (http-reply-code reply) 206
1698 (http-reply-description reply) "Partial Content")
1699 (destructuring-bind (from to) (first ranges)
1700 (http-reply-header-set reply
1701 (list "Content-Range"
1702 "bytes ~D-~D/~D"
1703 from to size))
1704 (http-reply-flush reply stream (- to from)))))
1705 (loop
1706 with orig-size = size
1707 with crlf = *crlf*
1708 for range in ranges
1709 for (from to) = range
1710 for size = (if (= to from)
1711 1
1712 (- to from))
1713 when (/= offset from) do (progn
1714 (file-position in from)
1715 (setf offset from))
1716 do
1717 (when multiple-ranges-p
1718 (format stream "--~A~A" boundary-string crlf)
1719 (http-reply-header-set
1720 reply
1721 (list "Content-Range" "bytes ~D-~D/~D"
1722 from to orig-size)
1723 (list "Content-Length" size))
1724 (write-string (http-reply-headers-string reply) stream))
1725 (loop
1726 with seq = *buffer*
1727 with seqsize of-type fixnum = (array-dimension seq 0)
1728 for len of-type fixnum = (read-sequence
1729 seq in
1730 :end (min seqsize size))
1731 do
1732 (write-sequence seq stream :end len)
1733 (decf size len)
1734 while (and (/= 0 len) (= seqsize len)))
1735 (when multiple-ranges-p
1736 (write-string crlf stream)) ; XXX Is this legal?
1737 (finish-output stream))))))))
1738
1739 ;; Handled errors
a837d3f7
MM
1740 (file-error ()
1741 (http-error stream 403 "Forbidden"
451d8738
MM
1742 "You do not have the permission to access \"~A\"."
1743 (path-virtual path)))))))
1744 (values))
1745
c0aa17ee
MM
1746
1747;;; Actual entry point from SERVER
1748(defun http-serve (connection)
1749 (loop
1750 with config = *config*
1751 with max-size = (config-request-max-size config)
1752 with keep-alive of-type boolean = nil
1753 with keep-alive-max of-type fixnum = (config-request-keepalive-max
1754 config)
1755 for keep-alive-count of-type fixnum from 0 below keep-alive-max
1756 do
1757 (when (debug-feature :beep)
1758 (beep))
1759 (handler-case
1760 (let* ((stream (connection-stream connection))
1761 (session (connection-session connection)))
1762
1763 (when (= 1 keep-alive-count)
1764 (setf (connection-input-timeout connection)
1765 (config-request-keepalive-timeout config)))
1766 (multiple-value-bind (status lines)
1767 (http-request-read stream)
1768
1769 (when (eq :no-request status)
1770 (unless keep-alive
1771 (when (debug-feature :log-errors)
51017907
MM
1772 (log-line "~X ~A No request"
1773 session
1774 (connection-address-string connection))))
c0aa17ee
MM
1775 (return-from http-serve nil))
1776
1777 (let* ((req (http-request-parse lines stream))
1778 (*request* req)
1779 (vhost (http-request-vhost req))
1780 (path (vhost-path vhost (http-request-path req))))
1781
1782 (unless keep-alive
1783 (setf keep-alive (http-request-keep-alive req)))
1784
1785 (when (debug-feature :log-requests)
1786 (let ((*print-pretty* nil))
51017907
MM
1787 (log-line "~X ~A ~S"
1788 session
1789 (connection-address-string connection)
1790 req)))
c0aa17ee
MM
1791
1792 (cond ((eq :success status))
1793 ((eq :request-size-exceeded status)
1794 (when (debug-feature :log-errors)
51017907
MM
1795 (log-line "~X ~A Query length exceeds ~A bytes"
1796 session
1797 (connection-address-string connection)
1798 max-size))
c0aa17ee
MM
1799 (http-error stream 413 "Request Entity Too Large"
1800 "Query length exceeds ~A bytes."
1801 max-size))
1802 ((eq :request-timeout status)
1803 (unless keep-alive
1804 (when (debug-feature :log-errors)
51017907
MM
1805 (log-line "~X ~A Request Timeout"
1806 session
1807 (connection-address-string
1808 connection)))
c0aa17ee
MM
1809 (http-error stream 408 "Request Timeout"))
1810 (return-from http-serve nil)))
1811
1812 ;; We could alternatively accept HTTP > 1.1 and behave
1813 ;; like for HTTP 1.1.
1814 ;; XXX Also see RFC 2616 section 3.1 and RFC 2145
1815 ;; about replying with a version Entity.
1816 (let ((protocol (http-request-protocol req)))
1817 (when (or (null protocol)
1818 (>= protocol 2.0))
1819 (when (debug-feature :log-errors)
51017907
MM
1820 (log-line "~X ~A Unsupported protocol version ~A"
1821 session
1822 (connection-address-string connection)
1823 protocol))
c0aa17ee
MM
1824 (http-error stream 505 "Version Not Supported"
1825 "This server supports HTTP versions <= 2.0.")))
1826 (when (and (>= (http-request-protocol req) 1.1)
1827 (null (http-request-host req)))
1828 (http-error stream 400 "Bad Request"
1829 "HTTP versions >= 1.1 require a Host header."))
1830
1831 ;; Prioritize any existing dynamic handler over static
1832 (unless (http-dynamic-dispatch req connection path)
1833 (http-static-dispatch req connection path)))))
1834
1835 (http-reply-signal-no-keepalive ()
1836 (loop-finish))
1837 (http-reply-signal ()
1838 t)
1839 (end-of-file ()
1840 (unless keep-alive
1841 (when (debug-feature :log-errors)
51017907
MM
1842 (log-line "~X ~A End of file"
1843 (connection-session connection)
1844 (connection-address-string connection))))
c0aa17ee
MM
1845 (loop-finish)))
1846 while keep-alive)
1847 nil)
1848
1849;;; Second entry point from SERVER to handle errors
1850(defun http-overflow (connection reason)
1851 (declare (ignore reason))
1852 (handler-case
1853 (let ((stream (connection-stream connection)))
1854 (http-error stream 403.9 "Too many connections"
1855 "Connection limit exceeded for your address. Try again later."))
1856 (http-reply-signal ()
1857 t))
1858 nil)
1859
1860
1861;;; Initialization and startup
1862
1863(defvar *initialized* nil)
1864
1865;; Set a minimal default vhost
1866(vhost-register (make-vhost :hostname "localhost"
1867 :root "/tmp/htdocs/"
1868 :autoindex nil))
1869
1870#-:mm-ecl-standalone
1871(eval-when (:load-toplevel :execute)
1872 ;; Not standalone, attempt to load config file in current path
4bcf8ca1
MM
1873 (handler-case
1874 (load "httpd-config.lisp")
1875 (error (e)
1876 (format *error-output* "~%Error loading configuration file~%~A~%"
1877 e))))
c0aa17ee
MM
1878
1879(defun httpd-init ()
1880 (check-type *config* httpd-config)
f1f7c601
MM
1881 (let* ((config *config*)
1882 (server-config (config-server-config config)))
c0aa17ee
MM
1883 (check-type server-config server-config)
1884 (setf *debug* (config-debug config)
1885 (server::config-serve-function server-config) #'http-serve
1886 (server::config-overflow-function server-config) #'http-overflow
1887 (server::config-buffer server-config) 65536
1888 (server::config-log-connections server-config) (debug-feature
1889 :log-connections))
1890 (server-init server-config)
1891 (setf *config* config
1892 *initialized* t))
1893 t)
1894
c0aa17ee
MM
1895(defun httpd-cleanup ()
1896 (if *initialized*
1897 (progn
1898 (server-cleanup)
1899 (setf *initialized* nil)
1900 t)
1901 nil))
1902
51017907
MM
1903
1904;;; Initialize implicitely if started in interactive mode
1905
1906#-:mm-ecl-standalone
1907(httpd-init)
1908
1909
1910;;; Standalone/daemon mode handling
1911
c0aa17ee 1912#+:mm-ecl-standalone
51017907
MM
1913(defun swank-loop ()
1914 ;; Set the default debug hook to log and exit
1915 (setf *debugger-hook* #'(lambda (condition hook)
1916 (declare (ignore hook))
1917 (server::log-error condition)
1918 (ext:exit -1)))
1919
1920 ;; Launch swank is necessary, or just loop
1921 (cond ((config-swank-create-server *config*)
1922 (push :unix *features*)
1923 (load (config-swank-loader *config*))
1924 (with-input-from-string (s
1925"(swank-loader:init :delete nil
1926 :reload nil
1927 :load-contribs nil)")
1928 (with-log-errors
1929 (eval (read s))))
1930 (with-input-from-string (s (format nil
1931"(let ((swank::*loopback-interface* ~S))
1932 (swank:create-server :dont-close t
1933 :port ~D)))"
1934 (config-swank-address *config*)
1935 (config-swank-port *config*)))
1936 (with-log-errors
1937 (eval (read s)))
1938 (ext:exit)))
1939 (t
1940 (with-log-errors
1941 (loop
1942 do
1943 (sleep 60)))
1944 (ext:exit))))
1945
c0aa17ee
MM
1946#+:mm-ecl-standalone
1947(defparameter config-file nil)
51017907 1948
c0aa17ee
MM
1949#+:mm-ecl-standalone
1950(defun standalone-main ()
1951 (let ((ext:*lisp-init-file-list* nil))
1952 (defun help (stream)
1953 (format stream "~%~A [-config <file>]~%" (first ext:*command-args*))
1954 (ext:quit 1))
1955
1956 (handler-case
1957 (ext:process-command-args
1958 :rules '(("-config" 1 (setf config-file 1) :noloadrc)
1959 ("*DEFAULT*" 0 (help *standard-output*))))
1960 (error ()
1961 (help *error-output*)))
1962
1963 (unless config-file
1964 (help *error-output*))
1965
1966 (handler-case
af8238cc
MM
1967 (let ((*load-verbose* t))
1968 (load config-file))
4bcf8ca1
MM
1969 (error (e)
1970 (format *error-output* "~%Error loading configuration file~%~A~%" e)
c0aa17ee
MM
1971 (ext:quit -1)))
1972 (httpd-init)
1973 (swank-loop)))
51017907 1974
c0aa17ee
MM
1975#+:mm-ecl-standalone
1976(standalone-main)