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