0c2086b6013c54d593c801984d2d6b2becda73e3
[mmondor.git] / mmsoftware / cl / server / test-httpd.lisp
1 ;;;; $Id: test-httpd.lisp,v 1.22 2011/09/02 13:53:05 mmondor Exp $
2
3 #|
4
5 Copyright (c) 2011, Matthew Mondor
6 All rights reserved.
7
8 Redistribution and use in source and binary forms, with or without
9 modification, are permitted provided that the following conditions
10 are met:
11 1. Redistributions of source code must retain the above copyright
12 notice, this list of conditions and the following disclaimer.
13 2. 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
17 THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
18 IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
19 OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
20 IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
21 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
22 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
23 USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24 THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
26 THIS 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 ;;;; - Maybe cleanup all those HTTP-ERROR followed by RETURN-FROM cases
34 ;;;; where HTTP-ERROR could signal a condition instead.
35 ;;;; - Perhaps make the interface to HTTP-REPLY, HTTP-REPLY-SEND and
36 ;;;; HTTP-ERROR better so that user code doesn't always have to carry
37 ;;;; and care about STREAM, etc. *CONNECTION* already holds it...
38 ;;;; - Per-vhost POST size limit
39 ;;;; - Directory indexing code
40 ;;;; - Implement RANGE
41 ;;;; - URL to application server method dispatching, and setup to be
42 ;;;; used as a library by application servers
43 ;;;; - Keep-Alive to keep connection open a decent amount of time,
44 ;;;; also allow user code to send chucked streams
45 ;;;; - Multipart POST parsing so that files can be uploaded
46 ;;;; - Session helper code, with support for session ID cookie and
47 ;;;; anti-XSS GET session-tied IDs, URL generator to use these IDs,
48 ;;;; user session-specific variables/objects
49 ;;;; - Form generator with form-instance IDs for matching responses to
50 ;;;; queries
51 ;;;; - Test application(s) with simple in-memory objects
52
53
54 (declaim (optimize (speed 3) (safety 1) (debug 3)))
55
56 (eval-when (:compile-toplevel :load-toplevel)
57 (load "ecl-mp-server")
58 (load "html")
59 (load "character"))
60
61 (defpackage :httpd
62 (:use :cl :server :html :character))
63
64 (in-package :httpd)
65
66 (defparameter *rcsid*
67 "$Id: test-httpd.lisp,v 1.22 2011/09/02 13:53:05 mmondor Exp $")
68
69 (defparameter *server-version*
70 (let ((parts (string-split *rcsid*
71 :separators '(#\Space #\,))))
72 (concatenate 'string
73 (svref parts 1) "/" (svref parts 3))))
74
75
76 ;;; Parameters XXX To move into a structure when we become a library
77
78 ;;; Supported *DEBUG* features:
79 ;;; :log-req :log-connections :log-timeouts :test :beep
80 (defvar *debug* '(:beep :test :log-timeouts))
81 (defparameter *request-timeout* 60)
82 (defparameter *request-max-size* 4096)
83
84 (defvar *mime-types*
85 '(("text/html"
86 ("html" "htm" "dhtml"))
87 ("text/plain"
88 ("txt"))
89 ("text/css"
90 ("css"))
91 ("application/x-xpinstall"
92 ("xpi"))
93 ("application/vnd.mozilla.xul+xml"
94 ("xul"))
95 ("text/rdf"
96 ("rdf"))
97 ("application/pdf"
98 ("pdf"))
99 ("application/postscript"
100 ("ps"))
101 ("application/x-tar"
102 ("tar"))
103 ("application/x-gzip"
104 ("gz"))
105 ("application/x-bzip2"
106 ("bz2"))
107 ("application/zip"
108 ("zip"))
109 ("application/x-javascript"
110 ("js"))
111 ("application/x-c"
112 ("c" "h" "cpp" "cc"))
113 ("application/x-sh"
114 ("sh"))
115 ("application/x-shockwave-flash"
116 ("swf"))
117 ("application/xml"
118 ("xml"))
119 ("application/xml-dtd"
120 ("dtd"))
121 ("image/jpg"
122 ("jpeg" "jpg"))
123 ("image/png"
124 ("png"))
125 ("image/gif"
126 ("gif"))
127 ("image/x-icon"
128 ("ico"))
129 ("image/svg+xml"
130 ("xvg"))
131 ("video/mpeg"
132 ("mpeg" "mpg"))
133 ("video/quicktime"
134 ("mov" "mp4"))
135 ("video/x-msvideo"
136 ("asf" "asx" "wmv" "avi"))))
137
138
139 ;;; Paths
140
141 (defparameter *path-max* 255)
142 (defparameter *path-valid-char-table*
143 (make-valid-character-table (character-intervals
144 '(#\a #\z)
145 '(#\A #\Z)
146 '(#\0 #\9)
147 #\. #\/ #\- #\_)))
148
149 ;;; Returns copy of PATH or NIL. Always begins with "/", with multiple
150 ;;; "/" collapsed into one. Makes sure that PATH only contains allowed
151 ;;; characters (in *PATH-VALID-CHAR-TABLE*) and is shorter than *PATH-MAX*.
152 ;;; Does not allow '.' at the start of PATH or after any '/'.
153 (defun path-valid (path)
154 (let ((out (make-array (1+ (length path))
155 :element-type 'character
156 :fill-pointer 0)))
157 (macrolet ((add-char (c)
158 `(vector-push ,c out)))
159 (add-char #\/)
160 (if
161 (loop
162 with last of-type character = #\/
163 for c of-type character across path
164 do
165 (block continue
166 (when (char= #\/ last)
167 ;; Collapse multiple '/' and prohibit '.' at start
168 (if (char= #\/ c)
169 (return-from continue)
170 (when (char= #\. c)
171 (return nil))))
172 (unless (character-valid-p *path-valid-char-table* c)
173 (return nil))
174 (add-char c)
175 (setf last c))
176 finally (return out))
177 (if (> (length out) *path-max*)
178 nil
179 out)
180 nil))))
181
182 (defstruct path
183 real virtual)
184
185 ;;; Should always be called when processing user-supplied paths.
186 ;;; The application should then only trust the objects returned by
187 ;;; this function. Returns NIL if the path is invalid. On success,
188 ;;; returns a PATH object with:
189 ;;; REAL: System-wide absolute real fullpath, to be used to access the
190 ;;; file/directory in question
191 ;;; VIRTUAL: The virtual root based absolute fullpath, useful to report
192 ;;; to the user.
193 ;;; Note that supplied ROOT should previously have been passed through
194 ;;; PATH-VALID, and that both ROOT and PATH should be absolute paths.
195 (defun path-valid-virtual (root path)
196 (let* ((virtual (path-valid (concatenate 'string "/" path)))
197 (real (if virtual (path-valid (concatenate 'string
198 "/" root "/" virtual))
199 nil)))
200 (if (and virtual real)
201 (make-path :real real
202 :virtual virtual)
203 nil)))
204
205 (defun path-extension (path)
206 (let ((dot (position #\. path
207 :test #'char=
208 :from-end t)))
209 (if dot
210 (string-downcase (subseq path (1+ dot)))
211 nil)))
212
213
214 ;;; VHosts
215
216 (defvar *vhost-default* nil)
217
218 (defstruct vhost
219 (hostname "" :type string)
220 (root "/" :type string)
221 (index "/index.html" :type string)
222 (charset "UTF-8" :type string))
223
224 (defvar *vhosts* (make-hash-table :test #'equal))
225 (defvar *vhosts-lock* (mp:make-lock :name 'vhosts-lock))
226
227 (defun vhost-register (&key
228 (name "")
229 (aliases '())
230 (root "/")
231 (index "/index.html")
232 (charset "UTF-8")
233 (default nil))
234 (let ((vhost (make-vhost :hostname name
235 :root (or (path-valid root)
236 (error "Invalid root path \"~A\""
237 root))
238 :index (or (path-valid index)
239 (error "Invalid index path \"~A\""
240 index))
241 :charset charset)))
242 (mp:with-lock (*vhosts-lock*)
243 (setf (gethash (string-downcase name) *vhosts*) vhost)
244 (loop
245 for alias in aliases
246 do
247 (setf (gethash (string-downcase alias) *vhosts*) vhost))
248 (when default
249 (setf *vhost-default* vhost))))
250 t)
251
252 (defun vhost-unregister (name)
253 (mp:with-lock (*vhosts-lock*)
254 (multiple-value-bind (vhost exists-p)
255 (gethash (string-downcase name) *vhosts*)
256 (when exists-p
257 (loop
258 for key being each hash-key of *vhosts* using (hash-value val)
259 when (eq val vhost) do (remhash key *vhosts*)))))
260 t)
261
262 (defun vhost-query (name &key (default nil))
263 (mp:with-lock (*vhosts-lock*)
264 (multiple-value-bind (vhost exists-p)
265 (gethash (string-downcase name) *vhosts*)
266 (cond ((and default *vhost-default* (not exists-p))
267 *vhost-default*)
268 (exists-p
269 vhost)
270 (t
271 nil)))))
272
273 ;;; User-supplied paths should be passed through this function, returning
274 ;;; NIL or an object supplied by PATH-VALID-VIRTUAL on VHOST's ROOT and
275 ;;; PATH.
276 (defun vhost-path (vhost path)
277 (path-valid-virtual (vhost-root vhost) path))
278
279
280 ;;; Mime types
281
282 (defvar *mime-type-table* (make-hash-table :test #'equal))
283 (defvar *mime-type-lock* (mp:make-lock :name 'mime-type-lock))
284
285 (defun mime-register (mimetype extensions)
286 (let ((type (string-downcase mimetype)))
287 (mp:with-lock (*mime-type-lock*)
288 (mapc #'(lambda (e)
289 (setf (gethash (string-downcase e) *mime-type-table*) type))
290 extensions))
291 type))
292
293 (defun mime-register-list (types)
294 (mapc #'(lambda (type)
295 (destructuring-bind (mimetype extensions) type
296 (mime-register mimetype extensions)))
297 types)
298 t)
299
300 (defun mime-unregister (extension)
301 (mp:with-lock (*mime-type-lock*)
302 (multiple-value-bind (type exists-p)
303 (gethash (string-downcase extension) *mime-type-table*)
304 (when exists-p
305 (loop
306 for key being each hash-key of *mime-type-table*
307 using (hash-value val)
308 when (eq val type) do (remhash key *mime-type-table*)))))
309 t)
310
311 (defun mime-query (extension &optional (default "application/octet-stream"))
312 (mp:with-lock (*mime-type-lock*)
313 (multiple-value-bind (type exists-p)
314 (gethash (string-downcase extension) *mime-type-table*)
315 (if exists-p
316 type
317 default))))
318
319
320 ;;; HTTP reply
321
322 ;;; Dynamically bound to request object for us
323 (defvar *request* nil)
324
325 (defstruct http-reply
326 (date (server-time-rfc) :type string)
327 (code 200 :type real)
328 (description "Ok" :type string)
329 (headers (list
330 (format nil "Server: ~A" *server-version*)
331 "Connection: close"
332 "Accept-Ranges: bytes")
333 :type list)
334 (content '() :type list)
335 (mime-type "text/html" :type string)
336 (charset (if *request*
337 (vhost-charset (http-request-vhost *request*))
338 "UTF-8")
339 :type string)
340 (protocol (if *request*
341 (http-request-protocol *request*)
342 0.9)
343 :type float))
344
345 (defun http-reply-nocache (reply)
346 (with-accessors ((headers http-reply-headers)) reply
347 (setf headers
348 (append headers
349 (list
350 "Expires: Mon, 26 Jul 1997 05:00:00 GMT"
351 (format nil "Last-Modified: ~A" (http-reply-date reply))
352 "Cache-Control: no-cache, must-revalidate"
353 "Pragma: no-cache")))))
354
355 (defun http-reply-header-add (reply fmt &rest fmt-args)
356 (push (apply #'format nil fmt fmt-args) (http-reply-headers reply)))
357
358 (defun http-reply-content-add (reply content)
359 (push content (http-reply-content reply)))
360
361 (defun http-reply-log-time (&optional (ut (server-time)))
362 (let ((months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
363 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
364 (multiple-value-bind
365 (second minute hour date month year)
366 (decode-universal-time ut 0)
367 (format nil "[~2,'0D/~A/~4,'0D:~2,'0D:~2,'0D:~2,'0D -0000]"
368 date (svref months (1- month)) year
369 hour minute second))))
370
371 ;;; Should only be called once per HTTP-REPLY object
372 (defun http-reply-flush (reply stream &optional (size nil))
373 (let* ((content (http-reply-content reply))
374 (content-len (if size
375 size
376 (loop
377 for s in content
378 sum (length s) into len of-type fixnum
379 finally (return len))))
380 (crlf (format nil "~C~C" #\Return #\LineFeed)))
381
382 (when *request*
383 (let ((connection *connection*)
384 (request *request*))
385 (macrolet ((field (f &optional (type :string))
386 `(let ((%f ,f))
387 ,(if (eq type :string)
388 `(if %f %f "-")
389 `(if (zerop %f) "-" %f)))))
390 (log-line-nostamp "~X ~A - - ~A ~A ~S ~A ~A \"~A\" \"~A\""
391 (connection-session connection)
392 (connection-address-string connection)
393 (http-reply-log-time)
394 (vhost-hostname (http-request-vhost request))
395 (first (http-request-raw request))
396 (http-reply-code reply)
397 (field content-len :integer)
398 (field (http-request-referer request))
399 (field (http-request-agent request))))))
400
401 (when (> (http-reply-protocol reply) 0.9)
402 (with-accessors ((headers http-reply-headers)) reply
403 (push (format nil "Date: ~A" (http-reply-date reply)) headers)
404 (push (format nil "Content-Length: ~D" content-len) headers)
405 (push (format nil "Content-Type: ~A; charset=~A"
406 (http-reply-mime-type reply)
407 (http-reply-charset reply))
408 headers)
409 (push (format nil "HTTP/1.1 ~A ~A"
410 (http-reply-code reply)
411 (http-reply-description reply))
412 headers)
413 (write-string
414 (concatenate 'string
415 (reduce #'(lambda (a b)
416 (concatenate 'string a crlf b))
417 headers)
418 crlf crlf)
419 stream)))
420 (unless size
421 (loop
422 for s in content
423 do (write-string s stream)))
424 (finish-output stream))
425 t)
426
427 (defun http-reply-send (stream string)
428 (http-reply-flush (make-http-reply :content (list string)) stream))
429
430 (defun http-error (stream code message &optional fmt &rest fmt-args)
431 (let ((reply (make-http-reply :code code
432 :description message))
433 (description (if fmt
434 (apply #'format nil fmt fmt-args)
435 nil)))
436 (http-reply-nocache reply)
437 (http-reply-content-add
438 reply
439 (let ((title (html-escape (format nil "~A - ~A" code message))))
440 (do-html nil
441 (:html (:head (:title title))
442 (:body
443 (:h1 title)
444 (do-html-when description
445 (:p (html-escape description)))
446 (:small (html-escape *server-version*)))))))
447 (http-reply-flush reply stream)))
448
449 (defun http-redirect (stream req vpath)
450 (let* ((vhost (http-request-vhost req))
451 (path (vhost-path vhost vpath))
452 (reply (make-http-reply :code 301
453 :description "Moved Permanently"
454 :charset (vhost-charset vhost)))
455 (movedto (format nil "http://~A~A"
456 (http-request-host req)
457 (if path (path-virtual path) nil)))
458 (title "301 - Moved Permanently"))
459 (unless path
460 (http-error stream 403 "Forbidden"
461 "You do not have the permission to access this resource.")
462 (return-from http-redirect nil))
463 (http-reply-nocache reply)
464 (http-reply-header-add reply "Location: ~A" movedto)
465 (http-reply-content-add
466 reply
467 (do-html nil
468 (:html (:head (:title title))
469 (:body
470 (:h1 title)
471 (:p
472 "The document was permanently moved to "
473 (:a :href movedto
474 movedto) ".")
475 (:small (html-escape *server-version*))))))
476 (http-reply-flush reply stream)))
477
478
479 ;;; HTTP request parsing
480
481 ;;; Decodes the URL supplied in STRING to another string, returning it.
482 (defun url-decode (string)
483 (macrolet ((get-octet ()
484 `(if (= input-max input-pos)
485 (loop-finish)
486 (prog1
487 (aref input input-pos)
488 (the fixnum (incf (the fixnum input-pos))))))
489 (put-octet (o)
490 `(vector-push ,o output)))
491 (loop
492 with input = (utf-8-string-encode string)
493 with input-pos of-type fixnum = 0
494 with input-max of-type fixnum = (length input)
495 with output = (make-array (length input)
496 :element-type '(unsigned-byte 8)
497 :fill-pointer 0)
498 for o of-type (unsigned-byte 8) = (get-octet)
499 when (= 37 o) do (let ((c1 (code-char (get-octet)))
500 (c2 (code-char (get-octet))))
501 (when (and (digit-char-p c1 16)
502 (digit-char-p c2 16))
503 (put-octet (parse-integer
504 (map 'string #'identity `(,c1 ,c2))
505 :radix 16))))
506 else when (= 43 o) do (put-octet 32)
507 else do (put-octet o)
508 finally (return (utf-8-string-decode output)))))
509
510
511 ;;; Supplied with a hash table and a string set statement in the form
512 ;;; "variable=value" or "variable[]=value", add the association binding.
513 ;;; If the variable name terminates with "[]", it denotes that the variable
514 ;;; is an array, in which case multiple values may be accumulated into it.
515 (defun property-set (ht str)
516 (let ((parts (string-split str :separators '(#\=) :max 2)))
517 (when (> (length parts) 0)
518 (let ((var (string-downcase (svref parts 0)))
519 (val (if (= 1 (length parts)) "" (svref parts 1)))
520 (array-p nil))
521 ;; Escape and sanity-check VAR
522 (setf var (url-decode var))
523 (when (every #'(lambda (c)
524 (or (alphanumericp c)
525 (member c '(#\- #\[ #\]) :test #'char=)))
526 var)
527 ;; Unescape VAL
528 (setf val (url-decode val))
529 ;; An array?
530 (let ((len (length var)))
531 (declare (type fixnum len))
532 (when (and (> len 2)
533 (char= #\] (schar var (- len 1)))
534 (char= #\[ (schar var (- len 2))))
535 (setf array-p t)))
536 (multiple-value-bind (o exists-p)
537 (gethash var ht)
538 (cond (array-p
539 ;; Array
540 (when (not exists-p)
541 (setf o (make-array 16
542 :element-type 'string
543 :adjustable t
544 :fill-pointer 0)
545 (gethash var ht) o))
546 (vector-push-extend val o 16))
547 (t
548 ;; Normal associative variable
549 (setf (gethash var ht) val)))))))))
550
551 (defun http-get-parse (ht str)
552 (loop
553 with parts = (string-split str
554 :separators '(#\&)
555 :trim-parts '(#\Newline #\Return))
556 for p across parts
557 do
558 (property-set ht p)))
559
560 ;;; Reads the HTTP client request from STREAM, and returns two values,
561 ;;; a status keyword symbol and a list consisting of the collected lines.
562 ;;; :NO-REQUEST no request was sent (empty request)
563 ;;; :REQUEST-SIZE-EXCEEDED request exceeded allowed request size
564 ;;; :REQUEST-TIMEOUT allowed time for request to complete exceeded
565 ;;; :SUCCESS success
566 (defun http-request-read (stream)
567 (loop
568 with max-time of-type integer = (+ (server-time) *request-timeout*)
569 with request-max-size of-type fixnum = *request-max-size*
570 with timeout-signal = nil
571 for line = (handler-case
572 (line-read stream)
573 (sb-bsd-sockets:operation-timeout-error ()
574 (setf timeout-signal t)
575 "<TIMEOUT>"))
576 for words = (if (= nlines 0)
577 (string-split line :max 3)
578 #())
579 until timeout-signal ; Timeout signal
580 while (< chars request-max-size) ; Request size exceeded
581 while (< (server-time) max-time) ; Request timeout
582 until (string= "" line) ; End of HTTP/1.x request
583 until (and (= nlines 0) ; End of HTTP/0.x request
584 (< (length words) 3))
585 sum (length line) into chars of-type fixnum
586 count line into nlines of-type fixnum
587 collect line into lines
588 finally
589 (return
590 (values (cond
591 ((and (= nlines 0)
592 (= (length words) 0))
593 :no-request)
594 ((> chars request-max-size)
595 :request-size-exceeded)
596 ((or (>= (server-time) max-time)
597 timeout-signal)
598 :request-timeout)
599 ((and (= nlines 0)
600 (< (length words) 3))
601 (push line lines)
602 :success)
603 (t
604 :success))
605 lines))))
606
607 ;;; Request parsing preprocessor.
608 ;;; Extracts query from the first request line and coalesces continuating
609 ;;; header lines. Returns the request line as first value and the list
610 ;;; of preprocessed lines as second value.
611 (defun http-request-parse-1 (lines)
612 (values (pop lines)
613 (loop
614 with list = '()
615 with last = nil
616 for line in lines
617 do
618 (cond ((and (let ((c (schar line 0)))
619 (or (char= #\Space c) (char= #\Tab c)))
620 last)
621 (setf (car last)
622 (concatenate 'string (car last) " "
623 (string-trim '(#\Space #\Tab)
624 line))))
625 (t
626 (let ((words
627 (string-split line
628 :separators '(#\:)
629 :trim-parts '(#\Space #\Tab)
630 :max 2)))
631 (when (= 2 (length words))
632 (push line list)
633 (setf last list)))))
634 finally (return list))))
635
636 (defstruct http-request
637 raw
638 (protocol 0.9 :type float)
639 method
640 host
641 (vhost *vhost-default*)
642 path
643 query
644 post
645 (vars-get (make-hash-table :test 'equal))
646 (vars-post (make-hash-table :test 'equal))
647 (vars-cookie (make-hash-table :test 'equal))
648 agent
649 referer
650 (keep-alive 0)
651 (connection "close" :type string)
652 content-type
653 (content-length -1 :type integer)
654 modified-since
655 unmodified-since
656 range)
657
658 ;;; List of headers we care about and functions to fill them.
659 ;;; CLOS could have been used instead after interning a keyword symbol
660 ;;; from the header variable string, but that would probably be slower.
661 (defparameter *header-table*
662 `(("host"
663 ,#'(lambda (o v)
664 (let* ((pos (position #\: v :from-end t))
665 (h (if pos (subseq v 0 pos) v)))
666 (setf (http-request-host o) v
667 (http-request-vhost o) (vhost-query h :default t)))))
668 ("user-agent"
669 ,#'(lambda (o v)
670 (setf (http-request-agent o) v)))
671 ("referer"
672 ,#'(lambda (o v)
673 (setf (http-request-agent o) v)))
674 ("keep-alive"
675 ,#'(lambda (o v)
676 (let ((i (handler-case
677 (parse-integer v)
678 (t ()
679 0))))
680 (setf (http-request-keep-alive o) i))))
681 ("connection"
682 ,#'(lambda (o v)
683 (setf (http-request-connection o) v)))
684 ("content-type"
685 ,#'(lambda (o v)
686 (setf (http-request-content-type o) v)))
687 ("content-length"
688 ,#'(lambda (o v)
689 (let ((i (handler-case
690 (parse-integer v)
691 (t ()
692 -1))))
693 (setf (http-request-content-length o) i))))
694 ("if-modified-since"
695 ,#'(lambda (o v)
696 (setf (http-request-modified-since o)
697 (server-time-rfc-parse v))))
698 ("if-unmodified-since"
699 ,#'(lambda (o v)
700 (setf (http-request-unmodified-since o)
701 (server-time-rfc-parse v))))
702 ("range"
703 ,#'(lambda (o v)
704 (setf (http-request-range o) v)))
705 ("cookie"
706 ,#'(lambda (o v)
707 (property-set (http-request-vars-cookie o) v)))))
708
709 ;;; Reads and parses POST data request if any
710 ;;; XXX Should check the content-length size doesn't exceed allowed limit
711 ;;; XXX Should use a short enough timeout
712 ;;; XXX Should at least also support "multipart/form-data" enctype
713 ;;; XXX We may want to error with 411 Length Required If content-length
714 ;;; is not provided.
715 ;;; XXX We may also want to error with 415 Unsupported Media Type if
716 ;;; the content-type is not expected.
717 (defun http-post-parse (stream req)
718 (when (and (string= (http-request-method req) :post)
719 (string= (http-request-content-type req)
720 "application/x-www-form-urlencoded")
721 (> (http-request-content-length req) 0))
722 (let ((pd
723 (handler-case
724 (loop
725 with length = (http-request-content-length req)
726 with vector = (make-array length
727 :element-type 'character
728 :initial-element #\Nul)
729 while (< read-length length)
730 sum (read-sequence vector stream
731 :start read-length) into read-length
732 finally (return vector))
733 (t ()
734 nil))))
735 (when pd
736 (http-get-parse (http-request-vars-post req) pd))
737 pd)))
738
739 ;;; To avoid constant INTERNing, simply match method strings to keywords
740 (defun method-keyword (method)
741 (let* ((methods #("GET" "POST" "HEAD" "PUT"
742 "DELETE" "TRACE" "CONNECT" "OPTIONS"))
743 (keywords #(:get :post :head :put
744 :delete :trace :connect :options))
745 (pos (position method methods :test #'string=)))
746 (if pos
747 (svref keywords pos)
748 :unknown)))
749
750 ;;; Used to parse the HTTP version
751 (defun parse-float (string)
752 (block nil
753 (when (char= #\. (char string 0))
754 (setf string (concatenate 'string "0" string)))
755 (let ((w (string-split string :separators '(#\.) :max 2)))
756 (unless (= 2 (length w))
757 (return nil))
758 (let ((i1 (handler-case
759 (parse-integer (aref w 0))
760 (t ()
761 nil)))
762 (i2 (handler-case
763 (parse-integer (aref w 1))
764 (t ()
765 nil))))
766 (unless (and i1 i2)
767 (return nil))
768 (float (+ i1 (/ i2 (expt 10 (length (aref w 1))))))))))
769
770 ;;; Parse supplied HTTP version STRING, returning NIL on error or
771 ;;; a floating point representing the number.
772 (defun version-parse (string)
773 (let ((w (string-split string :separators '(#\/) :max 2)))
774 (if (and (= 2 (length w))
775 (string-equal "HTTP" (aref w 0)))
776 (parse-float (aref w 1))
777 nil)))
778
779 ;;; Actual request parsing function.
780 (defun http-request-parse (lines stream)
781 ;; Preprocessing
782 (multiple-value-bind (request headers)
783 (http-request-parse-1 lines)
784 (let ((req (make-http-request))
785 (valid nil))
786 (setf (http-request-raw req) lines)
787
788 ;; Request method/path/protocol
789 (let ((words (string-split request :max 4)))
790 (cond ((< (length words) 3)
791 (setf (http-request-method req) (method-keyword
792 (svref words 0))
793 (http-request-path req) (if (= 2 (length words))
794 (svref words 1)
795 "/")
796 valid t))
797 ((= 3 (length words))
798 (setf (http-request-protocol req) (version-parse
799 (svref words 2))
800 (http-request-method req) (method-keyword
801 (svref words 0))
802 (http-request-path req) (svref words 1)
803 valid t))))
804
805 ;; Headers
806 (when valid
807 (loop
808 for line in headers
809 for var = (string-trim
810 '(#\Space)
811 (string-downcase
812 (subseq line 0 (position #\: line))))
813 for val = (string-trim
814 '(#\Space)
815 (subseq line (1+ (position #\: line :start
816 (length var)))))
817 for fun = (second (find var *header-table*
818 :key #'first
819 :test #'string=))
820 when fun do (funcall fun req val)))
821
822 ;; Separate path from query variables; fill in GET variables if any.
823 (let* ((path (http-request-path req))
824 (pos (position #\? path :test #'char=))
825 (epos (position #\; path :test #'char= :from-end t)))
826 (when pos
827 (let ((get (subseq path (1+ pos) (if epos epos (length path)))))
828 (setf (http-request-path req) (subseq path 0 pos)
829 (http-request-query req) get)
830 (http-get-parse (http-request-vars-get req) get))))
831
832 ;; Read and parse POST data if any
833 (setf (http-request-post req) (http-post-parse stream req))
834
835 ;; Finally return request object for eventual dispatching
836 req)))
837
838
839 ;;; Creates dynamic bindings for a set of variables defined in the
840 ;;; hash-table HT. May be useful to bind the cookie, get and post
841 ;;; variables when calling user code.
842 ;;; These variables are bound with names in the format $PREFIX-<variable>$.
843 ;;; An additional variable is bound to a list of lists holding all bound
844 ;;; variables, named $$PREFIX$$.
845 (defmacro with-ht-bind ((ht prefix) &body body)
846 (let ((s-ht (gensym))
847 (s-prefix (gensym))
848 (s-var (gensym))
849 (s-val (gensym))
850 (s-binding (gensym))
851 (s-vars (gensym))
852 (s-vals (gensym))
853 (s-bindings (gensym)))
854 `(loop
855 with ,s-ht = ,ht
856 with ,s-prefix = ,prefix
857 for ,s-var being each hash-key of ,s-ht using (hash-value ,s-val)
858 for ,s-binding = (intern (format nil "$~A-~A$"
859 (symbol-name ,s-prefix)
860 (string-upcase ,s-var)))
861 collect ,s-binding into ,s-vars
862 collect ,s-val into ,s-vals
863 collect `(,,s-binding ,,s-val) into ,s-bindings
864 finally
865 (progn
866 (push (intern (format nil "$$~A$$" (symbol-name ,s-prefix)))
867 ,s-vars)
868 (push ,s-bindings ,s-vals)
869 (return (progv ,s-vars ,s-vals
870 ,@body))))))
871
872 ;;; Utility function for user code to easily verify that the
873 ;;; wanted variables in the wanted category exist.
874 (defun http-required-vars (&key get post cookie)
875 (flet ((check (category-name category-var vars-list)
876 (every #'(lambda (var)
877 (or (member var category-var
878 :key #'first
879 :test #'eq)
880 (error "Required ~A variable ~S is unbound."
881 category-name var)))
882 vars-list)))
883 (declare (special $$get$$ $$post$$ $$cookie$$))
884 (when get
885 (check "GET" $$get$$ get))
886 (when post
887 (check "POST" $$post$$ post))
888 (when cookie
889 (check "COOKIE" $$cookie$$ cookie)))
890 t)
891
892 (defun req-var (req type var &optional (default ""))
893 (let ((ht (cond ((eq :get type)
894 (http-request-vars-get req))
895 ((eq :post type)
896 (http-request-vars-post req))
897 ((eq :cookie type)
898 (http-request-vars-cookie req)))))
899 (multiple-value-bind (val exists-p)
900 (gethash (string-downcase (symbol-name var)) ht)
901 (if exists-p
902 val
903 default))))
904
905
906 ;;; Debugging
907 (defun debug-feature (keyword)
908 (and *debug* (position keyword *debug* :test #'eq)))
909 (defun beep ()
910 (handler-case
911 (with-open-file (s "/dev/speaker" :direction :output)
912 (write-string "O1L15D" s))
913 (t ()
914 nil)))
915 (defun dump-vars (ht)
916 (with-output-to-string (out)
917 (maphash #'(lambda (k v)
918 (format out "~A = ~S~%" k v))
919 ht)))
920 ;;; XXX Eventually provide such a debug hook binder to user code and
921 ;;; make it conditional on config to report via HTTP or log or both
922 ;;; Actually this may disclose too much information, and might not
923 ;;; be able to work as an error may happen anytime and the connection
924 ;;; might no longer be up, etc.
925 (defmacro with-http-errors ((stream) &body body)
926 (let ((s-block (intern (symbol-name (gensym "BLOCK")) :keyword)))
927 `(block ,s-block
928 (let ((*debugger-hook* #'(lambda (condition hook)
929 (declare (ignore hook))
930 (http-error ,stream 500 "XXX")
931 (return-from ,s-block nil))))
932 ,@body))))
933
934
935
936 (defun html-test-page (req connection)
937 (http-reply-send
938 (connection-stream connection)
939 (do-html nil
940 (:html (:head (:title "Interactively developed test server"))
941 (:body
942 (:h1 "Interactively developed test server")
943 (:p "This page, forms and server code may change anytime "
944 "without interruption; a live SWANK connection is "
945 "maintained from Emacs and SLIME, and the system is "
946 "developed interactively on spare time.")
947 (:p
948 "Follow " (:a :href "/" "this link") " to proceed to a "
949 "mirror of my site hosted on this test server.")
950 (:h2 "Location")
951 (:p "IP address/port: "
952 (connection-address-string connection) ":"
953 (connection-port connection))
954 (:h2 "Test form")
955 (:form :action (html-escape
956 (format nil
957 "/test?id=~64,'0X" (random
958 #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)))
959 :method "post"
960 "First name: "
961 (:/input :name "first-name"
962 :type "text"
963 :size "32"
964 :maxlength "64"
965 :value (html-escape
966 (req-var req :post :first-name
967 "First name")))
968 (:/br)
969 "Last name: "
970 (:/input :name "last-name"
971 :type "text"
972 :size "32"
973 :maxlength "64"
974 :value (html-escape
975 (req-var req :post :last-name
976 "Last name")))
977 (:/br)
978 (do-html-loop (for i from 1 to 10
979 for s = (format nil "~2,'0D" i)
980 for v = (format nil "box-~2,'0D" i))
981 "Box " s
982 ;; XXX If we allowed user code for the tag name,
983 ;; this would have been smaller.
984 (let* ((a (req-var req :post :box[] nil))
985 (c (if a (find v a :test #'string=) nil)))
986 (do-html-if c
987 (:/input :name "box[]"
988 :type "checkbox"
989 :value v
990 :/checked)
991 (:/input :name "box[]"
992 :type "checkbox"
993 :value v))))
994 (:/br)
995 (:textarea :name "message"
996 :rows 10
997 :cols 60
998 (html-escape
999 (req-var req :post :message
1000 "Message text.")))
1001 (:/br)
1002 (:/input :type "submit" :value "Post"))
1003 (:h2 "Browser request")
1004 (:pre
1005 (do-html-loop (for line in (http-request-raw req))
1006 (html-escape (format nil "~A~%" line))))
1007 (:p (:code
1008 (html-escape (format nil "~S~%" req))))
1009 (:h2 "Path")
1010 (html-escape (format nil "~A~%"
1011 (http-request-path req)))
1012 (do-html-when (http-request-query req)
1013 (:h2 "GET data")
1014 (:pre
1015 (html-escape (format nil "~A~%"
1016 (http-request-query req))))
1017 (:pre
1018 (html-escape (dump-vars (http-request-vars-get req)))))
1019 (do-html-when (http-request-post req)
1020 (:h2 "POST data")
1021 (:pre
1022 (html-escape (format nil "~A~%"
1023 (http-request-post req))))
1024 (:pre
1025 (html-escape (dump-vars
1026 (http-request-vars-post req)))))
1027 (do-html-when (> (hash-table-count
1028 (http-request-vars-cookie req)) 0)
1029 (:h2 "COOKIE data")
1030 (:pre
1031 (html-escape (dump-vars
1032 (http-request-vars-cookie req)))))
1033 (:h2 "Server information")
1034 (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
1035 :target "_blank"
1036 "Source available here.")
1037 (:/br)
1038 (do-html-loop
1039 (with packages = (list-all-packages)
1040 for p in packages
1041 for s = (find-symbol "*RCSID*" p)
1042 for v = (if (and s (boundp s))
1043 (html-escape (symbol-value s)) nil)
1044 when v)
1045 (:code v) (:/br))
1046 (:code (html-escape (lisp-implementation-type)) " "
1047 (html-escape (lisp-implementation-version)) " ("
1048 (html-escape (first (mp::uname))) ")")
1049 (:p (:a :href "http://validator.w3.org/check?uri=referer"
1050 (:/img :src
1051 "http://www.w3.org/Icons/valid-xhtml10"
1052 :alt "Valid XHTML 1.0 Transitional"
1053 :height "31"
1054 :width "88"))))))))
1055
1056 (defun http-dynamic-dispatch (req connection path)
1057
1058 (when (debug-feature :test)
1059 (when (string= "/test" (path-virtual path))
1060 (html-test-page req connection)
1061 (return-from http-dynamic-dispatch t)))
1062
1063 nil)
1064
1065 (defun http-static-dispatch (req connection path)
1066 (let ((vhost (http-request-vhost req))
1067 (stream (connection-stream connection))
1068 truepath)
1069
1070 ;; Allowed method?
1071 (let ((method (http-request-method req)))
1072 (unless
1073 (cond
1074 ;; We allow these for static content
1075 ((member method '(:get :head) :test #'eq)
1076 t)
1077 ;; And forbid these
1078 ((member method '(:options :delete :trace :connect :post)
1079 :test #'eq)
1080 (http-error stream 405 "Method Not Allowed")
1081 nil)
1082 ;; Any other unimplemented for static content
1083 (t
1084 (http-error stream 501 "Method Not Implemented")
1085 nil))
1086 (return-from http-static-dispatch))
1087 (when (and (< (http-request-protocol req) 1.0)
1088 (eq :head method))
1089 (http-error stream 400 "Bad Request"
1090 "HTTP versions <= 0.9 have no HEAD method.")
1091 (return-from http-static-dispatch)))
1092
1093 ;; File/directory exists?
1094 (unless (setf truepath (probe-file (path-real path)))
1095 (http-error stream 404 "Not Found"
1096 "\"~A\" could not be found."
1097 (path-virtual path))
1098 (return-from http-static-dispatch))
1099
1100 ;; If a directory, send index file if exists, but 403 otherwise.
1101 (let ((s-truepath (directory-namestring truepath)))
1102 (when (and (= 0 (length (file-namestring truepath)))
1103 (eql (position #\/ s-truepath :test #'char= :from-end t)
1104 (1- (length s-truepath))))
1105 ;; Points to a directory, check if we can find index
1106 (let ((tp
1107 (probe-file
1108 (path-valid (concatenate 'string
1109 "/" (path-real path) "/"
1110 (vhost-index vhost))))))
1111 (setf truepath nil)
1112 (if tp
1113 (setf truepath tp)
1114 (progn
1115 (http-error stream 403 "Forbidden"
1116 "You do not have the permission to access \"~A\"."
1117 (path-virtual path))
1118 (return-from http-static-dispatch))))))
1119
1120 ;; Prepare to send file
1121 (when truepath
1122 (let* ((mime-type (mime-query
1123 (path-extension (file-namestring truepath))))
1124 (reply (make-http-reply :mime-type mime-type
1125 :charset (vhost-charset vhost)))
1126 (lastmodsecs (file-write-date truepath))
1127 (lastmod (server-time-rfc lastmodsecs)))
1128
1129 ;; If-modified/If-unmodified
1130 (let ((modified-since (http-request-modified-since req)))
1131 (when (and modified-since
1132 (<= lastmodsecs modified-since))
1133 (setf (http-reply-code reply) 304
1134 (http-reply-description reply) "Not Modified")
1135 (http-reply-flush reply stream 0)
1136 (return-from http-static-dispatch)))
1137 (let ((unmodified-since (http-request-unmodified-since req)))
1138 (when (and unmodified-since
1139 (> lastmodsecs unmodified-since))
1140 (setf (http-reply-code reply) 412
1141 (http-reply-description reply) "Precondition Failed")
1142 (http-reply-flush reply stream 0)
1143 (return-from http-static-dispatch)))
1144
1145 ;; Range
1146 ;; XXX 416 Requested Range Not Satisfiable
1147
1148 ;; Finally send file (except for HEAD)
1149 (http-reply-header-add reply "Last-Modified: ~A" lastmod)
1150 (with-open-file (in truepath
1151 :direction :input
1152 :element-type '(unsigned-byte 8))
1153 (http-reply-flush reply stream (file-length in))
1154 (when (eq :head (http-request-method req))
1155 (return-from http-static-dispatch))
1156 (loop
1157 with seq = *buffer*
1158 with seqsize of-type fixnum = (array-dimension seq 0)
1159 for len of-type fixnum = (read-sequence seq in)
1160 do (write-sequence seq stream :end len)
1161 while (= seqsize len))
1162 (finish-output stream))))))
1163
1164 (defun http-serve (connection)
1165 (when (debug-feature :beep)
1166 (beep))
1167 (let* ((stream (connection-stream connection))
1168 (session (connection-session connection)))
1169 (multiple-value-bind (status lines)
1170 (http-request-read stream)
1171
1172 (when (eq :no-request status)
1173 (log-line "~X No request" session)
1174 (return-from http-serve nil))
1175
1176 (let* ((req (http-request-parse lines stream))
1177 (*request* req)
1178 (vhost (http-request-vhost req))
1179 (path (vhost-path vhost (http-request-path req))))
1180
1181 (when (debug-feature :log-req)
1182 (let ((*print-pretty* nil))
1183 (log-line "~X ~S" session req)))
1184
1185 (unless (eq :success status)
1186 (cond ((eq :request-size-exceeded status)
1187 (http-error stream 413 "Request Entity Too Large"
1188 "Query length exceeds ~A bytes."
1189 *request-max-size*)
1190 (log-line "~X Query length exceeds ~A bytes"
1191 session *request-max-size*))
1192 ((eq :request-timeout status)
1193 (http-error stream 408 "Request Timeout")
1194 (when (debug-feature :log-timeouts)
1195 (log-line "~X Request Timeout" session))))
1196 (return-from http-serve nil))
1197
1198 ;; We could alternatively accept HTTP > 1.1 and behave like for
1199 ;; HTTP 1.1.
1200 ;; XXX Also see RFC 2616 section 3.1 and RFC 2145
1201 ;; about replying with a version Entity.
1202 (when (>= (http-request-protocol req) 2.0)
1203 (http-error stream 505 "Version Not Supported"
1204 "This server supports HTTP versions <= 2.0.")
1205 (return-from http-serve nil))
1206
1207 (when (and (>= (http-request-protocol req) 1.1)
1208 (null (http-request-host req)))
1209 (http-error stream 400 "Bad Request"
1210 "HTTP versions >= 1.1 require a Host header.")
1211 (return-from http-serve nil))
1212
1213 (unless path
1214 (http-error stream 403 "Forbidden"
1215 "You do not have permission to access this resource.")
1216 (return-from http-serve))
1217
1218 (unless (http-dynamic-dispatch req connection path)
1219 (http-static-dispatch req connection path))))))
1220
1221
1222 ;;; Function called to serve exceeded connections.
1223 (defun http-overflow (connection reason)
1224 (declare (ignore reason))
1225 (let ((stream (connection-stream connection)))
1226 (http-error stream 403.9 "Too many connections"
1227 "Connection limit exceeded for your address. Try again later.")))
1228
1229
1230 (defun httpd-init ()
1231 (vhost-register :name "gw.pulsar-zone.net"
1232 :aliases '("behemoth.xisop" "localhost")
1233 :root "/tmp/htdocs/"
1234 :charset "UTF-8"
1235 :default t)
1236 (mime-register-list *mime-types*)
1237 (server-init (make-server-config :listen-address "0.0.0.0"
1238 :listen-port 7777
1239 :serve-function 'http-serve
1240 :overflow-function 'http-overflow
1241 :buffer 65536
1242 :log-connections
1243 (debug-feature :log-connections)))
1244 t)
1245
1246 (defvar *initialized* (httpd-init))
1247
1248 (defun httpd-cleanup ()
1249 (server-cleanup)
1250 (setf *initialized* nil))