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