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