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