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