- Replaced test-httpd.lisp by httpd.lisp
[mmondor.git] / mmsoftware / cl / server / httpd.lisp
CommitLineData
c0aa17ee
MM
1;;;; $Id: httpd.lisp,v 1.1 2012/08/27 20:58:42 mmondor Exp $
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.
41;;;; - Implement logging to file and possibly to syslog
42;;;; - Perhaps make the interface to HTTP-REPLY, HTTP-REPLY-SEND and
43;;;; HTTP-ERROR better so that user code doesn't always have to carry
44;;;; and care about STREAM, etc. *CONNECTION* already holds it...
45;;;; - Implement RANGE
46;;;; - URL to application server method dispatching, and setup to be
47;;;; used as a library by application servers
48;;;; - Perhaps support chunked streams
49;;;; - Multipart POST parsing so that files can be uploaded.
50;;;; Unfortunately, the silly standard does not make Content-Length
51;;;; obligatory, so less efficient ad-hoc line-based parsing must be used
52;;;; when it's absent.
53;;;; - Session helper code, with support for session ID cookie and
54;;;; anti-XSS GET session-tied IDs, URL generator to use these IDs,
55;;;; user session-specific variables/objects
56;;;; - Form generator with form-instance IDs for matching responses to
57;;;; queries
58;;;; - Make standalone mode specifying config file, that also includes Swank
59;;;; - Make config file specify mime-types file
60;;;; - Perhaps also separate vhosts configuration?
61;;;; - Separate out configuration and test applications
62;;;; - Rename test-httpd.lisp to a better name... Probably http-cons.lisp
63;;;; - Possibly implement simple filter types to allow the equivalent to the
64;;;; following directive for Apache+secmod:
65;;;; SecRule HTTP_User-Agent "GSLFbot" "deny,log,status:403"
66;;;; Determine if we should support these per-vhost, global or both.
67;;;; We might also want to define a hook system for configuration files
68;;;; to easily create custom filter code.
69;;;; - Perhaps make error handlers configurable. This could either be done
70;;;; using CLOS generic functions or a simpler, possibly faster dispatch
71;;;; system. Maybe also make the page indexer configurable.
72
73
74
75(declaim (optimize (speed 3) (safety 1) (debug 3)))
76
77(eval-when (:compile-toplevel :load-toplevel)
78 (load "ecl-mp-server")
79 (load "html")
80 (load "character"))
81
82(defpackage :httpd
83 (:use :cl :server :html :character)
84 (:export #:httpd-config
85 #:make-httpd-config
86 #:httpd-init
87 #:vhost
88 #:make-vhost
89 #:vhost-register
90 #:vhost-unregister
91 #:vhost-handler-register
92 #:vhost-handler-list
93 #:vhost-handler-unregister
94 #:mime-register
95 #:mime-unregister
96 #:mime-query
97 #:mime-load
98 #:mime-reload
99 #:http-reply
100 #:make-http-reply
101 #:http-reply-nocache
102 #:http-reply-header-add
103 #:http-reply-content-add
104 #:http-reply-log-time
105 #:http-reply-flush
106 #:http-reply-send
107 #:http-error
108 #:http-redirect
109 #:url-decode
110 #:url-encode
111 #:req-var
112 #:http-let
113 #:debug-feature))
114
115(in-package :httpd)
116
117(defparameter *rcsid*
118 "$Id: httpd.lisp,v 1.1 2012/08/27 20:58:42 mmondor Exp $")
119
120(defparameter *server-version*
121 (let ((parts (string-split *rcsid*
122 :separators '(#\Space #\,))))
123 (concatenate 'string
124 (svref parts 1) "/" (svref parts 3))))
125
126
127(defstruct (httpd-config (:conc-name config-))
128 (server-config nil :type (or null
129 server:server-config))
130 ;; Supported DEBUG features:
131 ;; :log-requests :log-connections :log-errors :test :beep
132 (debug '(:log :log-errors :test) :type list)
133
134 (request-timeout 60 :type fixnum)
135 (request-max-size 4096 :type fixnum)
136 (request-keepalive-timeout 20 :type fixnum)
137 (request-keepalive-max 100 :type fixnum)
138 (request-log t :type boolean)) ; XXX Optional?
139
140(defvar *config* (make-httpd-config :server-config (make-server-config)))
141
142
143;;; Paths
144
145(defvar *path-max* 255)
146(defvar *path-valid-char-table*
147 (make-valid-character-table (character-intervals
148 '(#\a #\z)
149 '(#\A #\Z)
150 '(#\0 #\9)
151 #\. #\/ #\- #\_)))
152
153;;; Returns copy of PATH or NIL. Always begins with "/", with multiple
154;;; "/" collapsed into one. Makes sure that PATH only contains allowed
155;;; characters (in *PATH-VALID-CHAR-TABLE*) and is shorter than *PATH-MAX*.
156;;; Does not allow '.' at the start of PATH or after any '/'.
157(defun path-valid (path)
158 (let ((out (make-array (1+ (length path))
159 :element-type 'character
160 :fill-pointer 0)))
161 (macrolet ((add-char (c)
162 `(vector-push ,c out)))
163 (add-char #\/)
164 (if
165 (loop
166 with char-table = *path-valid-char-table*
167 with last of-type character = #\/
168 for c of-type character across path
169 do
170 (block continue
171 (when (char= #\/ last)
172 ;; Collapse multiple '/' and prohibit '.' at start
173 (if (char= #\/ c)
174 (return-from continue)
175 (when (char= #\. c)
176 (return nil))))
177 (unless (character-valid-p char-table c)
178 (return nil))
179 (add-char c)
180 (setf last c))
181 finally (return out))
182 (if (> (length out) *path-max*)
183 nil
184 out)
185 nil))))
186
187(defstruct path
188 real virtual)
189
190;;; Should always be called when processing user-supplied paths.
191;;; The application should then only trust the objects returned by
192;;; this function. Returns NIL if the path is invalid. On success,
193;;; returns a PATH object with:
194;;; REAL: System-wide absolute real fullpath, to be used to access the
195;;; file/directory in question
196;;; VIRTUAL: The virtual root based absolute fullpath, useful to report
197;;; to the user.
198;;; Note that supplied ROOT should previously have been passed through
199;;; PATH-VALID, and that both ROOT and PATH should be absolute paths.
200(defun path-valid-virtual (root path)
201 (let* ((virtual (path-valid (concatenate 'string "/" path)))
202 (real (if virtual (path-valid (concatenate 'string
203 "/" root "/" virtual))
204 nil)))
205 (if (and virtual real)
206 (make-path :real real
207 :virtual virtual)
208 nil)))
209
210(defun path-extension (path)
211 (let ((dot (position #\. path
212 :test #'char=
213 :from-end t)))
214 (if dot
215 (string-downcase (subseq path (1+ dot)))
216 nil)))
217
218
219;;; VHosts
220
221(defvar *vhost-default* nil)
222
223(defstruct vhost
224 (hostname "" :type string :read-only t)
225 (root "/" :type string)
226 (index "/index.html" :type string)
227 (charset :utf-8 :type keyword)
228 (autoindex nil :type boolean)
229 (post-max-size 1048576 :type integer)
230 (post-timeout 240 :type fixnum)
231 (%handlers (make-hash-table :test #'equal) :type hash-table :read-only t))
232
233(defvar *vhosts* (make-hash-table :test #'equal))
234(defvar *vhosts-lock* (mp:make-lock :name 'vhosts-lock))
235
236(defun vhost-register (vhost &key (aliases '()) (default nil))
237 (check-type vhost vhost)
238 (check-type aliases list)
239 (check-type default boolean)
240 (with-accessors ((name vhost-hostname)
241 (root vhost-root)
242 (index vhost-index)) vhost
243 (unless (path-valid root)
244 (error "Invalid root path \"~A\"" root))
245 (unless (path-valid index)
246 (error "Invalid index path \"~A\"" index))
247 (mp:with-lock (*vhosts-lock*)
248 (let ((vhosts *vhosts*))
249 (setf (gethash (string-downcase name) vhosts) vhost)
250 (loop
251 for alias in aliases
252 do
253 (setf (gethash (string-downcase alias) vhosts) vhost))
254 (when default
255 (setf *vhost-default* vhost)))))
256 t)
257
258(defun vhost-unregister (name)
259 (mp:with-lock (*vhosts-lock*)
260 (let ((vhosts *vhosts*))
261 (multiple-value-bind (vhost exists-p)
262 (gethash (string-downcase name) vhosts)
263 (when exists-p
264 (loop
265 for key being each hash-key of vhosts using (hash-value val)
266 when (eq val vhost) do (remhash key vhosts))))))
267 t)
268
269(defun vhost-query (name &key (default nil))
270 (mp:with-lock (*vhosts-lock*)
271 (multiple-value-bind (vhost exists-p)
272 (gethash (string-downcase name) *vhosts*)
273 (let ((vhost-default *vhost-default*))
274 (cond ((and default vhost-default (not exists-p))
275 vhost-default)
276 (exists-p
277 vhost)
278 (t
279 nil))))))
280
281;;; User-supplied paths should be passed through this function, returning
282;;; NIL or an object supplied by PATH-VALID-VIRTUAL on VHOST's ROOT and
283;;; PATH.
284(defun vhost-path (vhost path)
285 (path-valid-virtual (vhost-root vhost) path))
286
287;;; VHost dynamic handlers
288(defun vhost-handler-register (vhost-name handlers)
289 (let ((vhost (vhost-query vhost-name)))
290 (check-type vhost vhost)
291 (check-type handlers list)
292 (mp:with-lock (*vhosts-lock*)
293 (mapc #'(lambda (l)
294 (destructuring-bind (path function) l
295 (check-type path string)
296 (let ((vpath (string-downcase (path-valid path))))
297 (setf (gethash vpath (vhost-%handlers vhost))
298 function))))
299 handlers)))
300 nil)
301
302(defun vhost-handler-list (vhost-name)
303 (let* ((vhost (vhost-query vhost-name))
304 (list '()))
305 (when vhost
306 (mp:with-lock (*vhosts-lock*)
307 (maphash #'(lambda (k v)
308 (push `(,k ,v) list))
309 (vhost-%handlers vhost))))
310 (sort list #'string< :key #'first)))
311
312(defun vhost-handler-unregister (vhost-name handlers)
313 (let ((vhost (vhost-query vhost-name)))
314 (when (and vhost handlers)
315 (mp:with-lock (*vhosts-lock*)
316 (mapc #'(lambda (s)
317 (check-type s string)
318 (let ((function (gethash s (vhost-%handlers vhost))))
319 (when function
320 (remhash s (vhost-%handlers vhost)))))
321 handlers)))))
322
323(defun vhost-handler-query (vhost vpath)
324 (let ((function nil))
325 (mp:with-lock (*vhosts-lock*)
326 (let ((fun (gethash vpath (vhost-%handlers vhost))))
327 (setf function fun)))
328 function))
329
330
331;;; Mime types
332
333(defvar *mime-type-table* (make-hash-table :test #'equal))
334(defvar *mime-type-lock* (mp:make-lock :name 'mime-type-lock))
335(defvar *mime-type-file* "mime-types.lisp")
336(defvar *mime-types*)
337
338(defun mime-register (mimetype extensions)
339 (let ((type (string-downcase mimetype)))
340 (mp:with-lock (*mime-type-lock*)
341 (mapc #'(lambda (e)
342 (setf (gethash (string-downcase e) *mime-type-table*) type))
343 extensions))
344 type))
345
346(defun mime-register-list (types)
347 (mapc #'(lambda (type)
348 (destructuring-bind (mimetype extensions) type
349 (mime-register mimetype extensions)))
350 types)
351 t)
352
353(defun mime-unregister (extension)
354 (mp:with-lock (*mime-type-lock*)
355 (let ((table *mime-type-table*))
356 (multiple-value-bind (type exists-p)
357 (gethash (string-downcase extension) table)
358 (when exists-p
359 (loop
360 for key being each hash-key of table using (hash-value val)
361 when (eq val type) do (remhash key table))))))
362 t)
363
364(defun mime-query (extension &optional (default "application/octet-stream"))
365 (mp:with-lock (*mime-type-lock*)
366 (multiple-value-bind (type exists-p)
367 (gethash (string-downcase extension) *mime-type-table*)
368 (if exists-p
369 type
370 default))))
371
372(defun mime-load (file)
373 (load file)
374 (setf *mime-type-file* file)
375 (mime-register-list *mime-types*))
376
377(defun mime-reload ()
378 (load *mime-type-file*)
379 (mime-register-list *mime-types*))
380
381
382;;; HTTP reply
383
384;;; Dynamically bound to request object for us
385(defvar *request* nil)
386
387;;; Useful to elegantly longjmp back to the request reader as soon as a
388;;; request is flushed.
389(define-condition http-reply-signal
390 (simple-error)
391 ())
392
393(define-condition http-reply-signal-no-keepalive
394 (http-reply-signal)
395 ())
396
397;;; XXX Accesses dynamic variable symbols more than once
398(defstruct http-reply
399 (date (server-time-rfc) :type string)
400 (code 200 :type real)
401 (description "Ok" :type string)
402 (headers (list
403 (format nil "Server: ~A" *server-version*)
404 "Accept-Ranges: bytes")
405 :type list)
406 (content '() :type list)
407 (mime-type "text/html" :type string)
408 (charset (if *request*
409 (vhost-charset (http-request-vhost *request*))
410 :utf-8)
411 :type keyword)
412 (protocol (if *request*
413 (let ((protocol (http-request-protocol *request*)))
414 (if protocol
415 protocol
416 0.9))
417 0.9)
418 :type float)
419 (no-keepalive nil))
420
421(defun http-reply-nocache (reply)
422 (nconc (http-reply-headers reply)
423 (list
424 "Expires: Mon, 26 Jul 1997 05:00:00 GMT"
425 (format nil "Last-Modified: ~A" (http-reply-date reply))
426 "Cache-Control: no-cache, must-revalidate"
427 "Pragma: no-cache")))
428
429(defun http-reply-header-add (reply fmt &rest fmt-args)
430 (push (apply #'format nil fmt fmt-args) (http-reply-headers reply)))
431
432(defun http-reply-content-add (reply content)
433 (push content (http-reply-content reply)))
434
435(defun http-reply-log-time (&optional (ut (server-time)))
436 (let ((months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
437 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
438 (multiple-value-bind
439 (second minute hour date month year)
440 (decode-universal-time ut 0)
441 (format nil "[~2,'0D/~A/~4,'0D:~2,'0D:~2,'0D:~2,'0D -0000]"
442 date (svref months (1- month)) year
443 hour minute second))))
444
445;;; Should only be called once per HTTP-REPLY object.
446;;; If size is not provided or is zero, signal HTTP-REPLY-SIGNAL.
447(defun http-reply-flush (reply stream &optional (size nil))
448 (let* ((config *config*)
449 (request *request*)
450 (encoding (if request
451 (vhost-charset (http-request-vhost request))
452 (vhost-charset *vhost-default*)))
453 (content (if (eq :utf-8 encoding)
454 (mapcar #'utf-8-string-encode
455 (http-reply-content reply))
456 (http-reply-content reply)))
457 (content-len (if size
458 size
459 (loop
460 for s in content
461 sum (length s) into len of-type fixnum
462 finally (return len))))
463 (crlf (format nil "~C~C" #\Return #\LineFeed)))
464
465 (when request
466 (let ((connection *connection*))
467 (when (http-reply-no-keepalive reply)
468 (http-request-disable-keepalive request))
469 (macrolet ((field (f &optional (type :string))
470 `(let ((%f ,f))
471 ,(if (eq type :string)
472 `(if %f %f "-")
473 `(if (zerop %f) "-" %f)))))
474 (when (config-request-log config)
475 (log-line-nostamp "~X ~A - - ~A ~A ~S ~A ~A \"~A\" \"~A\""
476 (connection-session connection)
477 (connection-address-string connection)
478 (http-reply-log-time)
479 (vhost-hostname (http-request-vhost request))
480 (first (http-request-raw request))
481 (http-reply-code reply)
482 (field content-len :integer)
483 (field (http-request-referer request))
484 (field (http-request-agent request)))))))
485
486 (when (> (http-reply-protocol reply) 0.9)
487 (with-accessors ((headers http-reply-headers)) reply
488 (push (format nil "Date: ~A" (http-reply-date reply)) headers)
489 (push (format nil "Content-Length: ~D" content-len) headers)
490 (push (format nil "Content-Type: ~A; charset=~A"
491 (http-reply-mime-type reply)
492 (symbol-name (http-reply-charset reply)))
493 headers)
494 (if (and request
495 (http-request-keep-alive request))
496 (when (= 1.0 (http-request-protocol request))
497 (push (format nil "Keep-Alive: timeout=~D, max=~D"
498 (config-request-keepalive-timeout config)
499 (config-request-keepalive-max config))
500 headers)
501 (push "Connection: Keep-Alive" headers))
502 (push "Connection: close" headers))
503 ;; Must push last so that it gets displayed first
504 (push (format nil "HTTP/1.1 ~A ~A"
505 (http-reply-code reply)
506 (http-reply-description reply))
507 headers)
508 (write-string
509 (concatenate 'string
510 (reduce #'(lambda (a b)
511 (concatenate 'string a crlf b))
512 headers)
513 crlf crlf)
514 stream)))
515 (unless size
516 (loop
517 with rcontent = (reverse content)
518 for s in rcontent
519 do
520 (write-sequence s stream)))
521 (finish-output stream))
522 (when (or (null size) (zerop size))
523 (error (make-condition (if (http-reply-no-keepalive reply)
524 'http-reply-signal-no-keepalive
525 'http-reply-signal))))
526 t)
527
528(defun http-reply-send (stream string)
529 (http-reply-flush (make-http-reply :content (list string)) stream))
530
531(defun http-error (stream code message &optional fmt &rest fmt-args)
532 (let ((reply (make-http-reply :code code
533 :description message
534 :no-keepalive t))
535 (description (if fmt
536 (apply #'format nil fmt fmt-args)
537 nil)))
538 (http-reply-nocache reply)
539 (http-reply-content-add
540 reply
541 (let ((title (html-escape (format nil "~A - ~A" code message))))
542 (do-html nil
543 (:html (:head (:title title))
544 (:body
545 (:h1 title)
546 (do-html-when description
547 (:p (html-escape description)))
548 (:small (html-escape *server-version*)))))))
549 (http-reply-flush reply stream)))
550
551(defun http-error-unimplemented (stream)
552 (let ((reply (make-http-reply :code 501
553 :description "Method Not Implemented"
554 :no-keepalive t)))
555 (http-reply-nocache reply)
556 (http-reply-header-add reply "Allow: GET, HEAD, POST")
557 (http-reply-content-add
558 reply
559 (let ((title "501 - Method Not Implemented"))
560 (do-html nil
561 (:html (:head (:title title))
562 (:body
563 (:h1 title)
564 (:small (html-escape *server-version*)))))))
565 (http-reply-flush reply stream)))
566
567(defun http-redirect (stream req vpath)
568 (let* ((vhost (http-request-vhost req))
569 (path (vhost-path vhost vpath))
570 (reply (make-http-reply :code 301
571 :description "Moved Permanently"
572 :charset (vhost-charset vhost)))
573 (movedto (format nil "http://~A~A"
574 (http-request-host req)
575 (if path (path-virtual path) nil)))
576 (title "301 - Moved Permanently"))
577 (unless path
578 (http-error stream 403 "Forbidden"
579 "You do not have the permission to access this resource."))
580 (http-reply-nocache reply)
581 (http-reply-header-add reply "Location: ~A" movedto)
582 (http-reply-content-add
583 reply
584 (do-html nil
585 (:html (:head (:title title))
586 (:body
587 (:h1 title)
588 (:p
589 "The document was permanently moved to "
590 (:a :href movedto
591 movedto) ".")
592 (:small (html-escape *server-version*))))))
593 (http-reply-flush reply stream)))
594
595(defun http-index-time (&optional (ut (server-time)))
596 (let ((months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
597 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
598 (multiple-value-bind
599 (second minute hour date month year)
600 (decode-universal-time ut 0)
601 (format nil "~2,'0D-~A-~4,'0D~C~2,'0D:~2,'0D:~2,'0D"
602 date (svref months (1- month)) year #\U00A0
603 hour minute second))))
604
605(defun http-index-size (bytes)
606 (format nil "~,3F&nbsp;KB" (float (/ bytes 1024))))
607
608(defun http-send-index (stream path)
609 (let ((title (html-escape (format nil "Index of ~A" (path-virtual path))))
610 (dirs
611 (sort (remove-if-not
612 #'path-valid
613 (mapcar #'(lambda (d)
614 (concatenate 'string
615 (car (last (pathname-directory d)))
616 "/"))
617 (directory
618 (concatenate 'string
619 (path-real path) "/*/"))))
620 #'string-lessp))
621 (files
622 (sort (remove-if-not
623 #'path-valid
624 (mapcar #'file-namestring
625 (directory
626 (concatenate 'string
627 (path-real path) "/*.*"))))
628 #'string-lessp)))
629 (http-reply-send
630 stream
631 (do-html nil
632 (:html (:head (:title title))
633 (:body :style "background: #d0d0d0;"
634 (:h1 title)
635 (:/hr)
636 (:ul (:li (:a :href "../"
637 (:code "../") " (Parent directory)")))
638 (do-html-unless (or dirs files)
639 (:/hr)
640 (:h2 "Directory empty."))
641 (do-html-when dirs
642 (:/hr)
643 (:h2 "Directories")
644 (:ul
645 (do-html-loop (for i in dirs
646 for l = (html-escape i))
647 (:li (:a :href l (:code l))))))
648 (do-html-when files
649 (:/hr)
650 (:h2 "Files")
651 (:table :cellpadding "3"
652 (:tr (:th :width "70%" :align "left" (:b "Name"))
653 (:th :width "10%" :align "right" (:b "Size"))
654 (:th :width "20%" :align "center"
655 (:b "Modified&nbsp;(UTC)")))
656 (do-html-loop (for i in files
657 for c from 0
658 for color = (if (evenp c)
659 "#b0b0b0"
660 "#c0c0c0")
661 for l = (html-escape i)
662 for rpath = (concatenate 'string
663 (path-real path)
664 "/" i)
665 for lastmod = (html-escape
666 (http-index-time
667 (file-write-date rpath)))
668 for size = (with-open-file
669 (s rpath :direction :input)
670 (file-length s)))
671 (:tr :style (format nil "background: ~A;" color)
672 (:td (:a :href l (:code l)))
673 (:td :align "right" (:code (http-index-size size)))
674 (:td :align "center" (:code lastmod))))))
675 (:/hr)
676 (:small (html-escape *server-version*))))))))
677
678
679;;; HTTP request parsing
680
681;;; Decodes the URL supplied in STRING to another string, returning it.
682(defun url-decode (string)
683 (macrolet ((get-octet ()
684 `(if (= input-max input-pos)
685 (loop-finish)
686 (prog1
687 (aref input input-pos)
688 (the fixnum (incf (the fixnum input-pos))))))
689 (put-octet (o)
690 `(vector-push ,o output)))
691 (loop
692 with input = (utf-8-string-encode string)
693 with input-pos of-type fixnum = 0
694 with input-max of-type fixnum = (length input)
695 with output = (make-array (length input)
696 :element-type '(unsigned-byte 8)
697 :fill-pointer 0)
698 for o of-type (unsigned-byte 8) = (get-octet)
699 when (= 37 o) do (let ((c1 (code-char (get-octet)))
700 (c2 (code-char (get-octet))))
701 (when (and (digit-char-p c1 16)
702 (digit-char-p c2 16))
703 (put-octet (parse-integer
704 (map 'string #'identity `(,c1 ,c2))
705 :radix 16))))
706 else when (= 43 o) do (put-octet 32)
707 else do (put-octet o)
708 finally (return (utf-8-string-decode output)))))
709
710(defvar *url-safe-char-table*
711 (make-valid-character-table
712 (character-intervals '(#\A #\Z)
713 '(#\a #\z)
714 '(#\0 #\9))))
715
716;;; Encodes the supplied URL in STRING to another string, returning it.
717(defun url-encode (string)
718 (flet ((url-encode-char (c)
719 (if (character-valid-p *url-safe-char-table* c)
720 c
721 (reduce #'(lambda (a b)
722 (concatenate 'string a b))
723 (map 'list #'(lambda (o)
724 (format nil "%~2,'0X" o))
725 (utf-8-string-encode (string c)))))))
726 (with-output-to-string (out)
727 (with-input-from-string (in string)
728 (loop
729 for c = (handler-case
730 (read-char in)
731 (end-of-file ()
732 nil))
733 for toc = (if c (url-encode-char c) nil)
734 while toc
735 when (characterp toc) do (write-char toc out)
736 else do (write-string toc out))))))
737
738;;; Supplied with a hash table and a string set statement in the form
739;;; "variable=value" or "variable[]=value", add the association binding.
740;;; If the variable name terminates with "[]", it denotes that the variable
741;;; is an array, in which case multiple values may be accumulated into it.
742(defun property-set (ht str)
743 (let ((parts (string-split str :separators '(#\=) :max 2)))
744 (when (= (length parts) 2)
745 (let ((var (string-downcase (svref parts 0)))
746 (val (if (= 1 (length parts)) "" (svref parts 1)))
747 (array-p nil))
748 ;; Escape and sanity-check VAR
749 (setf var (url-decode var))
750 (when (and (> (length var) 0)
751 (every #'(lambda (c)
752 (or (alphanumericp c)
753 (member c '(#\- #\[ #\]) :test #'char=)))
754 var))
755 ;; Unescape VAL
756 (setf val (url-decode val))
757 ;; An array?
758 (let ((len (length var)))
759 (declare (type fixnum len))
760 (when (and (> len 2)
761 (char= #\] (schar var (- len 1)))
762 (char= #\[ (schar var (- len 2))))
763 (setf array-p t)))
764 (multiple-value-bind (o exists-p)
765 (gethash var ht)
766 (cond (array-p
767 ;; Array
768 (when (not exists-p)
769 (setf o (make-array 16
770 :element-type 'string
771 :adjustable t
772 :fill-pointer 0)
773 (gethash var ht) o))
774 (vector-push-extend val o 16))
775 (t
776 ;; Normal associative variable
777 (setf (gethash var ht) val)))))))))
778
779(defun http-get-parse (ht str)
780 (loop
781 with parts = (string-split str
782 :separators '(#\&)
783 :trim-parts '(#\Newline #\Return))
784 for p across parts
785 do
786 (property-set ht p)))
787
788;;; Reads the HTTP client request from STREAM, and returns two values,
789;;; a status keyword symbol and a list consisting of the collected lines.
790;;; :NO-REQUEST no request was sent (empty request)
791;;; :REQUEST-SIZE-EXCEEDED request exceeded allowed request size
792;;; :REQUEST-TIMEOUT allowed time for request to complete exceeded
793;;; :SUCCESS success
794(defun http-request-read (stream)
795 (loop
796 with config = *config*
797 with max-time of-type integer = (+ (server-time)
798 (config-request-timeout config))
799 with request-max-size of-type fixnum = (config-request-max-size config)
800 with timeout-signal = nil
801 for line = (handler-case
802 (line-read stream)
803 (sb-bsd-sockets:operation-timeout-error ()
804 (setf timeout-signal t)
805 "<TIMEOUT>"))
806 for words = (if (= nlines 0)
807 (string-split line :max 3)
808 #())
809 until timeout-signal ; Timeout signal
810 while (< chars request-max-size) ; Request size exceeded
811 while (< (server-time) max-time) ; Request timeout
812 until (string= "" line) ; End of HTTP/1.x request
813 until (and (= nlines 0) ; End of HTTP/0.x request
814 (< (length words) 3))
815 sum (length line) into chars of-type fixnum
816 count line into nlines of-type fixnum
817 collect line into lines
818 finally
819 (return
820 (values (cond
821 ((and (= nlines 0)
822 (= (length words) 0))
823 :no-request)
824 ((> chars request-max-size)
825 :request-size-exceeded)
826 ((or (>= (server-time) max-time)
827 timeout-signal)
828 :request-timeout)
829 ((and (= nlines 0)
830 (< (length words) 3))
831 (push line lines)
832 :success)
833 (t
834 :success))
835 lines))))
836
837;;; Request parsing preprocessor.
838;;; Extracts query from the first request line and coalesces continuating
839;;; header lines. Returns the request line as first value and the list
840;;; of preprocessed lines as second value.
841(defun http-request-parse-1 (lines)
842 (values (pop lines)
843 (loop
844 with list = '()
845 with last = nil
846 for line in lines
847 do
848 (cond ((and (let ((c (schar line 0)))
849 (or (char= #\Space c) (char= #\Tab c)))
850 last)
851 (setf (car last)
852 (concatenate 'string (car last) " "
853 (string-trim '(#\Space #\Tab)
854 line))))
855 (t
856 (let ((words
857 (string-split line
858 :separators '(#\:)
859 :trim-parts '(#\Space #\Tab)
860 :max 2)))
861 (when (= 2 (length words))
862 (push line list)
863 (setf last list)))))
864 finally (return list))))
865
866
867(defstruct http-request
868 (raw nil)
869 (protocol 0.9 :type (or null float))
870 (method nil)
871 (host nil)
872 (vhost *vhost-default*)
873 (path nil)
874 (query nil)
875 (post nil)
876 (vars-get (make-hash-table :test 'equal))
877 (vars-post (make-hash-table :test 'equal))
878 (vars-cookie (make-hash-table :test 'equal))
879 (agent nil)
880 (referer nil)
881 (keep-alive nil :type boolean)
882 (content-type "application/x-www-form-urlencoded")
883 (content-length -1 :type integer)
884 (modified-since nil)
885 (unmodified-since nil)
886 (range nil))
887
888(defun http-request-disable-keepalive (request)
889 (setf (http-request-keep-alive request) nil))
890
891;;; List of headers we care about and functions to fill them.
892;;; We later on fill a hash table using this list for fast lookups.
893;;; CLOS could have been used instead after interning a keyword symbol
894;;; from the header variable string, but that would probably be slower.
895;;; The performance of a large COND, or of running this list, would vary
896;;; depending on the order of received headers and number of headers we care
897;;; about.
898(defparameter *header-list*
899 `(("host"
900 ,#'(lambda (o v)
901 (let* ((pos (position #\: v :from-end t))
902 (h (if pos (subseq v 0 pos) v)))
903 (setf (http-request-host o) v
904 (http-request-vhost o) (vhost-query h :default t)))))
905 ("user-agent"
906 ,#'(lambda (o v)
907 (setf (http-request-agent o) v)))
908 ("referer"
909 ,#'(lambda (o v)
910 (setf (http-request-referer o) v)))
911 ("connection"
912 ,#'(lambda (o v)
913 (cond ((string-equal "keep-alive" v)
914 (setf (http-request-keep-alive o) t))
915 ((string-equal "close" v)
916 (setf (http-request-keep-alive o) nil)))))
917 ("content-type"
918 ,#'(lambda (o v)
919 (setf (http-request-content-type o) v)))
920 ("content-length"
921 ,#'(lambda (o v)
922 (let ((i (handler-case
923 (parse-integer v)
924 (t ()
925 -1))))
926 (setf (http-request-content-length o) i))))
927 ("if-modified-since"
928 ,#'(lambda (o v)
929 (setf (http-request-modified-since o)
930 (server-time-rfc-parse v))))
931 ("if-unmodified-since"
932 ,#'(lambda (o v)
933 (setf (http-request-unmodified-since o)
934 (server-time-rfc-parse v))))
935 ("range"
936 ,#'(lambda (o v)
937 (setf (http-request-range o) v)))
938 ("cookie"
939 ,#'(lambda (o v)
940 (property-set (http-request-vars-cookie o) v)))))
941
942(defparameter *header-table*
943 (let ((ht (make-hash-table :test 'equal)))
944 (mapc #'(lambda (l)
945 (destructuring-bind (field function) l
946 (setf (gethash field ht) function)))
947 *header-list*)
948 ht))
949
950;;; Reads and parses POST data request if any
951;;; XXX Should at least also support "multipart/form-data" enctype
952(defun http-post-parse (stream)
953 (let* ((req *request*)
954 (req-length (http-request-content-length req))
955 (req-vhost (http-request-vhost req))
956 (req-type (let* ((type (http-request-content-type req))
957 (pos (position #\; type)))
958 (if pos
959 (subseq type 0 pos)
960 type))))
961 (unless (eq (http-request-method req) :post)
962 (return-from http-post-parse))
963 (unless (string= req-type "application/x-www-form-urlencoded")
964 (http-error stream 415 "Unsupported Media Type"
965 "The POST enctype \"~A\" is unsupported." req-type))
966 (when (= -1 req-length)
967 (http-error stream 411 "Length Required"))
968 (unless (< 0 req-length (vhost-post-max-size req-vhost))
969 (http-error stream 413 "Request Entity Too Large"))
970 (let ((pd
971 (handler-case
972 (loop
973 with max-time of-type integer = (+ (server-time)
974 (vhost-post-timeout
975 req-vhost))
976 with timeout-signal = nil
977 with vector = (make-array req-length
978 :element-type 'character
979 :initial-element #\Nul)
980 sum (handler-case
981 (read-sequence vector stream
982 :start read-length)
983 (simple-error ()
984 (setf timeout-signal t)
985 0)) into read-length
986 until timeout-signal
987 while (< (server-time) max-time)
988 while (< read-length req-length)
989 finally
990 (progn
991 (when (or (>= (server-time) max-time)
992 timeout-signal)
993 (http-error stream 408 "Request Timeout"))
994 (return vector)))
995 (ext:stream-decoding-error ()
996 (http-error stream 500 "Internal Server Error"
997 "Character decoding error.")))))
998 (if pd
999 (progn
1000 (http-get-parse (http-request-vars-post req) pd)
1001 pd)
1002 nil))))
1003
1004;;; To avoid constant INTERNing, simply match method strings to keywords.
1005;;; Matching symbols using EQ afterwards is simple and as efficient as matching
1006;;; numbers.
1007(defun method-keyword (method)
1008 (let* ((methods #("GET" "POST" "HEAD" "PUT"
1009 "DELETE" "TRACE" "CONNECT" "OPTIONS"))
1010 (keywords #(:get :post :head :put
1011 :delete :trace :connect :options))
1012 (pos (position method methods :test #'string=)))
1013 (if pos
1014 (svref keywords pos)
1015 :unknown)))
1016
1017;;; Used to parse the HTTP version
1018(defun parse-float (string)
1019 (when (char= #\. (char string 0))
1020 (setf string (concatenate 'string "0" string)))
1021 (let ((w (string-split string :separators '(#\.) :max 2)))
1022 (if (= 2 (length w))
1023 (let ((i1 (handler-case
1024 (parse-integer (aref w 0))
1025 (t ()
1026 nil)))
1027 (i2 (handler-case
1028 (parse-integer (aref w 1))
1029 (t ()
1030 nil))))
1031 (if (and i1 i2)
1032 (float (+ i1 (/ i2 (expt 10 (length (aref w 1))))))
1033 nil))
1034 nil)))
1035
1036;;; Parse supplied HTTP version STRING, returning NIL on error or
1037;;; a floating point representing the number.
1038(defun version-parse (string)
1039 (let ((w (string-split string :separators '(#\/) :max 2)))
1040 (if (and (= 2 (length w))
1041 (string-equal "HTTP" (aref w 0)))
1042 (parse-float (aref w 1))
1043 nil)))
1044
1045;;; Actual request parsing function.
1046(defun http-request-parse (lines stream)
1047 ;; Preprocessing
1048 (multiple-value-bind (request headers)
1049 (http-request-parse-1 lines)
1050 (let ((req (make-http-request))
1051 (valid nil))
1052 (setf (http-request-raw req) lines)
1053
1054 ;; Request method/path/protocol
1055 (let* ((words (string-split request :max 4))
1056 (nwords (length words)))
1057 (cond ((< nwords 3)
1058 (setf (http-request-method req) (method-keyword
1059 (svref words 0))
1060 (http-request-path req) (if (= 2 (length words))
1061 (svref words 1)
1062 "/")
1063 valid t))
1064 ((= 3 nwords)
1065 (setf (http-request-protocol req) (version-parse
1066 (svref words 2))
1067 (http-request-method req) (method-keyword
1068 (svref words 0))
1069 (http-request-path req) (svref words 1)
1070 valid t))))
1071
1072 ;; Keep-Alive on by default for >= HTTP/1.1, headers might change it
1073 (let ((protocol (http-request-protocol req)))
1074 (when (and protocol (>= protocol 1.1))
1075 (setf (http-request-keep-alive req) t)))
1076
1077 ;; Headers
1078 (when valid
1079 (loop
1080 with header-table = *header-table*
1081 for line in headers
1082 for var = (string-trim
1083 '(#\Space)
1084 (string-downcase
1085 (subseq line 0 (position #\: line))))
1086 for val = (string-trim
1087 '(#\Space)
1088 (subseq line (1+ (position #\: line :start
1089 (length var)))))
1090 for fun = (gethash var header-table)
1091 when fun do (funcall fun req val)))
1092
1093 ;; Separate path from query variables; fill in GET variables if any.
1094 (let* ((path (http-request-path req))
1095 (pos (position #\? path :test #'char=))
1096 (epos (position #\; path :test #'char= :from-end t)))
1097 (when pos
1098 (let ((get (subseq path (1+ pos) (if epos epos (length path)))))
1099 (setf (http-request-path req) (subseq path 0 pos)
1100 (http-request-query req) get)
1101 (http-get-parse (http-request-vars-get req) get))))
1102
1103 ;; Read and parse POST data if any
1104 (let ((*request* req))
1105 (setf (http-request-post req) (http-post-parse stream)))
1106
1107 ;; Finally return request object for eventual dispatching
1108 req)))
1109
1110
1111;;; Currently used by the test code.
1112(defun req-var (req type &optional name default)
1113 "Queries the request environment REQ for a variable of TYPE :GET, :POST
1114or :COOKIE, named NAME \(may be a symbol or a string\). DEFAULT is
1115returned if no such binding exists \(which defaults to NIL\). If NAME is
1116omited, a list is returned of all variable bindings of the specified TYPE."
1117 (let ((ht (cond ((eq :get type)
1118 (http-request-vars-get req))
1119 ((eq :post type)
1120 (http-request-vars-post req))
1121 ((eq :cookie type)
1122 (http-request-vars-cookie req))
1123 (t (error "TYPE not one of :GET :POST :COOKIE")))))
1124 (cond ((null name)
1125 (loop
1126 for key being each hash-key of ht using (hash-value val)
1127 collect `(,key ,val)))
1128 (t
1129 (multiple-value-bind (val exists-p)
1130 (gethash (string-downcase (string name)) ht)
1131 (if exists-p
1132 val
1133 default))))))
1134
1135(defmacro with-http-let (req bindings &body body)
1136 "Helper macro for REQ-VAR. Permits to perform multiple local bindings
1137with variables bound in the request environment REQ. BINDINGS consists of
1138a list of LET-like bindings with the following elements:
1139\(VAR TYPE &optional NAME DEFAULT\) where VAR is the variable to lexically
1140bind, TYPE is one of :GET, :POST or :COOKIE, NAME is the name of the
1141variable in the environment \(represented by a symbol or string\), and
1142DEFAULT is the default value to bind to VAR if NAME is not bound \(defaults
1143to NIL\). If NAME is omited, a list of all bound variables of TYPE in
1144REQ is bound to VAR."
1145 (let ((s-req (gensym)))
1146 `(let ((,s-req ,req))
1147 (let (,@(loop
1148 for binding in bindings
1149 for (var type name default) = binding
1150 collect `(,var (req-var ,s-req ,type ,name ,default))))
1151 ,@body))))
1152
1153
1154;;; Debugging
1155
1156(defvar *debug* '(:log :log-errors :test))
1157
1158(defun debug-feature (keyword)
1159 (let ((debug *debug*))
1160 (and debug (position keyword debug :test #'eq))))
1161
1162(defun beep ()
1163 (handler-case
1164 (with-open-file (s "/dev/speaker" :direction :output)
1165 (write-string "O1L15D" s))
1166 (t ()
1167 nil)))
1168
1169(defun dump-vars (ht)
1170 (with-output-to-string (out)
1171 (maphash #'(lambda (k v)
1172 (format out "~A = ~S~%" k v))
1173 ht)))
1174
1175
1176(defun html-test-page (req connection)
1177 (http-reply-send
1178 (connection-stream connection)
1179 (do-html nil
1180 (:html (:head (:title "Interactively developed test server"))
1181 (:body
1182 (:h1 "Interactively developed test server")
1183 (:p "This page, forms and server code may change anytime "
1184 "without interruption; a live SWANK connection is "
1185 "maintained from Emacs and SLIME, and the system is "
1186 "developed interactively on spare time.")
1187 (:p
1188 "Follow " (:a :href "/" "this link") " to proceed to a "
1189 "mirror of my site hosted on this test server.")
1190 (:p
1191 "The source code of this server is also available "
1192 (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
1193 :target "_blank"
1194 "here") ".")
1195 (:p
1196 "The first test application can be found "
1197 (:a :href "/chat" "here") ", and a second one to help "
1198 "accumulate name suggestions for this server "
1199 (:a :href "/names" "here") ".")
1200
1201 (:h2 "WITH-HTTP-LET Test")
1202 (:p (with-http-let req
1203 ((id :get :id -1)
1204 (first-name :post :last-name "first-name")
1205 (last-name :post :first-name "last-name")
1206 (foo :get :foo)
1207 (get :get))
1208 (html-escape
1209 (format nil "id=~S, name=\"~A ~A\", foo=~S, get=~S."
1210 id first-name last-name foo get))))
1211
1212 (:h2 "Location")
1213 (:p "IP address/port: "
1214 (connection-address-string connection) ":"
1215 (connection-port connection))
1216 (:h2 "Test form")
1217 (:form :action (html-escape
1218 (format nil
1219 "/test?id=~64,'0X" (random
1220 #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)))
1221 :method "post"
1222 "First name: "
1223 (:/input :name "first-name"
1224 :type "text"
1225 :size "32"
1226 :maxlength "64"
1227 :value (html-escape
1228 (req-var req :post :first-name
1229 "First name")))
1230 (:/br)
1231 "Last name: "
1232 (:/input :name "last-name"
1233 :type "text"
1234 :size "32"
1235 :maxlength "64"
1236 :value (html-escape
1237 (req-var req :post :last-name
1238 "Last name")))
1239 (:/br)
1240 (do-html-loop (for i from 1 to 10
1241 for s = (format nil "~2,'0D" i)
1242 for v = (format nil "box-~2,'0D" i))
1243 "Box " s
1244 (let* ((a (req-var req :post :box[] nil))
1245 (c (if a (find v a :test #'string=) nil)))
1246 (do-html-if c
1247 (:/input :name "box[]"
1248 :type "checkbox"
1249 :value v
1250 :/checked)
1251 (:/input :name "box[]"
1252 :type "checkbox"
1253 :value v))))
1254 (:/br)
1255 (:textarea :name "message"
1256 :rows 10
1257 :cols 60
1258 (html-escape
1259 (req-var req :post :message
1260 "Message text.")))
1261 (:/br)
1262 (:/input :type "submit" :value "Post"))
1263 (:h2 "Test form 2 (multipart)")
1264 (:form :action "/test"
1265 :method "post"
1266 :enctype "multipart/form-data"
1267 (:/input :name "description"
1268 :type "text"
1269 :size "32"
1270 :maxlength "64"
1271 :value (html-escape
1272 (req-var req :post :description
1273 "Description")))
1274 (:/br)
1275 (:/input :name "file"
1276 :type "file"
1277 :size "32"
1278 :maxlength "64"
1279 :value "File to send")
1280 (:/br)
1281 (:/input :type "submit"
1282 :value "Send"))
1283 (:h2 "Browser request")
1284 (:pre
1285 (do-html-loop (for line in (http-request-raw req))
1286 (html-escape (format nil "~A~%" line))))
1287 (:p (:code
1288 (html-escape (format nil "~S~%" req))))
1289 (:h2 "Path")
1290 (html-escape (format nil "~A~%"
1291 (http-request-path req)))
1292 (do-html-when (http-request-query req)
1293 (:h2 "GET data")
1294 (:pre
1295 (html-escape (format nil "~A~%"
1296 (http-request-query req))))
1297 (:pre
1298 (html-escape (dump-vars (http-request-vars-get req)))))
1299 (do-html-when (http-request-post req)
1300 (:h2 "POST data")
1301 (:pre
1302 (html-escape (format nil "~A~%"
1303 (http-request-post req))))
1304 (:pre
1305 (html-escape (dump-vars
1306 (http-request-vars-post req)))))
1307 (do-html-when (> (hash-table-count
1308 (http-request-vars-cookie req)) 0)
1309 (:h2 "COOKIE data")
1310 (:pre
1311 (html-escape (dump-vars
1312 (http-request-vars-cookie req)))))
1313 (:h2 "Server information")
1314 (:p *server-version* " "
1315 (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
1316 :target "_blank"
1317 "(Source available here)."))
1318 (:p (do-html-loop
1319 (with packages = (list-all-packages)
1320 for p in packages
1321 for s = (find-symbol "*RCSID*" p)
1322 for v = (if (and s (boundp s))
1323 (html-escape (symbol-value s)) nil)
1324 when v)
1325 (:code v) (:/br)))
1326 (:p "HTTP server uptime: " (server-uptime))
1327 (:code (html-escape (lisp-implementation-type)) " "
1328 (html-escape (lisp-implementation-version)) " ("
1329 (html-escape (first (mp::uname))) ")")
1330 (:p (:a :href "http://validator.w3.org/check?uri=referer"
1331 (:/img :src "/images/valid-xhtml.png"
1332 :alt "Valid XHTML 1.0 Transitional"
1333 :height "31"
1334 :width "88"))))))))
1335
1336(defun http-dynamic-dispatch (req connection path)
1337 (let ((method (http-request-method req))
1338 (stream (connection-stream connection)))
1339 (cond
1340 ;; HEAD not allowed for HTTP/0.9
1341 ((and (< (http-request-protocol req) 1.0) (eq :head method))
1342 (http-error stream 400 "Bad Request"
1343 "HTTP versions <= 0.9 have no HEAD method."))
1344 ;; Allow these for dynamic handlers
1345 ((member method '(:get :head :post) :test #'eq))
1346 ;; But forbid these
1347 ((member method '(:options :delete :trace) :test #'eq)
1348 (http-error stream 405 "Method Not Allowed"
1349 "Method not allowed for dynamic handlers."))
1350 ((eq :connect method)
1351 (http-error stream 405 "NO CARRIER")) ; Easter egg
1352 ;; Any other is unimplemented for dynamic content
1353 (t
1354 (http-error-unimplemented stream)))
1355 (unless path
1356 (http-error stream 403 "Forbidden"
1357 "You do not have the permission to access that resource.")))
1358
1359 (let ((vpath (path-virtual path)))
1360 (when (debug-feature :test)
1361 (when (string= "/test" vpath)
1362 (html-test-page req connection)))
1363 (let ((fun (vhost-handler-query (http-request-vhost req) vpath)))
1364 (when fun
1365 (funcall fun req connection)
1366 (return-from http-dynamic-dispatch t))))
1367 nil)
1368
1369(defun http-static-dispatch (req connection path)
1370 (let ((vhost (http-request-vhost req))
1371 (stream (connection-stream connection))
1372 truepath)
1373
1374 ;; Allowed method?
1375 (let ((method (http-request-method req)))
1376 (cond
1377 ;; HEAD not allowed for HTTP/0.9
1378 ((and (< (http-request-protocol req) 1.0) (eq :head method))
1379 (http-error stream 400 "Bad Request"
1380 "HTTP versions <= 0.9 have no HEAD method."))
1381 ;; Allow these for static content
1382 ((member method '(:get :head) :test #'eq))
1383 ;; But forbid these
1384 ((member method '(:options :delete :trace :post)
1385 :test #'eq)
1386 (http-error stream 405 "Method Not Allowed"
1387 "Method not allowed for static resources."))
1388 ((eq :connect method)
1389 (http-error stream 405 "NO CARRIER")) ; Easter egg
1390 ;; Any other is unimplemented for static content
1391 (t
1392 (http-error-unimplemented stream))))
1393 (unless path
1394 (http-error stream 403 "Forbidden"
1395 "You do not have the permission to access that resource."))
1396
1397 ;; File/directory exists?
1398 (unless (setf truepath (probe-file (path-real path)))
1399 (http-error stream 404 "Not Found"
1400 "\"~A\" could not be found."
1401 (path-virtual path)))
1402
1403 ;; If a directory, send index file if exists, but 403 otherwise.
1404 (let ((s-truepath (directory-namestring truepath)))
1405 (when (and (= 0 (length (file-namestring truepath)))
1406 (eql (position #\/ s-truepath :test #'char= :from-end t)
1407 (1- (length s-truepath))))
1408 ;; Points to a directory, make sure that "/" is part of the path
1409 ;; not to confuse browsers
1410 (let ((vpath (path-virtual path)))
1411 (unless (char= #\/ (schar vpath (1- (length vpath))))
1412 (http-redirect stream req (concatenate 'string
1413 vpath "/"))))
1414 ;; Check if we can find the index
1415 (let ((tp
1416 (probe-file
1417 (path-valid (concatenate 'string
1418 "/" (path-real path) "/"
1419 (vhost-index vhost))))))
1420 (setf truepath nil)
1421 (if tp
1422 (setf truepath tp)
1423 (if (vhost-autoindex vhost)
1424 (http-send-index stream path)
1425 (http-error stream 403 "Forbidden"
1426 "You do not have the permission to access \"~A\"."
1427 (path-virtual path)))))))
1428
1429 ;; Prepare to send file
1430 (when truepath
1431 (let* ((mime-type (mime-query
1432 (path-extension (file-namestring truepath))))
1433 (reply (make-http-reply :mime-type mime-type
1434 :charset (vhost-charset vhost)))
1435 (lastmodsecs (file-write-date truepath))
1436 (lastmod (server-time-rfc lastmodsecs)))
1437
1438 ;; If-modified/If-unmodified
1439 (let ((modified-since (http-request-modified-since req)))
1440 (when (and modified-since
1441 (<= lastmodsecs modified-since))
1442 (setf (http-reply-code reply) 304
1443 (http-reply-description reply) "Not Modified")
1444 (http-reply-flush reply stream 0)))
1445 (let ((unmodified-since (http-request-unmodified-since req)))
1446 (when (and unmodified-since
1447 (> lastmodsecs unmodified-since))
1448 (setf (http-reply-code reply) 412
1449 (http-reply-description reply) "Precondition Failed")
1450 (http-reply-flush reply stream 0)))
1451
1452 ;; Range
1453 ;; XXX 416 Requested Range Not Satisfiable
1454
1455 ;; Finally send file (except for HEAD)
1456 (http-reply-header-add reply "Last-Modified: ~A" lastmod)
1457 (with-open-file (in truepath
1458 :direction :input
1459 :element-type '(unsigned-byte 8))
1460 (http-reply-flush reply stream (file-length in))
1461 (unless (eq :head (http-request-method req))
1462 (loop
1463 with seq = *buffer*
1464 with seqsize of-type fixnum = (array-dimension seq 0)
1465 for len of-type fixnum = (read-sequence seq in)
1466 do (write-sequence seq stream :end len)
1467 while (= seqsize len))
1468 (finish-output stream)))))))
1469
1470;;; Actual entry point from SERVER
1471(defun http-serve (connection)
1472 (loop
1473 with config = *config*
1474 with max-size = (config-request-max-size config)
1475 with keep-alive of-type boolean = nil
1476 with keep-alive-max of-type fixnum = (config-request-keepalive-max
1477 config)
1478 for keep-alive-count of-type fixnum from 0 below keep-alive-max
1479 do
1480 (when (debug-feature :beep)
1481 (beep))
1482 (handler-case
1483 (let* ((stream (connection-stream connection))
1484 (session (connection-session connection)))
1485
1486 (when (= 1 keep-alive-count)
1487 (setf (connection-input-timeout connection)
1488 (config-request-keepalive-timeout config)))
1489 (multiple-value-bind (status lines)
1490 (http-request-read stream)
1491
1492 (when (eq :no-request status)
1493 (unless keep-alive
1494 (when (debug-feature :log-errors)
1495 (log-line "~X No request" session)))
1496 (return-from http-serve nil))
1497
1498 (let* ((req (http-request-parse lines stream))
1499 (*request* req)
1500 (vhost (http-request-vhost req))
1501 (path (vhost-path vhost (http-request-path req))))
1502
1503 (unless keep-alive
1504 (setf keep-alive (http-request-keep-alive req)))
1505
1506 (when (debug-feature :log-requests)
1507 (let ((*print-pretty* nil))
1508 (log-line "~X ~S" session req)))
1509
1510 (cond ((eq :success status))
1511 ((eq :request-size-exceeded status)
1512 (when (debug-feature :log-errors)
1513 (log-line "~X Query length exceeds ~A bytes"
1514 session max-size))
1515 (http-error stream 413 "Request Entity Too Large"
1516 "Query length exceeds ~A bytes."
1517 max-size))
1518 ((eq :request-timeout status)
1519 (unless keep-alive
1520 (when (debug-feature :log-errors)
1521 (log-line "~X Request Timeout" session))
1522 (http-error stream 408 "Request Timeout"))
1523 (return-from http-serve nil)))
1524
1525 ;; We could alternatively accept HTTP > 1.1 and behave
1526 ;; like for HTTP 1.1.
1527 ;; XXX Also see RFC 2616 section 3.1 and RFC 2145
1528 ;; about replying with a version Entity.
1529 (let ((protocol (http-request-protocol req)))
1530 (when (or (null protocol)
1531 (>= protocol 2.0))
1532 (when (debug-feature :log-errors)
1533 (log-line "~X Unsupported protocol version ~A"
1534 session protocol))
1535 (http-error stream 505 "Version Not Supported"
1536 "This server supports HTTP versions <= 2.0.")))
1537 (when (and (>= (http-request-protocol req) 1.1)
1538 (null (http-request-host req)))
1539 (http-error stream 400 "Bad Request"
1540 "HTTP versions >= 1.1 require a Host header."))
1541
1542 ;; Prioritize any existing dynamic handler over static
1543 (unless (http-dynamic-dispatch req connection path)
1544 (http-static-dispatch req connection path)))))
1545
1546 (http-reply-signal-no-keepalive ()
1547 (loop-finish))
1548 (http-reply-signal ()
1549 t)
1550 (end-of-file ()
1551 (unless keep-alive
1552 (when (debug-feature :log-errors)
1553 (log-line "~X End of file" (connection-session connection))))
1554 (loop-finish)))
1555 while keep-alive)
1556 nil)
1557
1558;;; Second entry point from SERVER to handle errors
1559(defun http-overflow (connection reason)
1560 (declare (ignore reason))
1561 (handler-case
1562 (let ((stream (connection-stream connection)))
1563 (http-error stream 403.9 "Too many connections"
1564 "Connection limit exceeded for your address. Try again later."))
1565 (http-reply-signal ()
1566 t))
1567 nil)
1568
1569
1570;;; Initialization and startup
1571
1572(defvar *initialized* nil)
1573
1574;; Set a minimal default vhost
1575(vhost-register (make-vhost :hostname "localhost"
1576 :root "/tmp/htdocs/"
1577 :autoindex nil))
1578
1579#-:mm-ecl-standalone
1580(eval-when (:load-toplevel :execute)
1581 ;; Not standalone, attempt to load config file in current path
1582 (load "httpd-config.lisp"))
1583
1584(defun httpd-init ()
1585 (check-type *config* httpd-config)
1586 (let ((server-config (config-server-config *config*)))
1587 (check-type server-config server-config)
1588 (setf *debug* (config-debug config)
1589 (server::config-serve-function server-config) #'http-serve
1590 (server::config-overflow-function server-config) #'http-overflow
1591 (server::config-buffer server-config) 65536
1592 (server::config-log-connections server-config) (debug-feature
1593 :log-connections))
1594 (server-init server-config)
1595 (setf *config* config
1596 *initialized* t))
1597 t)
1598
1599#-:mm-ecl-standalone
1600(httpd-init)
1601
1602(defun httpd-cleanup ()
1603 (if *initialized*
1604 (progn
1605 (server-cleanup)
1606 (setf *initialized* nil)
1607 t)
1608 nil))
1609
1610;;; XXX
1611#+:mm-ecl-standalone
1612(defun swank-loop () ; XXX
1613 (loop
1614 (sleep 1)))
1615#+:mm-ecl-standalone
1616(defparameter config-file nil)
1617#+:mm-ecl-standalone
1618(defun standalone-main ()
1619 (let ((ext:*lisp-init-file-list* nil))
1620 (defun help (stream)
1621 (format stream "~%~A [-config <file>]~%" (first ext:*command-args*))
1622 (ext:quit 1))
1623
1624 (handler-case
1625 (ext:process-command-args
1626 :rules '(("-config" 1 (setf config-file 1) :noloadrc)
1627 ("*DEFAULT*" 0 (help *standard-output*))))
1628 (error ()
1629 (help *error-output*)))
1630
1631 (unless config-file
1632 (help *error-output*))
1633
1634 (handler-case
1635 (load config-file)
1636 (error ()
1637 (format *error-output* "~%Error loading configuration file~%")
1638 (ext:quit -1)))
1639 (httpd-init)
1640 (swank-loop)))
1641#+:mm-ecl-standalone
1642(standalone-main)
1643