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