4be28edda48a84fad5614626f6cfea70462a9488
[mmondor.git] / mmsoftware / cl / server / test-httpd.lisp
1 ;;;; $Id: test-httpd.lisp,v 1.10 2011/08/28 00:56:42 mmondor Exp $
2 ;;;;
3 ;;;; Test/exemple minimal HTTP server
4 ;;;;
5 ;;;; Copyright (c) 2011, Matthew Mondor
6 ;;;; ALL RIGHTS RESERVED.
7
8
9 (declaim (optimize (speed 3) (safety 1) (debug 3)))
10
11 (eval-when (:compile-toplevel :load-toplevel)
12 (load "ecl-mp-server")
13 (load "html"))
14
15 (defpackage :httpd
16 (:use :cl :server :html))
17
18 (in-package :httpd)
19
20 (defparameter *rcsid*
21 "$Id: test-httpd.lisp,v 1.10 2011/08/28 00:56:42 mmondor Exp $")
22
23
24 (defparameter *request-timeout* 60)
25 (defparameter *request-max-size* 4096)
26
27
28 (defstruct vhost
29 (hostname "" :type string)
30 (root "/" :type string)
31 (charset "UTF-8" :type string))
32
33 (defvar *vhosts* (make-hash-table :test #'equal))
34 (defvar *vhosts-lock* (mp:make-lock :name 'vhosts-lock))
35 (defvar *vhost-default* nil)
36
37 (defun vhost-register (&key
38 (name "")
39 (aliases '())
40 (root "/")
41 (charset "UTF-8"))
42 (let ((vhost (make-vhost :hostname name
43 :root root
44 :charset charset)))
45 (mp:with-lock (*vhosts-lock*)
46 (setf (gethash (string-downcase name) *vhosts*) vhost)
47 (loop
48 for alias in aliases
49 do
50 (setf (gethash (string-downcase alias) *vhosts*) vhost))))
51 t)
52
53 (defun vhost-unregister (name)
54 (mp:with-lock (*vhosts-lock*)
55 (multiple-value-bind (vhost exists-p)
56 (gethash (string-downcase name) *vhosts*)
57 (when exists-p
58 (loop
59 for key being each hash-key of *vhosts* using (hash-value val)
60 when (eq val vhost) do (remhash key *vhosts*)))))
61 t)
62
63 (defun vhost-query (name &key (default nil))
64 (mp:with-lock (*vhosts-lock*)
65 (loop
66 repeat 2
67 do
68 (multiple-value-bind (vhost exists-p)
69 (gethash (string-downcase name) *vhosts*)
70 (cond ((and default *vhost-default* (not exists-p))
71 (setf name *vhost-default*))
72 (exists-p
73 (return vhost))
74 (t
75 (return nil)))))))
76
77
78 (defparameter *server-version*
79 (let ((parts (string-split *rcsid*
80 :separators '(#\Space #\,))))
81 (concatenate 'string
82 (svref parts 1) "/" (svref parts 3))))
83
84
85 ;;; XXX We have a problem: Say we unescape UTF-8 characters, they still
86 ;;; consist of bytes which we should convert back to actual UTF-8 characters
87 ;;; in the case of UTF-8 EXTERNAL-FORMAT... Which means that ideally, we
88 ;;; should write/decode the string to bytes, escape it then read/reencode
89 ;;; the result. Perhaps that there's a way using READ-BYTE/WRITE-BYTE?
90 ;;; Given STRING is % HEX HEX encoded, decode it while also returning
91 ;;; a string of characters according to EXTERNAL-FORMAT.
92 ;;; For current tests and to continue development immediately, assume
93 ;;; LATIN-1 only.
94 (defun url-decode (string)
95 (with-output-to-string (out)
96 (with-input-from-string (in string)
97 (handler-case
98 (loop
99 for c of-type character = (read-char in)
100 when (char= #\% c)
101 do (let ((c1 (read-char in))
102 (c2 (read-char in)))
103 (when (and (digit-char-p c1 16)
104 (digit-char-p c2 16))
105 (write-char (code-char
106 (parse-integer
107 (map 'string #'identity `(,c1 ,c2))
108 :radix 16))
109 out)))
110 else
111 when (char= #\+ c)
112 do (write-char #\Space out)
113 else
114 do (write-char c out))
115 (end-of-file ()
116 nil)))))
117
118 ;;; Supplied with a hash table and a string set statement in the form
119 ;;; "variable=value" or "variable[]=value", add the association binding.
120 ;;; If the variable name terminates with "[]", it denotes that the variable
121 ;;; is an array, in which case multiple values may be accumulated into it.
122 (defun property-set (ht str)
123 (let ((parts (string-split str :separators '(#\=) :max 2)))
124 (when (> (length parts) 0)
125 (let ((var (string-downcase (svref parts 0)))
126 (val (if (= 1 (length parts)) "" (svref parts 1)))
127 (array-p nil))
128 ;; Escape and sanity-check VAR
129 (setf var (url-decode var))
130 (when (every #'(lambda (c)
131 (or (alphanumericp c)
132 (member c '(#\- #\[ #\]) :test #'char=)))
133 var)
134 ;; Unescape VAL
135 (setf val (url-decode val))
136 ;; An array?
137 (let ((len (length var)))
138 (declare (type fixnum len))
139 (when (and (> len 2)
140 (char= #\] (schar var (- len 1)))
141 (char= #\[ (schar var (- len 2))))
142 (setf array-p t)))
143 (multiple-value-bind (o exists-p)
144 (gethash var ht)
145 (cond (array-p
146 ;; Array
147 (when (not exists-p)
148 (setf o (make-array 16
149 :element-type 'string
150 :adjustable t
151 :fill-pointer 0)
152 (gethash var ht) o))
153 (vector-push-extend val o 16))
154 (t
155 ;; Normal associative variable
156 (setf (gethash var ht) val)))))))))
157
158 (defun http-get-parse (ht str)
159 (loop
160 with parts = (string-split str
161 :separators '(#\&)
162 :trim-parts '(#\Newline #\Return))
163 for p across parts
164 do
165 (property-set ht p)))
166
167
168 ;;; XXX Should support options, like content-length, no-cache, etc...
169 ;;; We possibly also need a way to calculate content-length and send it,
170 ;;; to enhance performance.
171 (defun http-response-headers (stream code message)
172 (format stream
173 "HTTP/1.1 ~A ~A~C
174 Server: ~A~C
175 Connection: close~C
176 Content-Type: text/html; charset=UTF-8~C
177 ~C
178 "
179 code message #\Return
180 *server-version* #\Return
181 #\Return #\Return #\Return))
182
183 (defun http-error (stream code message &optional description)
184 (http-response-headers stream code message)
185 (let ((title (html-escape (format nil "~A - ~A" code message))))
186 (do-html stream
187 (:html (:head (:title title))
188 (:body
189 (:h1 title)
190 (do-html-when description
191 (:p (html-escape description)))
192 (:small (html-escape *server-version*)))))))
193
194 ;;; XXX Should we send :DEPRECATED-PROTOCOL for other methods than GET
195 ;;; for prehistoric requests?
196 ;;; Reads the HTTP client request from STREAM, and returns two values,
197 ;;; a status keyword symbol and a list consisting of the collected lines.
198 ;;; :NO-REQUEST no request was sent (empty request)
199 ;;; :DEPRECATED-PROTOCOL (HTTP < 1.0 GET request sent)
200 ;;; :REQUEST-SIZE-EXCEEDED request exceeded allowed request size
201 ;;; :REQUEST-TIMEOUT allowed time for request to complete exceeded
202 ;;; :SUCCESS success
203 (defun http-request-read (stream)
204 (loop
205 with max-time of-type integer = (+ (server-time) *request-timeout*)
206 with request-max-size of-type fixnum = *request-max-size*
207 for line = (line-read stream)
208 for words = (if (= nlines 0)
209 (string-split line :max 3)
210 #())
211 while (< chars request-max-size) ; Request size exceeded
212 while (< (server-time) max-time) ; Request timeout
213 until (string= "" line) ; End of HTTP/1.x request
214 until (and (= nlines 0) ; End of HTTP/0.x request
215 (= (length words) 2)
216 (string= "GET" (aref words 0)))
217 sum (length line) into chars of-type fixnum
218 count line into nlines of-type fixnum
219 collect line into lines
220 finally
221 (return
222 (values (cond
223 ((and (= nlines 0)
224 (= (length words) 0)) :no-request)
225 ((and (= nlines 0)
226 (= (length words) 2)
227 (string= "GET" (aref words 0)))
228 (push line lines)
229 :deprecated-protocol)
230 ((> chars request-max-size) :request-size-exceeded)
231 ((>= (server-time) max-time) :request-timeout)
232 (t :success))
233 lines))))
234
235 ;;; Request parsing preprocessor.
236 ;;; Extracts METHOD/PATH/PROTOCOL from the first request line and
237 ;;; coalesces continuating header lines. Returns the request line
238 ;;; as first value and the list of preprocessed lines as second value.
239 (defun http-request-parse-1 (lines)
240 (values (pop lines)
241 (loop
242 with list = '()
243 with last = nil
244 for line in lines
245 do
246 (cond ((and (let ((c (schar line 0)))
247 (or (char= #\Space c) (char= #\Tab c)))
248 last)
249 (setf (car last)
250 (concatenate 'string (car last) " "
251 (string-trim '(#\Space #\Tab)
252 line))))
253 (t
254 (let ((words
255 (string-split line
256 :separators '(#\:)
257 :trim-parts '(#\Space #\Tab)
258 :max 2)))
259 (when (= 2 (length words))
260 (push line list)
261 (setf last list)))))
262 finally (return list))))
263
264 (defstruct http-request
265 raw
266 protocol
267 (old-get nil)
268 method
269 host
270 (vhost nil)
271 path
272 query
273 post
274 (vars-get (make-hash-table :test 'equal))
275 (vars-post (make-hash-table :test 'equal))
276 (vars-cookie (make-hash-table :test 'equal))
277 agent
278 referer
279 (keep-alive 0)
280 (connection "close")
281 content-type
282 (content-length -1)
283 (modified-since -1)
284 (unmodified-since -1)
285 range)
286
287 ;;; List of headers we care about and functions to fill them.
288 ;;; CLOS could have been used instead after interning a keyword symbol
289 ;;; from the header variable string, but that would probably be slower.
290 (defparameter *header-table*
291 `(("host"
292 ,#'(lambda (o v)
293 (let ((pos (position #\: v :from-end t)))
294 (when pos
295 (setf v (subseq v 0 pos))))
296 (setf (http-request-host o) v
297 (http-request-vhost o) (vhost-query v :default t))))
298 ("user-agent"
299 ,#'(lambda (o v)
300 (setf (http-request-agent o) v)))
301 ("referer"
302 ,#'(lambda (o v)
303 (setf (http-request-agent o) v)))
304 ("keep-alive"
305 ,#'(lambda (o v)
306 (let ((i (handler-case
307 (parse-integer v)
308 (t ()
309 0))))
310 (setf (http-request-keep-alive o) i))))
311 ("connection"
312 ,#'(lambda (o v)
313 (setf (http-request-connection o) v)))
314 ("content-type"
315 ,#'(lambda (o v)
316 (setf (http-request-content-type o) v)))
317 ("content-length"
318 ,#'(lambda (o v)
319 (let ((i (handler-case
320 (parse-integer v)
321 (t ()
322 -1))))
323 (setf (http-request-content-length o) i))))
324 ("if-modified-since"
325 ,#'(lambda (o v)
326 (setf (http-request-modified-since o)
327 (server-time-rfc-parse v))))
328 ("if-unmodified-since"
329 ,#'(lambda (o v)
330 (setf (http-request-unmodified-since o)
331 (server-time-rfc-parse v))))
332 ("range"
333 ,#'(lambda (o v)
334 (setf (http-request-range o) v)))
335 ("cookie"
336 ,#'(lambda (o v)
337 (property-set (http-request-vars-cookie o) v)))))
338
339 ;;; Reads and parses POST data request if any
340 ;;; XXX Should check the content-length size doesn't exceed allowed limit
341 ;;; XXX Should use a short enough timeout
342 ;;; XXX Should handle UTF-8 decoding errors
343 ;;; Actually, those are not really expected since special characters
344 ;;; are sent escaped.
345 ;;; XXX Should at least also support "multipart/form-data" enctype
346 (defun http-post-parse (stream req)
347 (when (and (string= (http-request-method req) "POST")
348 (string= (http-request-content-type req)
349 "application/x-www-form-urlencoded")
350 (> (http-request-content-length req) 0))
351 (let ((pd
352 (handler-case
353 (loop
354 with length = (http-request-content-length req)
355 with vector = (make-array length
356 :element-type 'character
357 :initial-element #\Nul)
358 while (< read-length length)
359 sum (read-sequence vector stream
360 :start read-length) into read-length
361 finally (return vector))
362 (t ()
363 nil))))
364 (when pd
365 (http-get-parse (http-request-vars-post req) pd))
366 pd)))
367
368 ;;; Actual request parsing function.
369 (defun http-request-parse (lines stream)
370 ;; Preprocessing
371 (multiple-value-bind (request headers)
372 (http-request-parse-1 lines)
373 (let ((req (make-http-request))
374 (valid nil))
375 (setf (http-request-raw req) lines)
376
377 ;; Request method/path/protocol
378 (let ((words (string-split request :max 4)))
379 (cond ((and (= 2 (length words)) (string= "GET" (svref words 0)))
380 (setf (http-request-protocol req) "HTTP/0.0"
381 (http-request-old-get req) t
382 (http-request-method req) "GET"
383 (http-request-path req) (svref words 1)
384 valid t))
385 ((= 3 (length words))
386 (setf (http-request-protocol req) (svref words 2)
387 (http-request-method req) (svref words 0)
388 (http-request-path req) (svref words 1)
389 valid t))))
390
391 ;; Headers
392 (when (and valid (not (http-request-old-get req)))
393 (loop
394 for line in headers
395 for var = (string-trim
396 '(#\Space)
397 (string-downcase
398 (subseq line 0 (position #\: line))))
399 for val = (string-trim
400 '(#\Space)
401 (subseq line (1+ (position #\: line :start
402 (length var)))))
403 for fun = (second (find var *header-table*
404 :key #'first
405 :test #'string=))
406 when fun do (funcall fun req val)))
407
408 ;; XXX Reject pre 1.0 requests on dynamic applications
409
410 ;; XXX Error on other bad requests
411
412 ;; Separate path from query variables; fill in GET variables if any.
413 (let* ((path (http-request-path req))
414 (pos (position #\? path :test #'char=)))
415 (when pos
416 (let ((get (subseq path (1+ pos))))
417 (setf (http-request-path req) (subseq path 0 pos)
418 (http-request-query req) get)
419 (http-get-parse (http-request-vars-get req) get))))
420
421 ;; XXX Verify if resource exists (we should do this before reading
422 ;; any POST, ideally...
423
424 ;; Read and parse POST data if any
425 (setf (http-request-post req) (http-post-parse stream req))
426
427 ;; Finally return request object for eventual dispatching
428 req)))
429
430
431 ;;; Creates dynamic bindings for a set of variables defined in the
432 ;;; hash-table HT. May be useful to bind the cookie, get and post
433 ;;; variables when calling user code.
434 ;;; These variables are bound with names in the format $PREFIX-<variable>$.
435 ;;; An additional variable is bound to a list of lists holding all bound
436 ;;; variables, named $$PREFIX$$.
437 (defmacro with-ht-bind ((ht prefix) &body body)
438 (let ((s-ht (gensym))
439 (s-prefix (gensym))
440 (s-var (gensym))
441 (s-val (gensym))
442 (s-binding (gensym))
443 (s-vars (gensym))
444 (s-vals (gensym))
445 (s-bindings (gensym)))
446 `(loop
447 with ,s-ht = ,ht
448 with ,s-prefix = ,prefix
449 for ,s-var being each hash-key of ,s-ht using (hash-value ,s-val)
450 for ,s-binding = (intern (format nil "$~A-~A$"
451 (symbol-name ,s-prefix)
452 (string-upcase ,s-var)))
453 collect ,s-binding into ,s-vars
454 collect ,s-val into ,s-vals
455 collect `(,,s-binding ,,s-val) into ,s-bindings
456 finally
457 (progn
458 (push (intern (format nil "$$~A$$" (symbol-name ,s-prefix)))
459 ,s-vars)
460 (push ,s-bindings ,s-vals)
461 (return (progv ,s-vars ,s-vals
462 ,@body))))))
463
464 ;;; Utility function for user code to easily verify that the
465 ;;; wanted variables in the wanted category exist.
466 (defun http-required-vars (&key get post cookie)
467 (flet ((check (category-name category-var vars-list)
468 (every #'(lambda (var)
469 (or (member var category-var
470 :key #'first
471 :test #'eq)
472 (error "Required ~A variable ~S is unbound."
473 category-name var)))
474 vars-list)))
475 (declare (special $$get$$ $$post$$ $$cookie$$))
476 (when get
477 (check "GET" $$get$$ get))
478 (when post
479 (check "POST" $$post$$ post))
480 (when cookie
481 (check "COOKIE" $$cookie$$ cookie)))
482 t)
483
484
485 ;;; XXX Debugging
486 (defun dump-vars (ht)
487 (with-output-to-string (out)
488 (maphash #'(lambda (k v)
489 (format out "~A = ~S~%" k v))
490 ht)))
491 (defun req-var (req type var &optional (default ""))
492 (let ((ht (cond ((eq :get type)
493 (http-request-vars-get req))
494 ((eq :post type)
495 (http-request-vars-post req))
496 ((eq :cookie type)
497 (http-request-vars-cookie req)))))
498 (multiple-value-bind (val exists-p)
499 (gethash (string-downcase (symbol-name var)) ht)
500 (if exists-p
501 val
502 default))))
503
504 ;;; XXX Make it conditional on config to report via HTTP or log
505 (defmacro with-http-errors ((stream) &body body)
506 (let ((s-block (intern (symbol-name (gensym "BLOCK")) :keyword)))
507 `(block ,s-block
508 (let ((*debugger-hook* #'(lambda (condition hook)
509 (declare (ignore hook))
510 (http-error ,stream 500 "XXX")
511 (return-from ,s-block nil))))
512 ,@body))))
513
514 ;;; XXX Should dispatch requests to known resources as needed
515 ;;; XXX Should probably display HTTP errors for unhandled Lisp conditions
516 (defun http-serve (connection)
517 (let ((stream (connection-stream connection)))
518 (multiple-value-bind (status lines)
519 (http-request-read stream)
520 (unless (eq :success status)
521 ;; XXX Report appropriate error
522 (http-error stream 403 "Error"
523 (format nil "Error: ~S" status))
524 (log-line "~X Invalid request: ~S"
525 (connection-session connection) status)
526 (finish-output stream)
527 (return-from http-serve nil))
528 (let ((req (http-request-parse lines stream)))
529
530 ;; XXX We should probably eventually disable connect/disconnect
531 ;; messages and format our output more appropriately for an HTTPd.
532 (log-line "~X ~S" (connection-session connection) req)
533
534 (http-response-headers stream 200 "Ok")
535 (do-html stream
536 (:html (:head (:title "Interactively developed test server"))
537 (:body
538 (:h1 "Interactively developed test server")
539 (:p "This page, forms and server code may change anytime "
540 "without interruption; a live SWANK connection is "
541 "maintained from Emacs and SLIME, and the system is "
542 "developed interactively on spare time.")
543 (:h2 "Location")
544 (:p "IP address/port: "
545 (connection-address-string connection) ":"
546 (connection-port connection))
547 (:h2 "Test form")
548 (:form :action (html-escape
549 (format nil
550 "/foo.lisp?id=~64,'0X" (random
551 #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)))
552 :method "post"
553 "First name: "
554 (:/input :name "first-name"
555 :type "text"
556 :size "32"
557 :maxlength "64"
558 :value (html-escape
559 (req-var req :post :first-name
560 "First name")))
561 (:/br)
562 "Last name: "
563 (:/input :name "last-name"
564 :type "text"
565 :size "32"
566 :maxlength "64"
567 :value (html-escape
568 (req-var req :post :last-name
569 "Last name")))
570 (:/br)
571 (do-html-loop (for i from 1 to 10
572 for s = (format nil "~2,'0D" i)
573 for v = (format nil "box-~2,'0D" i))
574 "Box " s
575 ;; XXX If we allowed user code for the tag name,
576 ;; this would have been smaller.
577 (let* ((a (req-var req :post :box[] nil))
578 (c (if a (find v a :test #'string=) nil)))
579 (do-html-if c
580 (:/input :name "box[]"
581 :type "checkbox"
582 :value v
583 :/checked)
584 (:/input :name "box[]"
585 :type "checkbox"
586 :value v))))
587 (:/br)
588 (:textarea :name "message"
589 :rows 10
590 :cols 60
591 (html-escape
592 (req-var req :post :message
593 "Message text.")))
594 (:/br)
595 (:/input :type "submit" :value "Post"))
596 (:h2 "Browser request")
597 (:pre
598 (do-html-loop (for line in lines)
599 (html-escape (format nil "~A~%" line))))
600 (:p (:code
601 (html-escape (format nil "~S~%" req))))
602 (:h2 "Path")
603 (html-escape (format nil "~A~%"
604 (http-request-path req)))
605 (do-html-when (http-request-query req)
606 (:h2 "GET data")
607 (:pre
608 (html-escape (format nil "~A~%"
609 (http-request-query req))))
610 (:pre
611 (html-escape (dump-vars (http-request-vars-get req)))))
612 (do-html-when (http-request-post req)
613 (:h2 "POST data")
614 (:pre
615 (html-escape (format nil "~A~%"
616 (http-request-post req))))
617 (:pre
618 (html-escape (dump-vars
619 (http-request-vars-post req)))))
620 (do-html-when (> (hash-table-count
621 (http-request-vars-cookie req)) 0)
622 (:h2 "COOKIE data")
623 (:pre
624 (html-escape (dump-vars
625 (http-request-vars-cookie req)))))
626 (:h2 "Server information")
627 (do-html-loop
628 (with packages = (list-all-packages)
629 for p in packages
630 for s = (find-symbol "*RCSID*" p)
631 for v = (if (and s (boundp s))
632 (html-escape (symbol-value s)) nil)
633 when v)
634 (:code v) (:/br))
635 (:code (html-escape (lisp-implementation-type)) " "
636 (html-escape (lisp-implementation-version)))
637 (:p (:a :href "http://validator.w3.org/check?uri=referer"
638 (:/img :src
639 "http://www.w3.org/Icons/valid-xhtml10"
640 :alt "Valid XHTML 1.0 Transitional"
641 :height "31"
642 :width "88"))))))
643 (format stream "~%")
644 (finish-output stream)))))
645
646
647 ;;; Function called to serve exceeded connections.
648 (defun http-overflow (connection reason)
649 (declare (ignore reason)) ; XXX
650 (let ((stream (connection-stream connection)))
651 (http-error stream 403.9 "Too many connections"
652 "Connection limit exceeded for your address. Try again later.")
653 (finish-output stream)))
654
655
656 (defun httpd-init ()
657 (vhost-register :name "gw.pulsar-zone.net"
658 :aliases '("behemoth.xisop" "localhost")
659 :root "/home/www/pulsar-zone.net/"
660 :charset "UTF-8")
661 (server-init (make-server-config :listen-address "0.0.0.0"
662 :listen-port 7777
663 :serve-function 'http-serve
664 :overflow-function 'http-overflow))
665 t)
666
667 (defvar *initialized* (httpd-init))
668
669 (defun httpd-cleanup ()
670 (server-cleanup)
671 (setf *initialized* nil))