Add an ACCEPT function to wrap SOCKET-ACCEPT and make it ignore any
[mmondor.git] / mmsoftware / cl / server / httpd.lisp
CommitLineData
35971726 1;;;; $Id: httpd.lisp,v 1.21 2012/09/12 21:58:43 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.
0fd8b8a2
MM
71;;;; - Verify why file transfers are done in 1024 byte blocks rather than
72;;;; 65536 ones. Perhaps the underlaying stdio buffering, if any...
c0aa17ee
MM
73
74
75(declaim (optimize (speed 3) (safety 1) (debug 3)))
76
4bcf8ca1
MM
77#+:mm-ecl-standalone
78(setf *load-verbose* nil)
79(eval-when (:compile-toplevel #-:mm-ecl-standalone :load-toplevel)
c0aa17ee
MM
80 (load "ecl-mp-server")
81 (load "html")
82 (load "character"))
83
84(defpackage :httpd
85 (:use :cl :server :html :character)
86 (:export #:httpd-config
87 #:make-httpd-config
88 #:httpd-init
89 #:vhost
90 #:make-vhost
91 #:vhost-register
92 #:vhost-unregister
93 #:vhost-handler-register
94 #:vhost-handler-list
95 #:vhost-handler-unregister
96 #:mime-register
97 #:mime-unregister
98 #:mime-query
99 #:mime-load
100 #:mime-reload
101 #:http-reply
102 #:make-http-reply
451d8738
MM
103 #:http-reply-header-set
104 #:http-reply-header-get
105 #:http-reply-header-unset
106 #:http-reply-header-set-nocache
c0aa17ee
MM
107 #:http-reply-content-add
108 #:http-reply-log-time
109 #:http-reply-flush
110 #:http-reply-send
111 #:http-error
112 #:http-redirect
113 #:url-decode
114 #:url-encode
115 #:req-var
22b9809f 116 #:with-http-let
451d8738 117 #:range-validate
c0aa17ee
MM
118 #:debug-feature))
119
120(in-package :httpd)
121
122(defparameter *rcsid*
35971726 123 "$Id: httpd.lisp,v 1.21 2012/09/12 21:58:43 mmondor Exp $")
c0aa17ee
MM
124
125(defparameter *server-version*
126 (let ((parts (string-split *rcsid*
127 :separators '(#\Space #\,))))
128 (concatenate 'string
129 (svref parts 1) "/" (svref parts 3))))
130
131
132(defstruct (httpd-config (:conc-name config-))
133 (server-config nil :type (or null
134 server:server-config))
135 ;; Supported DEBUG features:
136 ;; :log-requests :log-connections :log-errors :test :beep
137 (debug '(:log :log-errors :test) :type list)
138
51017907
MM
139 ;; For the standalone-mode swank server
140 (swank-create-server t :type boolean)
141 (swank-loader "/home/foo/slime/swank-loader" :type string)
142 (swank-address "127.0.0.1" :type string)
143 (swank-port 4005 :type fixnum)
144
c0aa17ee
MM
145 (request-timeout 60 :type fixnum)
146 (request-max-size 4096 :type fixnum)
147 (request-keepalive-timeout 20 :type fixnum)
148 (request-keepalive-max 100 :type fixnum)
149 (request-log t :type boolean)) ; XXX Optional?
150
151(defvar *config* (make-httpd-config :server-config (make-server-config)))
152
153
154;;; Paths
155
156(defvar *path-max* 255)
157(defvar *path-valid-char-table*
158 (make-valid-character-table (character-intervals
159 '(#\a #\z)
160 '(#\A #\Z)
161 '(#\0 #\9)
162 #\. #\/ #\- #\_)))
163
164;;; Returns copy of PATH or NIL. Always begins with "/", with multiple
165;;; "/" collapsed into one. Makes sure that PATH only contains allowed
166;;; characters (in *PATH-VALID-CHAR-TABLE*) and is shorter than *PATH-MAX*.
167;;; Does not allow '.' at the start of PATH or after any '/'.
168(defun path-valid (path)
169 (let ((out (make-array (1+ (length path))
170 :element-type 'character
171 :fill-pointer 0)))
172 (macrolet ((add-char (c)
173 `(vector-push ,c out)))
174 (add-char #\/)
175 (if
176 (loop
177 with char-table = *path-valid-char-table*
178 with last of-type character = #\/
179 for c of-type character across path
180 do
181 (block continue
182 (when (char= #\/ last)
183 ;; Collapse multiple '/' and prohibit '.' at start
184 (if (char= #\/ c)
185 (return-from continue)
186 (when (char= #\. c)
187 (return nil))))
188 (unless (character-valid-p char-table c)
189 (return nil))
190 (add-char c)
191 (setf last c))
192 finally (return out))
193 (if (> (length out) *path-max*)
194 nil
195 out)
196 nil))))
197
198(defstruct path
199 real virtual)
200
201;;; Should always be called when processing user-supplied paths.
202;;; The application should then only trust the objects returned by
203;;; this function. Returns NIL if the path is invalid. On success,
204;;; returns a PATH object with:
205;;; REAL: System-wide absolute real fullpath, to be used to access the
206;;; file/directory in question
207;;; VIRTUAL: The virtual root based absolute fullpath, useful to report
208;;; to the user.
209;;; Note that supplied ROOT should previously have been passed through
210;;; PATH-VALID, and that both ROOT and PATH should be absolute paths.
211(defun path-valid-virtual (root path)
212 (let* ((virtual (path-valid (concatenate 'string "/" path)))
213 (real (if virtual (path-valid (concatenate 'string
214 "/" root "/" virtual))
215 nil)))
216 (if (and virtual real)
217 (make-path :real real
218 :virtual virtual)
219 nil)))
220
221(defun path-extension (path)
222 (let ((dot (position #\. path
223 :test #'char=
224 :from-end t)))
225 (if dot
226 (string-downcase (subseq path (1+ dot)))
227 nil)))
228
229
230;;; VHosts
231
232(defvar *vhost-default* nil)
233
234(defstruct vhost
235 (hostname "" :type string :read-only t)
236 (root "/" :type string)
237 (index "/index.html" :type string)
238 (charset :utf-8 :type keyword)
239 (autoindex nil :type boolean)
240 (post-max-size 1048576 :type integer)
241 (post-timeout 240 :type fixnum)
242 (%handlers (make-hash-table :test #'equal) :type hash-table :read-only t))
243
244(defvar *vhosts* (make-hash-table :test #'equal))
245(defvar *vhosts-lock* (mp:make-lock :name 'vhosts-lock))
246
247(defun vhost-register (vhost &key (aliases '()) (default nil))
248 (check-type vhost vhost)
249 (check-type aliases list)
250 (check-type default boolean)
251 (with-accessors ((name vhost-hostname)
252 (root vhost-root)
253 (index vhost-index)) vhost
254 (unless (path-valid root)
255 (error "Invalid root path \"~A\"" root))
256 (unless (path-valid index)
257 (error "Invalid index path \"~A\"" index))
258 (mp:with-lock (*vhosts-lock*)
259 (let ((vhosts *vhosts*))
260 (setf (gethash (string-downcase name) vhosts) vhost)
261 (loop
262 for alias in aliases
263 do
264 (setf (gethash (string-downcase alias) vhosts) vhost))
265 (when default
266 (setf *vhost-default* vhost)))))
267 t)
268
269(defun vhost-unregister (name)
270 (mp:with-lock (*vhosts-lock*)
271 (let ((vhosts *vhosts*))
272 (multiple-value-bind (vhost exists-p)
273 (gethash (string-downcase name) vhosts)
274 (when exists-p
275 (loop
276 for key being each hash-key of vhosts using (hash-value val)
277 when (eq val vhost) do (remhash key vhosts))))))
278 t)
279
280(defun vhost-query (name &key (default nil))
281 (mp:with-lock (*vhosts-lock*)
282 (multiple-value-bind (vhost exists-p)
283 (gethash (string-downcase name) *vhosts*)
284 (let ((vhost-default *vhost-default*))
285 (cond ((and default vhost-default (not exists-p))
286 vhost-default)
287 (exists-p
288 vhost)
289 (t
290 nil))))))
291
292;;; User-supplied paths should be passed through this function, returning
293;;; NIL or an object supplied by PATH-VALID-VIRTUAL on VHOST's ROOT and
294;;; PATH.
295(defun vhost-path (vhost path)
296 (path-valid-virtual (vhost-root vhost) path))
297
298;;; VHost dynamic handlers
299(defun vhost-handler-register (vhost-name handlers)
300 (let ((vhost (vhost-query vhost-name)))
301 (check-type vhost vhost)
302 (check-type handlers list)
303 (mp:with-lock (*vhosts-lock*)
304 (mapc #'(lambda (l)
305 (destructuring-bind (path function) l
306 (check-type path string)
307 (let ((vpath (string-downcase (path-valid path))))
308 (setf (gethash vpath (vhost-%handlers vhost))
309 function))))
310 handlers)))
311 nil)
312
313(defun vhost-handler-list (vhost-name)
314 (let* ((vhost (vhost-query vhost-name))
315 (list '()))
316 (when vhost
317 (mp:with-lock (*vhosts-lock*)
318 (maphash #'(lambda (k v)
319 (push `(,k ,v) list))
320 (vhost-%handlers vhost))))
321 (sort list #'string< :key #'first)))
322
323(defun vhost-handler-unregister (vhost-name handlers)
324 (let ((vhost (vhost-query vhost-name)))
325 (when (and vhost handlers)
326 (mp:with-lock (*vhosts-lock*)
327 (mapc #'(lambda (s)
328 (check-type s string)
329 (let ((function (gethash s (vhost-%handlers vhost))))
330 (when function
331 (remhash s (vhost-%handlers vhost)))))
332 handlers)))))
333
334(defun vhost-handler-query (vhost vpath)
335 (let ((function nil))
336 (mp:with-lock (*vhosts-lock*)
337 (let ((fun (gethash vpath (vhost-%handlers vhost))))
338 (setf function fun)))
339 function))
340
341
342;;; Mime types
343
344(defvar *mime-type-table* (make-hash-table :test #'equal))
345(defvar *mime-type-lock* (mp:make-lock :name 'mime-type-lock))
346(defvar *mime-type-file* "mime-types.lisp")
347(defvar *mime-types*)
348
349(defun mime-register (mimetype extensions)
350 (let ((type (string-downcase mimetype)))
351 (mp:with-lock (*mime-type-lock*)
352 (mapc #'(lambda (e)
353 (setf (gethash (string-downcase e) *mime-type-table*) type))
354 extensions))
355 type))
356
357(defun mime-register-list (types)
358 (mapc #'(lambda (type)
359 (destructuring-bind (mimetype extensions) type
360 (mime-register mimetype extensions)))
361 types)
362 t)
363
364(defun mime-unregister (extension)
365 (mp:with-lock (*mime-type-lock*)
366 (let ((table *mime-type-table*))
367 (multiple-value-bind (type exists-p)
368 (gethash (string-downcase extension) table)
369 (when exists-p
370 (loop
371 for key being each hash-key of table using (hash-value val)
372 when (eq val type) do (remhash key table))))))
373 t)
374
375(defun mime-query (extension &optional (default "application/octet-stream"))
376 (mp:with-lock (*mime-type-lock*)
377 (multiple-value-bind (type exists-p)
378 (gethash (string-downcase extension) *mime-type-table*)
379 (if exists-p
380 type
381 default))))
382
383(defun mime-load (file)
384 (load file)
385 (setf *mime-type-file* file)
386 (mime-register-list *mime-types*))
387
388(defun mime-reload ()
389 (load *mime-type-file*)
390 (mime-register-list *mime-types*))
391
392
393;;; HTTP reply
394
395;;; Dynamically bound to request object for us
396(defvar *request* nil)
397
398;;; Useful to elegantly longjmp back to the request reader as soon as a
399;;; request is flushed.
400(define-condition http-reply-signal
401 (simple-error)
402 ())
403
404(define-condition http-reply-signal-no-keepalive
405 (http-reply-signal)
406 ())
407
451d8738
MM
408(defstruct (http-reply (:constructor %make-http-reply))
409 (date (server-time-rfc) :type string)
410 (code 200 :type real)
411 (description "Ok" :type string)
412 (mime-type "text/html" :type string)
413 (charset :utf-8 :type keyword)
414 (headers '() :type list)
415 (content '() :type list)
416 (protocol 0.9 :type float)
417 (no-keepalive nil :type boolean)
418 (flush-log t :type boolean)
419 (flush-len t :type boolean)
420 (flush-signal t :type boolean))
421
422(defun make-http-reply (&rest keys)
423 (let* ((reply (apply #'%make-http-reply keys))
424 (request *request*))
425 (setf (http-reply-headers reply)
426 (list `("Server" . ,*server-version*)
427 '("Accept-Ranges" . "bytes")))
428 (when request
429 (setf (http-reply-charset reply)
430 (vhost-charset (http-request-vhost request))
431 (http-reply-protocol reply)
432 (let ((protocol (http-request-protocol request)))
433 (if protocol
434 protocol
435 0.9))
436 (http-reply-charset reply)
437 (vhost-charset (http-request-vhost request))))
438 reply))
439
440(defun http-reply-header-set (reply &rest pairs)
441 (with-accessors ((headers http-reply-headers)) reply
442 (loop
443 for pair in pairs
444 do
445 (destructuring-bind (key fmt &rest fmt-args) pair
446 (let* ((match (assoc key headers :test #'string-equal))
447 (line (if fmt-args
448 (apply #'format nil fmt fmt-args)
449 fmt)))
450 (if match
451 (rplacd match line)
452 (setf headers (acons key line headers)))))))
453 (values))
454
455(defun http-reply-header-get (reply key)
456 (assoc key (http-reply-headers reply) :test #'string-equal))
457
0fd8b8a2 458(defun http-reply-header-unset (reply &rest keys)
451d8738 459 (with-accessors ((headers http-reply-headers)) reply
0fd8b8a2
MM
460 (loop
461 for key in keys
462 for match = (assoc key headers :test #'string-equal)
463 when match do (rplacd match nil)))
451d8738
MM
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
ecdf3a46
MM
1650 (with-open-file (file-stream truepath
1651 :direction :input
1652 :element-type '(unsigned-byte 8))
1653 (let* ((size (file-length file-stream))
451d8738
MM
1654 (ranges (range-validate req size)))
1655 (when (eq :not-satisfiable ranges)
1656 (http-error stream 416
1657 "Requested Range Not Satisfiable"))
ecdf3a46 1658 (if ranges
1f844812
MM
1659 (file-send-ranges req reply stream file-stream size
1660 ranges)
1661 (file-send-full req reply stream file-stream size)))))
a837d3f7
MM
1662 (file-error ()
1663 (http-error stream 403 "Forbidden"
451d8738
MM
1664 "You do not have the permission to access \"~A\"."
1665 (path-virtual path)))))))
1666 (values))
1667
1f844812 1668(defun file-send-full (req reply stream file-stream size)
ecdf3a46
MM
1669 (http-reply-flush reply stream size)
1670 (unless (eq :head (http-request-method req))
1671 (loop
1672 with seq = *buffer*
1673 with seqsize of-type fixnum = (array-dimension seq 0)
1674 for len of-type fixnum = (read-sequence seq file-stream)
1675 do (write-sequence seq stream :end len)
1676 while (= seqsize len))
1677 (finish-output stream))
1678 (values))
1679
1f844812 1680(defun file-send-ranges (req reply stream file-stream size ranges)
ecdf3a46 1681 (let ((multiple-ranges-p (> (length ranges) 1))
11057264
MM
1682 (boundary-string nil)
1683 (parts '()))
ecdf3a46
MM
1684 (cond (multiple-ranges-p
1685
11057264
MM
1686 (let ((mr-content-length 0)
1687 (mr-reply (make-http-reply)))
1688 (setf boundary-string (format nil "~64,'0X" (random
1689 #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)))
1690
1691 ;; Populate PARTS and set MR-CONTENT-LENGTH.
1692 ;; This allows us to calculate the total reply Content-Length.
1693 (http-reply-header-unset mr-reply "Server" "Accept-Ranges")
1694 (http-reply-header-set mr-reply
ef3ef099
MM
1695 (list "Content-Type" "~A; charset=~A"
1696 (http-reply-mime-type reply)
1697 (symbol-name (http-reply-charset reply))))
1698 (loop
1699 with orig-size = size
1700 with crlf = *crlf*
1701 for range in ranges
1702 for (from to) = range
1703 for size = (- (1+ to) from)
1704 for headers = (with-output-to-string (out)
1705 (format out "--~A~A" boundary-string crlf)
1706 (http-reply-header-set mr-reply
1707 (list "Content-Range" "bytes ~D-~D/~D"
11057264 1708 from to orig-size))
ef3ef099
MM
1709 (write-string
1710 (http-reply-headers-string mr-reply) out))
1711 sum (+ (length headers)
1712 size
1713 2) into content-length of-type fixnum
1714 collect (list from to size headers) into list
1715 finally
1716 (setf mr-content-length (+ content-length 64 7) ; XXX odd
1717 parts list))
11057264
MM
1718
1719 ;; Setup initial REPLY object and flush its headers
1720 (setf (http-reply-flush-signal reply) nil
1721 (http-reply-flush-len reply) nil
1722 (http-reply-code reply) 206
1723 (http-reply-description reply) "Partial Content")
1724 (http-reply-header-set reply
ef3ef099
MM
1725 (list "Content-Type" "multipart/byteranges; boundary=~A"
1726 boundary-string)
1727 (list "Content-Length" "~D" mr-content-length))
11057264 1728 (http-reply-flush reply stream)))
ecdf3a46
MM
1729
1730 (t
11057264 1731
ef3ef099 1732 ;; Single range.
11057264 1733 ;; Fill PARTS and adapt and flush existing REPLY headers
ecdf3a46
MM
1734 (setf (http-reply-code reply) 206
1735 (http-reply-description reply) "Partial Content")
1736 (destructuring-bind (from to) (first ranges)
1737 (http-reply-header-set reply
ef3ef099 1738 (list "Content-Range" "bytes ~D-~D/~D" from to size))
11057264
MM
1739 (http-reply-flush reply stream (- (1+ to) from))
1740 (setf parts (list (list from to (- (1+ to) from) nil))))))
1741
ecdf3a46
MM
1742 (unless (eq :head (http-request-method req))
1743 (loop
ef3ef099 1744 with offset = 0
ecdf3a46 1745 with crlf = *crlf*
11057264
MM
1746 for part in parts
1747 for (from to size headers) = part
ecdf3a46
MM
1748 when (/= offset from) do (progn
1749 (file-position file-stream from)
1750 (setf offset from))
1751 do
1752 (when multiple-ranges-p
11057264 1753 (write-string headers stream))
ecdf3a46
MM
1754 (loop
1755 with seq = *buffer*
1756 with seqsize of-type fixnum = (array-dimension seq 0)
1757 for len of-type fixnum = (read-sequence
1758 seq file-stream
1759 :end (min seqsize size))
1760 do
1761 (write-sequence seq stream :end len)
1762 (decf size len)
1763 while (and (/= 0 len) (= seqsize len)))
1764 (when multiple-ranges-p
1765 (write-string crlf stream))
1766 (finish-output stream)
1767 finally
1768 (when multiple-ranges-p
1769 (format stream "--~A--~A" boundary-string crlf)
1770 (finish-output stream)))))
1771 (values))
c0aa17ee
MM
1772
1773;;; Actual entry point from SERVER
1774(defun http-serve (connection)
1775 (loop
1776 with config = *config*
1777 with max-size = (config-request-max-size config)
1778 with keep-alive of-type boolean = nil
1779 with keep-alive-max of-type fixnum = (config-request-keepalive-max
1780 config)
1781 for keep-alive-count of-type fixnum from 0 below keep-alive-max
1782 do
1783 (when (debug-feature :beep)
1784 (beep))
1785 (handler-case
1786 (let* ((stream (connection-stream connection))
1787 (session (connection-session connection)))
1788
1789 (when (= 1 keep-alive-count)
1790 (setf (connection-input-timeout connection)
1791 (config-request-keepalive-timeout config)))
1792 (multiple-value-bind (status lines)
1793 (http-request-read stream)
1794
1795 (when (eq :no-request status)
1796 (unless keep-alive
1797 (when (debug-feature :log-errors)
51017907
MM
1798 (log-line "~X ~A No request"
1799 session
1800 (connection-address-string connection))))
c0aa17ee
MM
1801 (return-from http-serve nil))
1802
1803 (let* ((req (http-request-parse lines stream))
1804 (*request* req)
1805 (vhost (http-request-vhost req))
1806 (path (vhost-path vhost (http-request-path req))))
1807
1808 (unless keep-alive
1809 (setf keep-alive (http-request-keep-alive req)))
1810
1811 (when (debug-feature :log-requests)
1812 (let ((*print-pretty* nil))
51017907
MM
1813 (log-line "~X ~A ~S"
1814 session
1815 (connection-address-string connection)
1816 req)))
c0aa17ee
MM
1817
1818 (cond ((eq :success status))
1819 ((eq :request-size-exceeded status)
1820 (when (debug-feature :log-errors)
51017907
MM
1821 (log-line "~X ~A Query length exceeds ~A bytes"
1822 session
1823 (connection-address-string connection)
1824 max-size))
c0aa17ee
MM
1825 (http-error stream 413 "Request Entity Too Large"
1826 "Query length exceeds ~A bytes."
1827 max-size))
1828 ((eq :request-timeout status)
1829 (unless keep-alive
1830 (when (debug-feature :log-errors)
51017907
MM
1831 (log-line "~X ~A Request Timeout"
1832 session
1833 (connection-address-string
1834 connection)))
c0aa17ee
MM
1835 (http-error stream 408 "Request Timeout"))
1836 (return-from http-serve nil)))
1837
1838 ;; We could alternatively accept HTTP > 1.1 and behave
1839 ;; like for HTTP 1.1.
1840 ;; XXX Also see RFC 2616 section 3.1 and RFC 2145
1841 ;; about replying with a version Entity.
1842 (let ((protocol (http-request-protocol req)))
1843 (when (or (null protocol)
1844 (>= protocol 2.0))
1845 (when (debug-feature :log-errors)
51017907
MM
1846 (log-line "~X ~A Unsupported protocol version ~A"
1847 session
1848 (connection-address-string connection)
1849 protocol))
c0aa17ee
MM
1850 (http-error stream 505 "Version Not Supported"
1851 "This server supports HTTP versions <= 2.0.")))
1852 (when (and (>= (http-request-protocol req) 1.1)
1853 (null (http-request-host req)))
1854 (http-error stream 400 "Bad Request"
1855 "HTTP versions >= 1.1 require a Host header."))
1856
1857 ;; Prioritize any existing dynamic handler over static
1858 (unless (http-dynamic-dispatch req connection path)
1859 (http-static-dispatch req connection path)))))
1860
1861 (http-reply-signal-no-keepalive ()
1862 (loop-finish))
1863 (http-reply-signal ()
1864 t)
1865 (end-of-file ()
1866 (unless keep-alive
1867 (when (debug-feature :log-errors)
51017907
MM
1868 (log-line "~X ~A End of file"
1869 (connection-session connection)
1870 (connection-address-string connection))))
c0aa17ee
MM
1871 (loop-finish)))
1872 while keep-alive)
1873 nil)
1874
1875;;; Second entry point from SERVER to handle errors
1876(defun http-overflow (connection reason)
1877 (declare (ignore reason))
1878 (handler-case
1879 (let ((stream (connection-stream connection)))
1880 (http-error stream 403.9 "Too many connections"
1881 "Connection limit exceeded for your address. Try again later."))
1882 (http-reply-signal ()
1883 t))
1884 nil)
1885
1886
1887;;; Initialization and startup
1888
1889(defvar *initialized* nil)
1890
1891;; Set a minimal default vhost
1892(vhost-register (make-vhost :hostname "localhost"
1893 :root "/tmp/htdocs/"
1894 :autoindex nil))
1895
1896#-:mm-ecl-standalone
1897(eval-when (:load-toplevel :execute)
1898 ;; Not standalone, attempt to load config file in current path
4bcf8ca1
MM
1899 (handler-case
1900 (load "httpd-config.lisp")
1901 (error (e)
1902 (format *error-output* "~%Error loading configuration file~%~A~%"
1903 e))))
c0aa17ee
MM
1904
1905(defun httpd-init ()
1906 (check-type *config* httpd-config)
f1f7c601
MM
1907 (let* ((config *config*)
1908 (server-config (config-server-config config)))
c0aa17ee
MM
1909 (check-type server-config server-config)
1910 (setf *debug* (config-debug config)
1911 (server::config-serve-function server-config) #'http-serve
1912 (server::config-overflow-function server-config) #'http-overflow
1913 (server::config-buffer server-config) 65536
1914 (server::config-log-connections server-config) (debug-feature
1915 :log-connections))
1916 (server-init server-config)
1917 (setf *config* config
1918 *initialized* t))
1919 t)
1920
c0aa17ee
MM
1921(defun httpd-cleanup ()
1922 (if *initialized*
1923 (progn
1924 (server-cleanup)
1925 (setf *initialized* nil)
1926 t)
1927 nil))
1928
51017907
MM
1929
1930;;; Initialize implicitely if started in interactive mode
1931
1932#-:mm-ecl-standalone
1933(httpd-init)
1934
1935
1936;;; Standalone/daemon mode handling
1937
c0aa17ee 1938#+:mm-ecl-standalone
51017907
MM
1939(defun swank-loop ()
1940 ;; Set the default debug hook to log and exit
1941 (setf *debugger-hook* #'(lambda (condition hook)
1942 (declare (ignore hook))
1943 (server::log-error condition)
1944 (ext:exit -1)))
1945
1946 ;; Launch swank is necessary, or just loop
1947 (cond ((config-swank-create-server *config*)
1948 (push :unix *features*)
1949 (load (config-swank-loader *config*))
1950 (with-input-from-string (s
1951"(swank-loader:init :delete nil
1952 :reload nil
1953 :load-contribs nil)")
1954 (with-log-errors
1955 (eval (read s))))
1956 (with-input-from-string (s (format nil
1957"(let ((swank::*loopback-interface* ~S))
1958 (swank:create-server :dont-close t
1959 :port ~D)))"
1960 (config-swank-address *config*)
1961 (config-swank-port *config*)))
1962 (with-log-errors
1963 (eval (read s)))
1964 (ext:exit)))
1965 (t
1966 (with-log-errors
1967 (loop
1968 do
1969 (sleep 60)))
1970 (ext:exit))))
1971
c0aa17ee
MM
1972#+:mm-ecl-standalone
1973(defparameter config-file nil)
51017907 1974
c0aa17ee
MM
1975#+:mm-ecl-standalone
1976(defun standalone-main ()
1977 (let ((ext:*lisp-init-file-list* nil))
1978 (defun help (stream)
1979 (format stream "~%~A [-config <file>]~%" (first ext:*command-args*))
1980 (ext:quit 1))
1981
1982 (handler-case
1983 (ext:process-command-args
1984 :rules '(("-config" 1 (setf config-file 1) :noloadrc)
1985 ("*DEFAULT*" 0 (help *standard-output*))))
1986 (error ()
1987 (help *error-output*)))
1988
1989 (unless config-file
1990 (help *error-output*))
1991
1992 (handler-case
af8238cc
MM
1993 (let ((*load-verbose* t))
1994 (load config-file))
4bcf8ca1
MM
1995 (error (e)
1996 (format *error-output* "~%Error loading configuration file~%~A~%" e)
c0aa17ee
MM
1997 (ext:quit -1)))
1998 (httpd-init)
1999 (swank-loop)))
51017907 2000
c0aa17ee
MM
2001#+:mm-ecl-standalone
2002(standalone-main)