3dbe03365a9fdd94b143cc437cb4f9771733f914
[mmondor.git] / mmsoftware / cl / server / test-httpd.lisp
1 ;;;; $Id: test-httpd.lisp,v 1.41 2012/02/02 15:45:50 mmondor Exp $
2
3 #|
4
5 Copyright (c) 2012, 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 ;;;; ! Find out why large pages using unicode characters don't fully
34 ;;;; load in the browser, it appears they they don't fully get
35 ;;;; flushed out for some reason.
36 ;;;; ! There appears to be a race condition, possibly in the locking
37 ;;;; code. Try again my alternative lock code and compare.
38 ;;;; The code can crash randomly, espcially under some load, and
39 ;;;; it occasionally crashes when loading the httpd from fas.
40 ;;;; - Perhaps make the interface to HTTP-REPLY, HTTP-REPLY-SEND and
41 ;;;; HTTP-ERROR better so that user code doesn't always have to carry
42 ;;;; and care about STREAM, etc. *CONNECTION* already holds it...
43 ;;;; - Implement RANGE
44 ;;;; - URL to application server method dispatching, and setup to be
45 ;;;; used as a library by application servers
46 ;;;; - Perhaps support chunked streams
47 ;;;; - Multipart POST parsing so that files can be uploaded
48 ;;;; - Session helper code, with support for session ID cookie and
49 ;;;; anti-XSS GET session-tied IDs, URL generator to use these IDs,
50 ;;;; user session-specific variables/objects
51 ;;;; - Form generator with form-instance IDs for matching responses to
52 ;;;; queries
53 ;;;; - Test application(s) with simple in-memory objects
54 ;;;; - Make standalone mode specifying config file
55 ;;;; - Make config file specify mime-types file
56 ;;;; - Make standalone mode with swank server to connect to
57 ;;;; - Separate out configuration and test applications
58
59
60 (declaim (optimize (speed 3) (safety 1) (debug 3)))
61
62 (eval-when (:compile-toplevel :load-toplevel)
63 (load "ecl-mp-server")
64 (load "html")
65 (load "character"))
66
67 (defpackage :httpd
68 (:use :cl :server :html :character))
69
70 (in-package :httpd)
71
72 (defparameter *rcsid*
73 "$Id: test-httpd.lisp,v 1.41 2012/02/02 15:45:50 mmondor Exp $")
74
75 (defparameter *server-version*
76 (let ((parts (string-split *rcsid*
77 :separators '(#\Space #\,))))
78 (concatenate 'string
79 (svref parts 1) "/" (svref parts 3))))
80
81
82 ;;; Parameters XXX To move into a structure when we become a library
83
84 ;;; Supported *DEBUG* features:
85 ;;; :log-req :log-connections :log-timeouts :test :beep
86 (defvar *debug* '(:test :log-timeouts))
87 (defparameter *request-timeout* 60)
88 (defparameter *request-max-size* 4096)
89 (defparameter *request-keepalive-timeout* 20)
90 (defparameter *request-keepalive-max* 100)
91
92
93 ;;; Paths
94
95 (defparameter *path-max* 255)
96 (defparameter *path-valid-char-table*
97 (make-valid-character-table (character-intervals
98 '(#\a #\z)
99 '(#\A #\Z)
100 '(#\0 #\9)
101 #\. #\/ #\- #\_)))
102
103 ;;; Returns copy of PATH or NIL. Always begins with "/", with multiple
104 ;;; "/" collapsed into one. Makes sure that PATH only contains allowed
105 ;;; characters (in *PATH-VALID-CHAR-TABLE*) and is shorter than *PATH-MAX*.
106 ;;; Does not allow '.' at the start of PATH or after any '/'.
107 (defun path-valid (path)
108 (let ((out (make-array (1+ (length path))
109 :element-type 'character
110 :fill-pointer 0)))
111 (macrolet ((add-char (c)
112 `(vector-push ,c out)))
113 (add-char #\/)
114 (if
115 (loop
116 with last of-type character = #\/
117 for c of-type character across path
118 do
119 (block continue
120 (when (char= #\/ last)
121 ;; Collapse multiple '/' and prohibit '.' at start
122 (if (char= #\/ c)
123 (return-from continue)
124 (when (char= #\. c)
125 (return nil))))
126 (unless (character-valid-p *path-valid-char-table* c)
127 (return nil))
128 (add-char c)
129 (setf last c))
130 finally (return out))
131 (if (> (length out) *path-max*)
132 nil
133 out)
134 nil))))
135
136 (defstruct path
137 real virtual)
138
139 ;;; Should always be called when processing user-supplied paths.
140 ;;; The application should then only trust the objects returned by
141 ;;; this function. Returns NIL if the path is invalid. On success,
142 ;;; returns a PATH object with:
143 ;;; REAL: System-wide absolute real fullpath, to be used to access the
144 ;;; file/directory in question
145 ;;; VIRTUAL: The virtual root based absolute fullpath, useful to report
146 ;;; to the user.
147 ;;; Note that supplied ROOT should previously have been passed through
148 ;;; PATH-VALID, and that both ROOT and PATH should be absolute paths.
149 (defun path-valid-virtual (root path)
150 (let* ((virtual (path-valid (concatenate 'string "/" path)))
151 (real (if virtual (path-valid (concatenate 'string
152 "/" root "/" virtual))
153 nil)))
154 (if (and virtual real)
155 (make-path :real real
156 :virtual virtual)
157 nil)))
158
159 (defun path-extension (path)
160 (let ((dot (position #\. path
161 :test #'char=
162 :from-end t)))
163 (if dot
164 (string-downcase (subseq path (1+ dot)))
165 nil)))
166
167
168 ;;; VHosts
169
170 (defvar *vhost-default* nil)
171
172 (defstruct vhost
173 (hostname "" :type string)
174 (root "/" :type string)
175 (index "/index.html" :type string)
176 (charset :utf-8 :type keyword)
177 (autoindex nil :type boolean)
178 (post-max-size 1048576 :type integer)
179 (post-timeout 240 :type fixnum)
180 (handlers (make-hash-table :test #'equal)))
181
182 (defvar *vhosts* (make-hash-table :test #'equal))
183 (defvar *vhosts-lock* (mp:make-lock :name 'vhosts-lock))
184
185 (defun vhost-register (&key
186 (name "")
187 (aliases '())
188 (root "/")
189 (index "/index.html")
190 (charset :utf-8)
191 (autoindex nil)
192 (post-max-size 1048576)
193 (post-timeout 240)
194 (default nil))
195 (let ((vhost (make-vhost :hostname name
196 :root (or (path-valid root)
197 (error "Invalid root path \"~A\""
198 root))
199 :index (or (path-valid index)
200 (error "Invalid index path \"~A\""
201 index))
202 :charset charset
203 :post-max-size post-max-size
204 :post-timeout post-timeout
205 :autoindex autoindex)))
206 (mp:with-lock (*vhosts-lock*)
207 (setf (gethash (string-downcase name) *vhosts*) vhost)
208 (loop
209 for alias in aliases
210 do
211 (setf (gethash (string-downcase alias) *vhosts*) vhost))
212 (when default
213 (setf *vhost-default* vhost))))
214 t)
215
216 (defun vhost-unregister (name)
217 (mp:with-lock (*vhosts-lock*)
218 (multiple-value-bind (vhost exists-p)
219 (gethash (string-downcase name) *vhosts*)
220 (when exists-p
221 (loop
222 for key being each hash-key of *vhosts* using (hash-value val)
223 when (eq val vhost) do (remhash key *vhosts*)))))
224 t)
225
226 (defun vhost-query (name &key (default nil))
227 (mp:with-lock (*vhosts-lock*)
228 (multiple-value-bind (vhost exists-p)
229 (gethash (string-downcase name) *vhosts*)
230 (cond ((and default *vhost-default* (not exists-p))
231 *vhost-default*)
232 (exists-p
233 vhost)
234 (t
235 nil)))))
236
237 ;;; User-supplied paths should be passed through this function, returning
238 ;;; NIL or an object supplied by PATH-VALID-VIRTUAL on VHOST's ROOT and
239 ;;; PATH.
240 (defun vhost-path (vhost path)
241 (path-valid-virtual (vhost-root vhost) path))
242
243 ;;; VHost dynamic handlers
244 (defun vhost-handler-register (vhost-name handlers)
245 (let ((vhost (vhost-query vhost-name)))
246 (check-type vhost vhost)
247 (mp:with-lock (*vhosts-lock*)
248 (mapc #'(lambda (l)
249 (destructuring-bind (path function) l
250 (check-type path string)
251 (let ((vpath (string-downcase (path-valid path))))
252 (setf (gethash vpath (vhost-handlers vhost))
253 function))))
254 handlers)))
255 nil)
256
257 (defun vhost-handler-list (vhost-name)
258 (let* ((vhost (vhost-query vhost-name))
259 (list '()))
260 (when vhost
261 (mp:with-lock (*vhosts-lock*)
262 (maphash #'(lambda (k v)
263 (declare (ignore v))
264 (push k list))
265 (vhost-handlers vhost))))
266 (sort list #'string<)))
267
268 (defun vhost-handler-unregister (vhost-name handlers)
269 (let ((vhost (vhost-query vhost-name)))
270 (when (and vhost handlers)
271 (mp:with-lock (*vhosts-lock*)
272 (mapc #'(lambda (s)
273 (check-type s string)
274 (let ((function (gethash s (vhost-handlers vhost))))
275 (when function
276 (remhash s (vhost-handlers vhost)))))
277 handlers)))))
278
279 (defun vhost-handler-query (vhost vpath)
280 (let ((function nil))
281 (mp:with-lock (*vhosts-lock*)
282 (let ((fun (gethash vpath (vhost-handlers vhost))))
283 (setf function fun)))
284 function))
285
286
287 ;;; Mime types
288
289 (defvar *mime-type-table* (make-hash-table :test #'equal))
290 (defvar *mime-type-lock* (mp:make-lock :name 'mime-type-lock))
291 (defvar *mime-type-file* "mime-types.lisp")
292
293 (defun mime-register (mimetype extensions)
294 (let ((type (string-downcase mimetype)))
295 (mp:with-lock (*mime-type-lock*)
296 (mapc #'(lambda (e)
297 (setf (gethash (string-downcase e) *mime-type-table*) type))
298 extensions))
299 type))
300
301 (defun mime-register-list (types)
302 (mapc #'(lambda (type)
303 (destructuring-bind (mimetype extensions) type
304 (mime-register mimetype extensions)))
305 types)
306 t)
307
308 (defun mime-unregister (extension)
309 (mp:with-lock (*mime-type-lock*)
310 (multiple-value-bind (type exists-p)
311 (gethash (string-downcase extension) *mime-type-table*)
312 (when exists-p
313 (loop
314 for key being each hash-key of *mime-type-table*
315 using (hash-value val)
316 when (eq val type) do (remhash key *mime-type-table*)))))
317 t)
318
319 (defun mime-query (extension &optional (default "application/octet-stream"))
320 (mp:with-lock (*mime-type-lock*)
321 (multiple-value-bind (type exists-p)
322 (gethash (string-downcase extension) *mime-type-table*)
323 (if exists-p
324 type
325 default))))
326
327 (defun mime-load (file)
328 (load file)
329 (setf *mime-type-file* file)
330 (mime-register-list *mime-types*))
331
332 (defun mime-reload ()
333 (load *mime-type-file*)
334 (mime-register-list *mime-types*))
335
336
337 ;;; HTTP reply
338
339 ;;; Dynamically bound to request object for us
340 (defvar *request* nil)
341
342 ;;; Useful to elegantly longjmp back to the request reader as soon as a
343 ;;; request is flushed.
344 (define-condition http-reply-signal
345 (simple-error)
346 ())
347
348 (define-condition http-reply-signal-no-keepalive
349 (http-reply-signal)
350 ())
351
352 (defstruct http-reply
353 (date (server-time-rfc) :type string)
354 (code 200 :type real)
355 (description "Ok" :type string)
356 (headers (list
357 (format nil "Server: ~A" *server-version*)
358 "Accept-Ranges: bytes")
359 :type list)
360 (content '() :type list)
361 (mime-type "text/html" :type string)
362 (charset (if *request*
363 (vhost-charset (http-request-vhost *request*))
364 :utf-8)
365 :type keyword)
366 (protocol (if *request*
367 (let ((protocol (http-request-protocol *request*)))
368 (if protocol
369 protocol
370 0.9))
371 0.9)
372 :type float)
373 (no-keepalive nil))
374
375 (defun http-reply-nocache (reply)
376 (with-accessors ((headers http-reply-headers)) reply
377 (setf headers
378 (append headers
379 (list
380 "Expires: Mon, 26 Jul 1997 05:00:00 GMT"
381 (format nil "Last-Modified: ~A" (http-reply-date reply))
382 "Cache-Control: no-cache, must-revalidate"
383 "Pragma: no-cache")))))
384
385 (defun http-reply-header-add (reply fmt &rest fmt-args)
386 (push (apply #'format nil fmt fmt-args) (http-reply-headers reply)))
387
388 (defun http-reply-content-add (reply content)
389 (push content (http-reply-content reply)))
390
391 (defun http-reply-log-time (&optional (ut (server-time)))
392 (let ((months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
393 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
394 (multiple-value-bind
395 (second minute hour date month year)
396 (decode-universal-time ut 0)
397 (format nil "[~2,'0D/~A/~4,'0D:~2,'0D:~2,'0D:~2,'0D -0000]"
398 date (svref months (1- month)) year
399 hour minute second))))
400
401 ;;; Should only be called once per HTTP-REPLY object.
402 ;;; If size is not provided or is zero, signal HTTP-REPLY-SIGNAL.
403 (defun http-reply-flush (reply stream &optional (size nil))
404 (let* ((request *request*)
405 (encoding (if request
406 (vhost-charset (http-request-vhost request))
407 (vhost-charset *vhost-default*)))
408 (content (if (eq :utf-8 encoding)
409 (mapcar #'utf-8-string-encode
410 (http-reply-content reply))
411 (http-reply-content reply)))
412 (content-len (if size
413 size
414 (loop
415 for s in content
416 sum (length s) into len of-type fixnum
417 finally (return len))))
418 (crlf (format nil "~C~C" #\Return #\LineFeed)))
419
420 (when request
421 (let ((connection *connection*))
422 (when (http-reply-no-keepalive reply)
423 (http-request-disable-keepalive request))
424 (macrolet ((field (f &optional (type :string))
425 `(let ((%f ,f))
426 ,(if (eq type :string)
427 `(if %f %f "-")
428 `(if (zerop %f) "-" %f)))))
429 (log-line-nostamp "~X ~A - - ~A ~A ~S ~A ~A \"~A\" \"~A\""
430 (connection-session connection)
431 (connection-address-string connection)
432 (http-reply-log-time)
433 (vhost-hostname (http-request-vhost request))
434 (first (http-request-raw request))
435 (http-reply-code reply)
436 (field content-len :integer)
437 (field (http-request-referer request))
438 (field (http-request-agent request))))))
439
440 (when (> (http-reply-protocol reply) 0.9)
441 (with-accessors ((headers http-reply-headers)) reply
442 (push (format nil "Date: ~A" (http-reply-date reply)) headers)
443 (push (format nil "Content-Length: ~D" content-len) headers)
444 (push (format nil "Content-Type: ~A; charset=~A"
445 (http-reply-mime-type reply)
446 (symbol-name (http-reply-charset reply)))
447 headers)
448 (if (and *request*
449 (http-request-keep-alive *request*))
450 (when (= 1.0 (http-request-protocol *request*))
451 (push (format nil "Keep-Alive: timeout=~D, max=~D"
452 *request-keepalive-timeout*
453 *request-keepalive-max*)
454 headers)
455 (push "Connection: Keep-Alive" headers))
456 (push "Connection: close" headers))
457 ;; Must push last so that it gets displayed first
458 (push (format nil "HTTP/1.1 ~A ~A"
459 (http-reply-code reply)
460 (http-reply-description reply))
461 headers)
462 (write-string
463 (concatenate 'string
464 (reduce #'(lambda (a b)
465 (concatenate 'string a crlf b))
466 headers)
467 crlf crlf)
468 stream)))
469 (unless size
470 (loop
471 with rcontent = (reverse content)
472 for s in rcontent
473 do
474 (write-sequence s stream)))
475 (finish-output stream))
476 (when (or (null size) (zerop size))
477 (error (make-condition (if (http-reply-no-keepalive reply)
478 'http-reply-signal-no-keepalive
479 'http-reply-signal))))
480 t)
481
482 (defun http-reply-send (stream string)
483 (http-reply-flush (make-http-reply :content (list string)) stream))
484
485 (defun http-error (stream code message &optional fmt &rest fmt-args)
486 (let ((reply (make-http-reply :code code
487 :description message
488 :no-keepalive t))
489 (description (if fmt
490 (apply #'format nil fmt fmt-args)
491 nil)))
492 (http-reply-nocache reply)
493 (http-reply-content-add
494 reply
495 (let ((title (html-escape (format nil "~A - ~A" code message))))
496 (do-html nil
497 (:html (:head (:title title))
498 (:body
499 (:h1 title)
500 (do-html-when description
501 (:p (html-escape description)))
502 (:small (html-escape *server-version*)))))))
503 (http-reply-flush reply stream)))
504
505 (defun http-error-unimplemented (stream)
506 (let ((reply (make-http-reply :code 501
507 :description "Method Not Implemented"
508 :no-keepalive t)))
509 (http-reply-nocache reply)
510 (http-reply-header-add reply "Allow: GET, HEAD, POST")
511 (http-reply-content-add
512 reply
513 (let ((title "501 - Method Not Implemented"))
514 (do-html nil
515 (:html (:head (:title title))
516 (:body
517 (:h1 title)
518 (:small (html-escape *server-version*)))))))
519 (http-reply-flush reply stream)))
520
521 (defun http-redirect (stream req vpath)
522 (let* ((vhost (http-request-vhost req))
523 (path (vhost-path vhost vpath))
524 (reply (make-http-reply :code 301
525 :description "Moved Permanently"
526 :charset (vhost-charset vhost)))
527 (movedto (format nil "http://~A~A"
528 (http-request-host req)
529 (if path (path-virtual path) nil)))
530 (title "301 - Moved Permanently"))
531 (unless path
532 (http-error stream 403 "Forbidden"
533 "You do not have the permission to access this resource."))
534 (http-reply-nocache reply)
535 (http-reply-header-add reply "Location: ~A" movedto)
536 (http-reply-content-add
537 reply
538 (do-html nil
539 (:html (:head (:title title))
540 (:body
541 (:h1 title)
542 (:p
543 "The document was permanently moved to "
544 (:a :href movedto
545 movedto) ".")
546 (:small (html-escape *server-version*))))))
547 (http-reply-flush reply stream)))
548
549 (defun http-index-time (&optional (ut (server-time)))
550 (let ((months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
551 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
552 (multiple-value-bind
553 (second minute hour date month year)
554 (decode-universal-time ut 0)
555 (format nil "~2,'0D-~A-~4,'0D~C~2,'0D:~2,'0D:~2,'0D"
556 date (svref months (1- month)) year #\U00A0
557 hour minute second))))
558
559 (defun http-index-size (bytes)
560 (format nil "~,3F&nbsp;KB" (float (/ bytes 1024))))
561
562 (defun http-send-index (stream path)
563 (let ((title (html-escape (format nil "Index of ~A" (path-virtual path))))
564 (dirs
565 (sort (remove-if-not
566 #'path-valid
567 (mapcar #'(lambda (d)
568 (concatenate 'string
569 (car (last (pathname-directory d)))
570 "/"))
571 (directory
572 (concatenate 'string
573 (path-real path) "/*/"))))
574 #'string-lessp))
575 (files
576 (sort (remove-if-not
577 #'path-valid
578 (mapcar #'file-namestring
579 (directory
580 (concatenate 'string
581 (path-real path) "/*.*"))))
582 #'string-lessp)))
583 (http-reply-send
584 stream
585 (do-html nil
586 (:html (:head (:title title))
587 (:body :style "background: #d0d0d0;"
588 (:h1 title)
589 (:/hr)
590 (:ul (:li (:a :href "../"
591 (:code "../") " (Parent directory)")))
592 (do-html-unless (or dirs files)
593 (:/hr)
594 (:h2 "Directory empty."))
595 (do-html-when dirs
596 (:/hr)
597 (:h2 "Directories")
598 (:ul
599 (do-html-loop (for i in dirs
600 for l = (html-escape i))
601 (:li (:a :href l (:code l))))))
602 (do-html-when files
603 (:/hr)
604 (:h2 "Files")
605 (:table :cellpadding "3"
606 (:tr (:th :width "70%" :align "left" (:b "Name"))
607 (:th :width "10%" :align "right" (:b "Size"))
608 (:th :width "20%" :align "center"
609 (:b "Modified&nbsp;(UTC)")))
610 (do-html-loop (for i in files
611 for c from 0
612 for color = (if (evenp c)
613 "#b0b0b0"
614 "#c0c0c0")
615 for l = (html-escape i)
616 for rpath = (concatenate 'string
617 (path-real path)
618 "/" i)
619 for lastmod = (html-escape
620 (http-index-time
621 (file-write-date rpath)))
622 for size = (with-open-file
623 (s rpath :direction :input)
624 (file-length s)))
625 (:tr :style (format nil "background: ~A;" color)
626 (:td (:a :href l (:code l)))
627 (:td :align "right" (:code (http-index-size size)))
628 (:td :align "center" (:code lastmod))))))
629 (:/hr)
630 (:small (html-escape *server-version*))))))))
631
632
633 ;;; HTTP request parsing
634
635 ;;; Decodes the URL supplied in STRING to another string, returning it.
636 (defun url-decode (string)
637 (macrolet ((get-octet ()
638 `(if (= input-max input-pos)
639 (loop-finish)
640 (prog1
641 (aref input input-pos)
642 (the fixnum (incf (the fixnum input-pos))))))
643 (put-octet (o)
644 `(vector-push ,o output)))
645 (loop
646 with input = (utf-8-string-encode string)
647 with input-pos of-type fixnum = 0
648 with input-max of-type fixnum = (length input)
649 with output = (make-array (length input)
650 :element-type '(unsigned-byte 8)
651 :fill-pointer 0)
652 for o of-type (unsigned-byte 8) = (get-octet)
653 when (= 37 o) do (let ((c1 (code-char (get-octet)))
654 (c2 (code-char (get-octet))))
655 (when (and (digit-char-p c1 16)
656 (digit-char-p c2 16))
657 (put-octet (parse-integer
658 (map 'string #'identity `(,c1 ,c2))
659 :radix 16))))
660 else when (= 43 o) do (put-octet 32)
661 else do (put-octet o)
662 finally (return (utf-8-string-decode output)))))
663
664 (defvar *url-safe-char-table*
665 (make-valid-character-table
666 (character-intervals '(#\A #\Z)
667 '(#\a #\z)
668 '(#\0 #\9))))
669
670 ;;; Encodes the supplied URL in STRING to another string, returning it.
671 (defun url-encode (string)
672 (flet ((url-encode-char (c)
673 (if (character-valid-p *url-safe-char-table* c)
674 c
675 (reduce #'(lambda (a b)
676 (concatenate 'string a b))
677 (map 'list #'(lambda (o)
678 (format nil "%~2,'0X" o))
679 (utf-8-string-encode (string c)))))))
680 (with-output-to-string (out)
681 (with-input-from-string (in string)
682 (loop
683 for c = (handler-case
684 (read-char in)
685 (end-of-file ()
686 nil))
687 for toc = (if c (url-encode-char c) nil)
688 while toc
689 when (characterp toc) do (write-char toc out)
690 else do (write-string toc out))))))
691
692 ;;; Supplied with a hash table and a string set statement in the form
693 ;;; "variable=value" or "variable[]=value", add the association binding.
694 ;;; If the variable name terminates with "[]", it denotes that the variable
695 ;;; is an array, in which case multiple values may be accumulated into it.
696 (defun property-set (ht str)
697 (let ((parts (string-split str :separators '(#\=) :max 2)))
698 (when (> (length parts) 0)
699 (let ((var (string-downcase (svref parts 0)))
700 (val (if (= 1 (length parts)) "" (svref parts 1)))
701 (array-p nil))
702 ;; Escape and sanity-check VAR
703 (setf var (url-decode var))
704 (when (every #'(lambda (c)
705 (or (alphanumericp c)
706 (member c '(#\- #\[ #\]) :test #'char=)))
707 var)
708 ;; Unescape VAL
709 (setf val (url-decode val))
710 ;; An array?
711 (let ((len (length var)))
712 (declare (type fixnum len))
713 (when (and (> len 2)
714 (char= #\] (schar var (- len 1)))
715 (char= #\[ (schar var (- len 2))))
716 (setf array-p t)))
717 (multiple-value-bind (o exists-p)
718 (gethash var ht)
719 (cond (array-p
720 ;; Array
721 (when (not exists-p)
722 (setf o (make-array 16
723 :element-type 'string
724 :adjustable t
725 :fill-pointer 0)
726 (gethash var ht) o))
727 (vector-push-extend val o 16))
728 (t
729 ;; Normal associative variable
730 (setf (gethash var ht) val)))))))))
731
732 (defun http-get-parse (ht str)
733 (loop
734 with parts = (string-split str
735 :separators '(#\&)
736 :trim-parts '(#\Newline #\Return))
737 for p across parts
738 do
739 (property-set ht p)))
740
741 ;;; Reads the HTTP client request from STREAM, and returns two values,
742 ;;; a status keyword symbol and a list consisting of the collected lines.
743 ;;; :NO-REQUEST no request was sent (empty request)
744 ;;; :REQUEST-SIZE-EXCEEDED request exceeded allowed request size
745 ;;; :REQUEST-TIMEOUT allowed time for request to complete exceeded
746 ;;; :SUCCESS success
747 (defun http-request-read (stream)
748 (loop
749 with max-time of-type integer = (+ (server-time) *request-timeout*)
750 with request-max-size of-type fixnum = *request-max-size*
751 with timeout-signal = nil
752 for line = (handler-case
753 (line-read stream)
754 (sb-bsd-sockets:operation-timeout-error ()
755 (setf timeout-signal t)
756 "<TIMEOUT>"))
757 for words = (if (= nlines 0)
758 (string-split line :max 3)
759 #())
760 until timeout-signal ; Timeout signal
761 while (< chars request-max-size) ; Request size exceeded
762 while (< (server-time) max-time) ; Request timeout
763 until (string= "" line) ; End of HTTP/1.x request
764 until (and (= nlines 0) ; End of HTTP/0.x request
765 (< (length words) 3))
766 sum (length line) into chars of-type fixnum
767 count line into nlines of-type fixnum
768 collect line into lines
769 finally
770 (return
771 (values (cond
772 ((and (= nlines 0)
773 (= (length words) 0))
774 :no-request)
775 ((> chars request-max-size)
776 :request-size-exceeded)
777 ((or (>= (server-time) max-time)
778 timeout-signal)
779 :request-timeout)
780 ((and (= nlines 0)
781 (< (length words) 3))
782 (push line lines)
783 :success)
784 (t
785 :success))
786 lines))))
787
788 ;;; Request parsing preprocessor.
789 ;;; Extracts query from the first request line and coalesces continuating
790 ;;; header lines. Returns the request line as first value and the list
791 ;;; of preprocessed lines as second value.
792 (defun http-request-parse-1 (lines)
793 (values (pop lines)
794 (loop
795 with list = '()
796 with last = nil
797 for line in lines
798 do
799 (cond ((and (let ((c (schar line 0)))
800 (or (char= #\Space c) (char= #\Tab c)))
801 last)
802 (setf (car last)
803 (concatenate 'string (car last) " "
804 (string-trim '(#\Space #\Tab)
805 line))))
806 (t
807 (let ((words
808 (string-split line
809 :separators '(#\:)
810 :trim-parts '(#\Space #\Tab)
811 :max 2)))
812 (when (= 2 (length words))
813 (push line list)
814 (setf last list)))))
815 finally (return list))))
816
817 (defstruct http-request
818 (raw nil)
819 (protocol 0.9 :type (or null float))
820 (method nil)
821 (host nil)
822 (vhost *vhost-default*)
823 (path nil)
824 (query nil)
825 (post nil)
826 (vars-get (make-hash-table :test 'equal))
827 (vars-post (make-hash-table :test 'equal))
828 (vars-cookie (make-hash-table :test 'equal))
829 (agent nil)
830 (referer nil)
831 (keep-alive nil :type boolean)
832 (content-type "application/x-www-form-urlencoded")
833 (content-length -1 :type integer)
834 (modified-since nil)
835 (unmodified-since nil)
836 (range nil))
837
838 (defun http-request-disable-keepalive (request)
839 (setf (http-request-keep-alive request) nil))
840
841 ;;; List of headers we care about and functions to fill them.
842 ;;; CLOS could have been used instead after interning a keyword symbol
843 ;;; from the header variable string, but that would probably be slower.
844 (defparameter *header-list*
845 `(("host"
846 ,#'(lambda (o v)
847 (let* ((pos (position #\: v :from-end t))
848 (h (if pos (subseq v 0 pos) v)))
849 (setf (http-request-host o) v
850 (http-request-vhost o) (vhost-query h :default t)))))
851 ("user-agent"
852 ,#'(lambda (o v)
853 (setf (http-request-agent o) v)))
854 ("referer"
855 ,#'(lambda (o v)
856 (setf (http-request-referer o) v)))
857 ("connection"
858 ,#'(lambda (o v)
859 (cond ((string-equal "keep-alive" v)
860 (setf (http-request-keep-alive o) t))
861 ((string-equal "close" v)
862 (setf (http-request-keep-alive o) nil)))))
863 ("content-type"
864 ,#'(lambda (o v)
865 (setf (http-request-content-type o) v)))
866 ("content-length"
867 ,#'(lambda (o v)
868 (let ((i (handler-case
869 (parse-integer v)
870 (t ()
871 -1))))
872 (setf (http-request-content-length o) i))))
873 ("if-modified-since"
874 ,#'(lambda (o v)
875 (setf (http-request-modified-since o)
876 (server-time-rfc-parse v))))
877 ("if-unmodified-since"
878 ,#'(lambda (o v)
879 (setf (http-request-unmodified-since o)
880 (server-time-rfc-parse v))))
881 ("range"
882 ,#'(lambda (o v)
883 (setf (http-request-range o) v)))
884 ("cookie"
885 ,#'(lambda (o v)
886 (property-set (http-request-vars-cookie o) v)))))
887
888 (defparameter *header-table*
889 (let ((ht (make-hash-table :test 'equal)))
890 (mapc #'(lambda (l)
891 (destructuring-bind (field function) l
892 (setf (gethash field ht) function)))
893 *header-list*)
894 ht))
895
896 ;;; Reads and parses POST data request if any
897 ;;; XXX Should at least also support "multipart/form-data" enctype
898 (defun http-post-parse (stream)
899 (let* ((req *request*)
900 (req-length (http-request-content-length req))
901 (req-vhost (http-request-vhost req))
902 (req-type (let* ((type (http-request-content-type req))
903 (pos (position #\; type)))
904 (if pos
905 (subseq type 0 pos)
906 type))))
907 (unless (eq (http-request-method req) :post)
908 (return-from http-post-parse))
909 (unless (string= req-type "application/x-www-form-urlencoded")
910 (http-error stream 415 "Unsupported Media Type"
911 "The POST enctype \"~A\" is unsupported." req-type))
912 (when (= -1 req-length)
913 (http-error stream 411 "Length Required"))
914 (unless (< 0 req-length (vhost-post-max-size req-vhost))
915 (http-error stream 413 "Request Entity Too Large"))
916 (let ((pd
917 (handler-case
918 (loop
919 with max-time of-type integer = (+ (server-time)
920 (vhost-post-timeout
921 req-vhost))
922 with timeout-signal = nil
923 with vector = (make-array req-length
924 :element-type 'character
925 :initial-element #\Nul)
926 sum (handler-case
927 (read-sequence vector stream
928 :start read-length)
929 (simple-error ()
930 (setf timeout-signal t)
931 0)) into read-length
932 until timeout-signal
933 while (< (server-time) max-time)
934 while (< read-length req-length)
935 finally
936 (progn
937 (when (or (>= (server-time) max-time)
938 timeout-signal)
939 (http-error stream 408 "Request Timeout"))
940 (return vector)))
941 (ext:stream-decoding-error ()
942 (http-error stream 500 "Internal Server Error"
943 "Character decoding error.")))))
944 (if pd
945 (progn
946 (http-get-parse (http-request-vars-post req) pd)
947 pd)
948 nil))))
949
950 ;;; To avoid constant INTERNing, simply match method strings to keywords
951 (defun method-keyword (method)
952 (let* ((methods #("GET" "POST" "HEAD" "PUT"
953 "DELETE" "TRACE" "CONNECT" "OPTIONS"))
954 (keywords #(:get :post :head :put
955 :delete :trace :connect :options))
956 (pos (position method methods :test #'string=)))
957 (if pos
958 (svref keywords pos)
959 :unknown)))
960
961 ;;; Used to parse the HTTP version
962 (defun parse-float (string)
963 (when (char= #\. (char string 0))
964 (setf string (concatenate 'string "0" string)))
965 (let ((w (string-split string :separators '(#\.) :max 2)))
966 (if (= 2 (length w))
967 (let ((i1 (handler-case
968 (parse-integer (aref w 0))
969 (t ()
970 nil)))
971 (i2 (handler-case
972 (parse-integer (aref w 1))
973 (t ()
974 nil))))
975 (if (and i1 i2)
976 (float (+ i1 (/ i2 (expt 10 (length (aref w 1))))))
977 nil))
978 nil)))
979
980 ;;; Parse supplied HTTP version STRING, returning NIL on error or
981 ;;; a floating point representing the number.
982 (defun version-parse (string)
983 (let ((w (string-split string :separators '(#\/) :max 2)))
984 (if (and (= 2 (length w))
985 (string-equal "HTTP" (aref w 0)))
986 (parse-float (aref w 1))
987 nil)))
988
989 ;;; Actual request parsing function.
990 (defun http-request-parse (lines stream)
991 ;; Preprocessing
992 (multiple-value-bind (request headers)
993 (http-request-parse-1 lines)
994 (let ((req (make-http-request))
995 (valid nil))
996 (setf (http-request-raw req) lines)
997
998 ;; Request method/path/protocol
999 (let* ((words (string-split request :max 4))
1000 (nwords (length words)))
1001 (cond ((< nwords 3)
1002 (setf (http-request-method req) (method-keyword
1003 (svref words 0))
1004 (http-request-path req) (if (= 2 (length words))
1005 (svref words 1)
1006 "/")
1007 valid t))
1008 ((= 3 nwords)
1009 (setf (http-request-protocol req) (version-parse
1010 (svref words 2))
1011 (http-request-method req) (method-keyword
1012 (svref words 0))
1013 (http-request-path req) (svref words 1)
1014 valid t))))
1015
1016 ;; Keep-Alive on by default for HTTP/1.1, headers might change it
1017 (let ((protocol (http-request-protocol req)))
1018 (when (and protocol (= 1.1 protocol))
1019 (setf (http-request-keep-alive req) t)))
1020
1021 ;; Headers
1022 (when valid
1023 (loop
1024 for line in headers
1025 for var = (string-trim
1026 '(#\Space)
1027 (string-downcase
1028 (subseq line 0 (position #\: line))))
1029 for val = (string-trim
1030 '(#\Space)
1031 (subseq line (1+ (position #\: line :start
1032 (length var)))))
1033 for fun = (gethash var *header-table*)
1034 when fun do (funcall fun req val)))
1035
1036 ;; Separate path from query variables; fill in GET variables if any.
1037 (let* ((path (http-request-path req))
1038 (pos (position #\? path :test #'char=))
1039 (epos (position #\; path :test #'char= :from-end t)))
1040 (when pos
1041 (let ((get (subseq path (1+ pos) (if epos epos (length path)))))
1042 (setf (http-request-path req) (subseq path 0 pos)
1043 (http-request-query req) get)
1044 (http-get-parse (http-request-vars-get req) get))))
1045
1046 ;; Read and parse POST data if any
1047 (let ((*request* req))
1048 (setf (http-request-post req) (http-post-parse stream)))
1049
1050 ;; Finally return request object for eventual dispatching
1051 req)))
1052
1053
1054 ;;; Creates dynamic bindings for a set of variables defined in the
1055 ;;; hash-table HT. May be useful to bind the cookie, get and post
1056 ;;; variables when calling user code.
1057 ;;; These variables are bound with names in the format $PREFIX-<variable>$.
1058 ;;; An additional variable is bound to a list of lists holding all bound
1059 ;;; variables, named $$PREFIX$$.
1060 (defmacro with-ht-bind ((ht prefix) &body body)
1061 (let ((s-ht (gensym))
1062 (s-prefix (gensym))
1063 (s-var (gensym))
1064 (s-val (gensym))
1065 (s-binding (gensym))
1066 (s-vars (gensym))
1067 (s-vals (gensym))
1068 (s-bindings (gensym)))
1069 `(loop
1070 with ,s-ht = ,ht
1071 with ,s-prefix = ,prefix
1072 for ,s-var being each hash-key of ,s-ht using (hash-value ,s-val)
1073 for ,s-binding = (intern (format nil "$~A-~A$"
1074 (symbol-name ,s-prefix)
1075 (string-upcase ,s-var)))
1076 collect ,s-binding into ,s-vars
1077 collect ,s-val into ,s-vals
1078 collect `(,,s-binding ,,s-val) into ,s-bindings
1079 finally
1080 (progn
1081 (push (intern (format nil "$$~A$$" (symbol-name ,s-prefix)))
1082 ,s-vars)
1083 (push ,s-bindings ,s-vals)
1084 (return (progv ,s-vars ,s-vals
1085 ,@body))))))
1086
1087 ;;; Utility function for user code to easily verify that the
1088 ;;; wanted variables in the wanted category exist.
1089 (defun http-required-vars (&key get post cookie)
1090 (flet ((check (category-name category-var vars-list)
1091 (every #'(lambda (var)
1092 (or (member var category-var
1093 :key #'first
1094 :test #'eq)
1095 (error "Required ~A variable ~S is unbound."
1096 category-name var)))
1097 vars-list)))
1098 (declare (special $$get$$ $$post$$ $$cookie$$))
1099 (when get
1100 (check "GET" $$get$$ get))
1101 (when post
1102 (check "POST" $$post$$ post))
1103 (when cookie
1104 (check "COOKIE" $$cookie$$ cookie)))
1105 t)
1106
1107 (defun req-var (req type var &optional (default ""))
1108 (let ((ht (cond ((eq :get type)
1109 (http-request-vars-get req))
1110 ((eq :post type)
1111 (http-request-vars-post req))
1112 ((eq :cookie type)
1113 (http-request-vars-cookie req)))))
1114 (multiple-value-bind (val exists-p)
1115 (gethash (string-downcase (symbol-name var)) ht)
1116 (if exists-p
1117 val
1118 default))))
1119
1120
1121 ;;; Debugging
1122 (defun debug-feature (keyword)
1123 (and *debug* (position keyword *debug* :test #'eq)))
1124 (defun beep ()
1125 (handler-case
1126 (with-open-file (s "/dev/speaker" :direction :output)
1127 (write-string "O1L15D" s))
1128 (t ()
1129 nil)))
1130 (defun dump-vars (ht)
1131 (with-output-to-string (out)
1132 (maphash #'(lambda (k v)
1133 (format out "~A = ~S~%" k v))
1134 ht)))
1135
1136
1137 (defun html-test-page (req connection)
1138 (http-reply-send
1139 (connection-stream connection)
1140 (do-html nil
1141 (:html (:head (:title "Interactively developed test server"))
1142 (:body
1143 (:h1 "Interactively developed test server")
1144 (:p "This page, forms and server code may change anytime "
1145 "without interruption; a live SWANK connection is "
1146 "maintained from Emacs and SLIME, and the system is "
1147 "developed interactively on spare time.")
1148 (:p
1149 "Follow " (:a :href "/" "this link") " to proceed to a "
1150 "mirror of my site hosted on this test server.")
1151 (:p
1152 "The source code of this server is also available "
1153 (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
1154 :target "_blank"
1155 "here") ".")
1156 (:p
1157 "The first test application can be found "
1158 (:a :href "/chat" "here") ", and a second one to help "
1159 "accumulate name suggestions for this server "
1160 (:a :href "/names" "here") ".")
1161 (:h2 "Location")
1162 (:p "IP address/port: "
1163 (connection-address-string connection) ":"
1164 (connection-port connection))
1165 (:h2 "Test form")
1166 (:form :action (html-escape
1167 (format nil
1168 "/test?id=~64,'0X" (random
1169 #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)))
1170 :method "post"
1171 "First name: "
1172 (:/input :name "first-name"
1173 :type "text"
1174 :size "32"
1175 :maxlength "64"
1176 :value (html-escape
1177 (req-var req :post :first-name
1178 "First name")))
1179 (:/br)
1180 "Last name: "
1181 (:/input :name "last-name"
1182 :type "text"
1183 :size "32"
1184 :maxlength "64"
1185 :value (html-escape
1186 (req-var req :post :last-name
1187 "Last name")))
1188 (:/br)
1189 (do-html-loop (for i from 1 to 10
1190 for s = (format nil "~2,'0D" i)
1191 for v = (format nil "box-~2,'0D" i))
1192 "Box " s
1193 (let* ((a (req-var req :post :box[] nil))
1194 (c (if a (find v a :test #'string=) nil)))
1195 (do-html-if c
1196 (:/input :name "box[]"
1197 :type "checkbox"
1198 :value v
1199 :/checked)
1200 (:/input :name "box[]"
1201 :type "checkbox"
1202 :value v))))
1203 (:/br)
1204 (:textarea :name "message"
1205 :rows 10
1206 :cols 60
1207 (html-escape
1208 (req-var req :post :message
1209 "Message text.")))
1210 (:/br)
1211 (:/input :type "submit" :value "Post"))
1212 (:h2 "Test form 2 (multipart)")
1213 (:form :action "/test"
1214 :method "post"
1215 :enctype "multipart/form-data"
1216 (:/input :name "description"
1217 :type "text"
1218 :size "32"
1219 :maxlength "64"
1220 :value (html-escape
1221 (req-var req :post :description
1222 "Description")))
1223 (:/br)
1224 (:/input :name "file"
1225 :type "file"
1226 :size "32"
1227 :maxlength "64"
1228 :value "File to send")
1229 (:/br)
1230 (:/input :type "submit"
1231 :value "Send"))
1232 (:h2 "Browser request")
1233 (:pre
1234 (do-html-loop (for line in (http-request-raw req))
1235 (html-escape (format nil "~A~%" line))))
1236 (:p (:code
1237 (html-escape (format nil "~S~%" req))))
1238 (:h2 "Path")
1239 (html-escape (format nil "~A~%"
1240 (http-request-path req)))
1241 (do-html-when (http-request-query req)
1242 (:h2 "GET data")
1243 (:pre
1244 (html-escape (format nil "~A~%"
1245 (http-request-query req))))
1246 (:pre
1247 (html-escape (dump-vars (http-request-vars-get req)))))
1248 (do-html-when (http-request-post req)
1249 (:h2 "POST data")
1250 (:pre
1251 (html-escape (format nil "~A~%"
1252 (http-request-post req))))
1253 (:pre
1254 (html-escape (dump-vars
1255 (http-request-vars-post req)))))
1256 (do-html-when (> (hash-table-count
1257 (http-request-vars-cookie req)) 0)
1258 (:h2 "COOKIE data")
1259 (:pre
1260 (html-escape (dump-vars
1261 (http-request-vars-cookie req)))))
1262 (:h2 "Server information")
1263 (:p (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
1264 :target "_blank"
1265 "Source available here."))
1266 (:p (do-html-loop
1267 (with packages = (list-all-packages)
1268 for p in packages
1269 for s = (find-symbol "*RCSID*" p)
1270 for v = (if (and s (boundp s))
1271 (html-escape (symbol-value s)) nil)
1272 when v)
1273 (:code v) (:/br)))
1274 (:p "HTTP server uptime: " (server-uptime))
1275 (:code (html-escape (lisp-implementation-type)) " "
1276 (html-escape (lisp-implementation-version)) " ("
1277 (html-escape (first (mp::uname))) ")")
1278 (:p (:a :href "http://validator.w3.org/check?uri=referer"
1279 (:/img :src "/images/valid-xhtml.png"
1280 :alt "Valid XHTML 1.0 Transitional"
1281 :height "31"
1282 :width "88"))))))))
1283
1284 (defun http-dynamic-dispatch (req connection path)
1285 (let ((method (http-request-method req))
1286 (stream (connection-stream connection)))
1287 (cond
1288 ;; HEAD not allowed for HTTP/0.9
1289 ((and (< (http-request-protocol req) 1.0) (eq :head method))
1290 (http-error stream 400 "Bad Request"
1291 "HTTP versions <= 0.9 have no HEAD method."))
1292 ;; Allow these for dynamic handlers
1293 ((member method '(:get :head :post) :test #'eq))
1294 ;; But forbid these
1295 ((member method '(:options :delete :trace) :test #'eq)
1296 (http-error stream 405 "Method Not Allowed"
1297 "Method not allowed for dynamic handlers."))
1298 ((eq :connect method)
1299 (http-error stream 405 "NO CARRIER"))
1300 ;; Any other is unimplemented for dynamic content
1301 (t
1302 (http-error-unimplemented stream)))
1303 (unless path
1304 (http-error stream 403 "Forbidden"
1305 "You do not have the permission to access that resource.")))
1306
1307 (let ((vpath (path-virtual path)))
1308 (when (debug-feature :test)
1309 (when (string= "/test" vpath)
1310 (html-test-page req connection)))
1311 (let ((fun (vhost-handler-query (http-request-vhost req) vpath)))
1312 (when fun
1313 (funcall fun req connection)
1314 (return-from http-dynamic-dispatch t))))
1315 nil)
1316
1317 (defun http-static-dispatch (req connection path)
1318 (let ((vhost (http-request-vhost req))
1319 (stream (connection-stream connection))
1320 truepath)
1321
1322 ;; Allowed method?
1323 (let ((method (http-request-method req)))
1324 (cond
1325 ;; HEAD not allowed for HTTP/0.9
1326 ((and (< (http-request-protocol req) 1.0) (eq :head method))
1327 (http-error stream 400 "Bad Request"
1328 "HTTP versions <= 0.9 have no HEAD method."))
1329 ;; Allow these for static content
1330 ((member method '(:get :head) :test #'eq))
1331 ;; But forbid these
1332 ((member method '(:options :delete :trace :post)
1333 :test #'eq)
1334 (http-error stream 405 "Method Not Allowed"
1335 "Method not allowed for static resources."))
1336 ((eq :connect method)
1337 (http-error stream 405 "NO CARRIER"))
1338 ;; Any other is unimplemented for static content
1339 (t
1340 (http-error-unimplemented stream))))
1341 (unless path
1342 (http-error stream 403 "Forbidden"
1343 "You do not have the permission to access that resource."))
1344
1345 ;; File/directory exists?
1346 (unless (setf truepath (probe-file (path-real path)))
1347 (http-error stream 404 "Not Found"
1348 "\"~A\" could not be found."
1349 (path-virtual path)))
1350
1351 ;; If a directory, send index file if exists, but 403 otherwise.
1352 (let ((s-truepath (directory-namestring truepath)))
1353 (when (and (= 0 (length (file-namestring truepath)))
1354 (eql (position #\/ s-truepath :test #'char= :from-end t)
1355 (1- (length s-truepath))))
1356 ;; Points to a directory, make sure that "/" is part of the path
1357 ;; not to confuse browsers
1358 (let ((vpath (path-virtual path)))
1359 (unless (char= #\/ (schar vpath (1- (length vpath))))
1360 (http-redirect stream req (concatenate 'string
1361 vpath "/"))))
1362 ;; Check if we can find the index
1363 (let ((tp
1364 (probe-file
1365 (path-valid (concatenate 'string
1366 "/" (path-real path) "/"
1367 (vhost-index vhost))))))
1368 (setf truepath nil)
1369 (if tp
1370 (setf truepath tp)
1371 (if (vhost-autoindex vhost)
1372 (http-send-index stream path)
1373 (http-error stream 403 "Forbidden"
1374 "You do not have the permission to access \"~A\"."
1375 (path-virtual path)))))))
1376
1377 ;; Prepare to send file
1378 (when truepath
1379 (let* ((mime-type (mime-query
1380 (path-extension (file-namestring truepath))))
1381 (reply (make-http-reply :mime-type mime-type
1382 :charset (vhost-charset vhost)))
1383 (lastmodsecs (file-write-date truepath))
1384 (lastmod (server-time-rfc lastmodsecs)))
1385
1386 ;; If-modified/If-unmodified
1387 (let ((modified-since (http-request-modified-since req)))
1388 (when (and modified-since
1389 (<= lastmodsecs modified-since))
1390 (setf (http-reply-code reply) 304
1391 (http-reply-description reply) "Not Modified")
1392 (http-reply-flush reply stream 0)))
1393 (let ((unmodified-since (http-request-unmodified-since req)))
1394 (when (and unmodified-since
1395 (> lastmodsecs unmodified-since))
1396 (setf (http-reply-code reply) 412
1397 (http-reply-description reply) "Precondition Failed")
1398 (http-reply-flush reply stream 0)))
1399
1400 ;; Range
1401 ;; XXX 416 Requested Range Not Satisfiable
1402
1403 ;; Finally send file (except for HEAD)
1404 (http-reply-header-add reply "Last-Modified: ~A" lastmod)
1405 (with-open-file (in truepath
1406 :direction :input
1407 :element-type '(unsigned-byte 8))
1408 (http-reply-flush reply stream (file-length in))
1409 (unless (eq :head (http-request-method req))
1410 (loop
1411 with seq = *buffer*
1412 with seqsize of-type fixnum = (array-dimension seq 0)
1413 for len of-type fixnum = (read-sequence seq in)
1414 do (write-sequence seq stream :end len)
1415 while (= seqsize len))
1416 (finish-output stream)))))))
1417
1418 ;;; Actual entry point from SERVER
1419 (defun http-serve (connection)
1420 (loop
1421 with keep-alive of-type boolean = nil
1422 with keep-alive-max of-type fixnum = *request-keepalive-max*
1423 for keep-alive-count of-type fixnum from 0 below keep-alive-max
1424 do
1425 (when (debug-feature :beep)
1426 (beep))
1427 (handler-case
1428 (let* ((stream (connection-stream connection))
1429 (session (connection-session connection)))
1430
1431 (when (= 1 keep-alive-count)
1432 (setf (connection-input-timeout connection)
1433 *request-keepalive-timeout*))
1434 (multiple-value-bind (status lines)
1435 (http-request-read stream)
1436
1437 (when (eq :no-request status)
1438 (unless keep-alive
1439 (log-line "~X No request" session))
1440 (return-from http-serve nil))
1441
1442 (let* ((req (http-request-parse lines stream))
1443 (*request* req)
1444 (vhost (http-request-vhost req))
1445 (path (vhost-path vhost (http-request-path req))))
1446
1447 (unless keep-alive
1448 (setf keep-alive (http-request-keep-alive req)))
1449
1450 (when (debug-feature :log-req)
1451 (let ((*print-pretty* nil))
1452 (log-line "~X ~S" session req)))
1453
1454 (cond ((eq :success status))
1455 ((eq :request-size-exceeded status)
1456 (log-line "~X Query length exceeds ~A bytes"
1457 session *request-max-size*)
1458 (http-error stream 413 "Request Entity Too Large"
1459 "Query length exceeds ~A bytes."
1460 *request-max-size*))
1461 ((eq :request-timeout status)
1462 (unless keep-alive
1463 (when (debug-feature :log-timeouts)
1464 (log-line "~X Request Timeout" session))
1465 (http-error stream 408 "Request Timeout"))
1466 (return-from http-serve nil)))
1467
1468 ;; We could alternatively accept HTTP > 1.1 and behave
1469 ;; like for HTTP 1.1.
1470 ;; XXX Also see RFC 2616 section 3.1 and RFC 2145
1471 ;; about replying with a version Entity.
1472 (let ((protocol (http-request-protocol req)))
1473 (when (or (null protocol)
1474 (>= protocol 2.0))
1475 (log-line "~X Unsupported protocol version ~A"
1476 session protocol)
1477 (http-error stream 505 "Version Not Supported"
1478 "This server supports HTTP versions <= 2.0.")))
1479
1480 (when (and (>= (http-request-protocol req) 1.1)
1481 (null (http-request-host req)))
1482 (http-error stream 400 "Bad Request"
1483 "HTTP versions >= 1.1 require a Host header."))
1484
1485 (unless (http-dynamic-dispatch req connection path)
1486 (http-static-dispatch req connection path)))))
1487 (http-reply-signal-no-keepalive ()
1488 (loop-finish))
1489 (http-reply-signal ()
1490 t)
1491 (end-of-file ()
1492 (unless keep-alive
1493 (log-line "~X End of file" (connection-session connection)))
1494 (loop-finish)))
1495 while keep-alive)
1496 nil)
1497
1498 ;;; Second entry point from SERVER to handle errors
1499 (defun http-overflow (connection reason)
1500 (declare (ignore reason))
1501 (handler-case
1502 (let ((stream (connection-stream connection)))
1503 (http-error stream 403.9 "Too many connections"
1504 "Connection limit exceeded for your address. Try again later."))
1505 (http-reply-signal ()
1506 t))
1507 nil)
1508
1509
1510
1511 ;;; Test
1512
1513 (defmacro with-temp-file ((path filename) &body body)
1514 (let ((tmpfile (gensym)))
1515 `(let* ((,tmpfile (ext:mkstemp ,filename))
1516 (,path ,tmpfile))
1517 (unwind-protect
1518 (progn
1519 ,@body)
1520 (handler-case
1521 (delete-file ,tmpfile)
1522 (simple-error ()
1523 nil))))))
1524
1525 ;;; XXX Perhaps rename original to .old then move tmpfile to original name.
1526 ;;; Also, perhaps provide a thread designed to regularily save data, for
1527 ;;; use by such applications... of course, in the long term a DB should
1528 ;;; be used.
1529 (defun save-list (filename list)
1530 (with-temp-file (tmpfile filename)
1531 (with-open-file (s tmpfile :direction :output)
1532 (write list :stream s)
1533 (format s "~%")
1534 (finish-output s))
1535 (rename-file tmpfile filename :if-exists :supersede)))
1536
1537 (defun load-list (filename)
1538 (handler-case
1539 (with-open-file (s filename :direction :input)
1540 (read s))
1541 (file-error ()
1542 '())))
1543
1544
1545 ;;; Test "chat" board with 1024 messages backlog
1546
1547 (defparameter *chat-lines-file* "/home/mmondor/tmp/chat-lines.lisp")
1548 (defparameter *chat-lines-save-interval* 300)
1549
1550 (defvar *chat-lines-save-lock* (mp:make-lock :name 'chat-lines-save-lock))
1551 (defvar *chat-lines*
1552 (let ((lines (load-list *chat-lines-file*)))
1553 (server::make-fifo :head lines
1554 :tail (last lines)
1555 :count (length lines)
1556 :size 1024)))
1557 (defvar *chat-lines-modified* nil)
1558
1559 (defun chat-save-regularily ()
1560 (loop
1561 do
1562 (handler-case
1563 (progn
1564 (sleep *chat-lines-save-interval*)
1565 (mp:with-lock (*chat-lines-save-lock*)
1566 (when *chat-lines-modified*
1567 (save-list *chat-lines-file*
1568 (server::fifo-head *chat-lines*))
1569 (setf *chat-lines-modified* nil))))
1570 (t (e)
1571 (log-line "# ~A ~A" (type-of e) e)))))
1572
1573 (defvar *chat-lines-save-thread*
1574 (mp:process-run-function 'chat-lines-save-thread #'chat-save-regularily))
1575
1576 (defun chat-frames (req connection)
1577 (declare (ignore req))
1578 (http-reply-send
1579 (connection-stream connection)
1580 (do-html nil
1581 (:html
1582 (:head
1583 (:/link :rel "stylesheet"
1584 :href "/css/chat.css"
1585 :type "text/css")
1586 (:title "Share your comments"))
1587 (:body :style "height: 99%"
1588 (:table :width "100%" :style "height: 99%"
1589 (:tr
1590 (:td :width "100%" :height "2%"
1591 :align "center" :valign "middle"
1592 (:h2 "Share your comments")))
1593 (:tr
1594 (:td :width "100%" :height "20%"
1595 :valign "middle"
1596 (:iframe :name "prompt" :src "/chat-prompt"
1597 :frameborder "0"
1598 :scrolling "no"
1599 :width "100%"
1600 :height "100%"
1601 "Prompt")))
1602 (:tr
1603 (:td :width "100%" :height "78%" :valign "top"
1604 (:iframe :name "lines" :src "/chat-lines"
1605 :frameborder "0"
1606 :scrolling "auto"
1607 :width "100%"
1608 :height "100%"
1609 "Lines")))))))))
1610
1611 (defun chat-lines (req connection)
1612 (declare (ignore req))
1613 (let ((reply (make-http-reply)))
1614 (http-reply-nocache reply)
1615 (http-reply-content-add
1616 reply
1617 (do-html nil
1618 (:html (:head
1619 (:/link :rel "stylesheet"
1620 :href "/css/chat.css"
1621 :type "text/css")
1622 (:/meta :http-equiv "refresh" :content "15")
1623 (:title "Messages"))
1624 (:body
1625 (do-html-loop (for m in (reverse
1626 (server::fifo-head *chat-lines*))
1627 for (from when msg) = m)
1628 (:table :width "100%"
1629 (:tr (:td :width "100%" :align "left"
1630 (:b
1631 "From: " from
1632 ", At: " (server-time-rfc when)
1633 " (" (server-time-interval
1634 (- (server-time) when)) " ago)")))
1635 (:tr (:td :width "100%" :align "left"
1636 (:pre
1637 (html-escape msg))))))))))
1638 (http-reply-flush reply (connection-stream connection))))
1639
1640 (defun chat-prompt (req connection)
1641 (let ((msg (req-var req :post :message nil)))
1642 (when msg
1643 (server::fifo-append
1644 *chat-lines*
1645 (list (connection-address-string connection)
1646 (server-time)
1647 msg))
1648 (mp:with-lock (*chat-lines-save-lock*)
1649 (setf *chat-lines-modified* t))))
1650 (http-reply-send
1651 (connection-stream connection)
1652 (do-html nil
1653 (:html (:head
1654 (:/link :rel "stylesheet"
1655 :href "/css/chat.css"
1656 :type "text/css")
1657 (:title "Prompt"))
1658 (:body :style "height: 99%"
1659 (:table :width "100%" :style "height: 93%"
1660 (:tr
1661 (:td :width "100%" :align "center"
1662 (:form :action "/chat-prompt" :method "post"
1663 (:textarea :name "message"
1664 :rows 5
1665 :cols 79
1666 "")
1667 (:/br)
1668 (:/input :type "submit"
1669 :value "Post"))))))))))
1670
1671
1672 ;;; Temporary name suggestion+voting application
1673
1674 (defstruct name-entry
1675 (positive (make-hash-table :test #'equal))
1676 (negative (make-hash-table :test #'equal)))
1677
1678 (defparameter *name-entries-file* "/home/mmondor/tmp/name-entries.lisp")
1679 (defparameter *name-entries-save-interval* 300)
1680
1681 (defvar *name-entries-lock* (mp:make-lock :name 'name-entries-lock))
1682 (defvar *name-entries* (make-hash-table :test #'equalp))
1683
1684 (defun list<-name-entries ()
1685 (mp:with-lock (*name-entries-lock*)
1686 (loop
1687 for key being each hash-key of *name-entries* using (hash-value val)
1688 collect
1689 `(,key
1690 ,(loop
1691 for a being each hash-key of (name-entry-positive val)
1692 using (hash-value r)
1693 collect `(,a ,r))
1694 ,(loop
1695 for a being each hash-key of (name-entry-negative val)
1696 using (hash-value r)
1697 collect `(,a ,r))))))
1698
1699 (defun name-entries<-list (list)
1700 (mp:with-lock (*name-entries-lock*)
1701 (loop
1702 for l in list
1703 for (name positive negative) = l
1704 do
1705 (let ((ne (make-name-entry)))
1706 (mapc #'(lambda (i)
1707 (destructuring-bind (address reason) i
1708 (setf (gethash address (name-entry-positive ne))
1709 reason)))
1710 positive)
1711 (mapc #'(lambda (i)
1712 (destructuring-bind (address reason) i
1713 (setf (gethash address (name-entry-negative ne))
1714 reason)))
1715 negative)
1716 (setf (gethash name *name-entries*) ne))))
1717 t)
1718
1719 (defvar *name-entries-modified*
1720 (prog1
1721 nil
1722 (name-entries<-list (load-list *name-entries-file*))))
1723
1724 (defun name-entries-save-regularily ()
1725 (loop
1726 do
1727 (handler-case
1728 (progn
1729 (sleep *name-entries-save-interval*)
1730 (mp:with-lock (*name-entries-lock*)
1731 (when *name-entries-modified*
1732 (save-list *name-entries-file* (list<-name-entries))
1733 (setf *name-entries-modified* nil))))
1734 (t (e)
1735 (log-line "# ~A ~A" (type-of e) e)))))
1736
1737 (defvar *name-entries-save-thread*
1738 (mp:process-run-function 'name-entries-save-regularily
1739 #'name-entries-save-regularily))
1740
1741 (defun name-entries-popularity ()
1742 (mp:with-lock (*name-entries-lock*)
1743 (sort
1744 (sort
1745 (loop
1746 for key being each hash-key of *name-entries*
1747 using (hash-value val)
1748 collect `(,key ,(- (hash-table-count (name-entry-positive val))
1749 (hash-table-count (name-entry-negative val)))))
1750 #'string-lessp :key #'first)
1751 #'> :key #'second)))
1752
1753 (defun name-entry-details (name)
1754 (mp:with-lock (*name-entries-lock*)
1755 (let ((ne (gethash name *name-entries*)))
1756 (unless ne
1757 (return-from name-entry-details nil))
1758 `(,(loop
1759 for a being each hash-key of (name-entry-positive ne)
1760 using (hash-value r)
1761 collect `(,a ,r))
1762 ,(loop
1763 for a being each hash-key of (name-entry-negative ne)
1764 using (hash-value r)
1765 collect `(,a ,r))))))
1766
1767 (defun name-entry-add (name address reason)
1768 (mp:with-lock (*name-entries-lock*)
1769 (when (gethash name *name-entries*)
1770 (return-from name-entry-add nil))
1771 (let ((ne (make-name-entry)))
1772 (setf (gethash name *name-entries*) ne
1773 (gethash address (name-entry-positive ne)) reason
1774 *name-entries-modified* t)
1775 t)))
1776
1777 (defun name-entry-vote (name address reason vote)
1778 (mp:with-lock (*name-entries-lock*)
1779 (let ((ne (gethash name *name-entries*)))
1780 (unless ne
1781 (return-from name-entry-vote nil))
1782 (setf (gethash address (if (eq :positive vote)
1783 (name-entry-positive ne)
1784 (name-entry-negative ne))) reason
1785 *name-entries-modified* t)
1786 t)))
1787
1788 (defun ne-names (req connection)
1789 ;; First handle any add/vote
1790 (let ((action (req-var req :post :action))
1791 (name (req-var req :post :name))
1792 (reason (req-var req :post :reason))
1793 (vote (req-var req :post :vote)))
1794 (cond ((and (string= action "add")
1795 (> (length name) 0)
1796 (> (length reason) 0))
1797 (name-entry-add name
1798 (connection-address-string connection)
1799 reason))
1800 ((and (string= action "vote")
1801 (> (length name) 0)
1802 (> (length reason) 0)
1803 (member vote '("positive" "negative") :test #'string=))
1804 (name-entry-vote name
1805 (connection-address-string connection)
1806 reason
1807 (if (string= "positive" vote)
1808 :positive :negative)))))
1809 (http-reply-send
1810 (connection-stream connection)
1811 (do-html nil
1812 (:html (:head
1813 (:/link :rel "stylesheet"
1814 :href "/css/chat.css"
1815 :type "text/css")
1816 (:title "Suggest a name for this HTTPd"))
1817 (:body
1818 (:h1 "Suggest a name for this HTTPd")
1819 (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
1820 :target "_blank"
1821 "(source code of the server)")
1822 (:/br)(:/br)
1823 (:h2 "Guidelines and suggestions")
1824 (:p "I have named various other daemons I've written with "
1825 "an mm prefix, such as mmsmtpd, mmpop3d, mmftpd, etc. "
1826 "It'd be nice to have a more original name for this one.")
1827 (:p "This HTTP server is written in Common Lisp, which allows"
1828 " to easily perform modifications interactively, and "
1829 "to use domain-specific languages without impacting "
1830 "performance (via the use of macros). An example is "
1831 "HTML templates. "
1832 "It will become a library for application servers. "
1833 "The author also likes the humorous and science-fiction "
1834 "ideas of the universe having been written in Lisp, or "
1835 "of Lisp being used to escape some of the limitations of "
1836 "the Matrix. It is recommended to suggest one-word "
1837 "names. Other than that, he likes cats and tea...")
1838 (:p "It is not guaranteed that the most popular name will be "
1839 "chosen, but it very well may. This system only uses IP "
1840 "addresses as reference and will not prevent "
1841 "dynamic address users from voting more than once for or "
1842 "against a name. But the goal is simply for friends to "
1843 "suggest names, explain why they prefer or dislike one, "
1844 "and for the suggestions to be recorded.")
1845 (:h1 "Suggest another name")
1846 (:form :action "/names" :method "post"
1847 (:/input :type "hidden" :name "action" :value "add")
1848 (:table
1849 (:tr
1850 (:td :align "right" "Name")
1851 (:td (:/input :type "text"
1852 :name "name"
1853 :value ""
1854 :maxlength "32"
1855 :size "32"))
1856 (:td :align "right" "Reason")
1857 (:td (:/input :type "text"
1858 :name "reason"
1859 :value ""
1860 :maxlength "64"
1861 :size "32"))
1862 (:td (:/input :type "submit"
1863 :value "Submit")))))
1864 (:h1 "Current suggestions by popularity")
1865 (:p "Click on a name to view more details.")
1866 (:table :cellspacing "10"
1867 (:tr
1868 (:th :align "left" "Name") (:th "Points") (:th "Vote"))
1869 (do-html-loop (for (name points) in (name-entries-popularity)
1870 for uname = (url-encode name)
1871 for hname = (html-escape name))
1872 (:tr
1873 (:td (:a :href (concatenate 'string
1874 "/name-details?name="
1875 uname)
1876 :target "_blank"
1877 hname))
1878 (:td :align "right" points)
1879 (:td (:form :action "/names" :method "post"
1880 (:/input :type "hidden" :name "action"
1881 :value "vote")
1882 (:/input :type "hidden" :name "name"
1883 :value hname)
1884 (:select :name "vote"
1885 (:option :value "positive"
1886 "Positive")
1887 (:option :value "negative"
1888 "Negative"))
1889 (:/input :type "text"
1890 :name "reason"
1891 :value "Reason"
1892 :maxlength "64"
1893 :size "32")
1894 (:/input :type "submit"
1895 :value "Vote")))))))))))
1896
1897 (defun ne-details (req connection)
1898 (let* ((stream (connection-stream connection))
1899 (name (req-var req :get :name))
1900 (details (name-entry-details name))
1901 (title (format nil "Details for \"~A\"" (html-escape name))))
1902 (unless (and name details)
1903 (http-redirect stream req "/names"))
1904 (http-reply-send
1905 stream
1906 (do-html nil
1907 (:html (:head (:/link :rel "stylesheet"
1908 :href "/css/chat.css"
1909 :type "text/css")
1910 (:title title))
1911 (:body
1912 (:a :href "/names" "&lt;- Back")
1913 (:h1 title)
1914 (:h2 "Positive votes")
1915 (:table :cellspacing "10"
1916 (:tr (:th "IP Address") (:th :align "left" "Reason"))
1917 (do-html-loop (for (address reason) in (first details)
1918 for hreason = (html-escape reason))
1919 (:tr (:td :align "center" address) (:td hreason))))
1920 (:/br)
1921 (:h2 "Negative votes")
1922 (:table :cellspacing "10"
1923 (:tr (:th "IP Address") (:th :align "left" "Reason"))
1924 (do-html-loop (for (address reason) in (second details)
1925 for hreason = (html-escape reason))
1926 (:tr (:td :align "center" address) (:td reason))))))))))
1927
1928
1929 (defun httpd-init ()
1930 (vhost-register :name "mmondor.pulsar-zone.net"
1931 :aliases '("behemoth.xisop" "localhost")
1932 :root "/home/mmondor/tmp/htdocs/"
1933 :charset :utf-8
1934 :autoindex t
1935 :post-max-size 1048576
1936 :post-timeout 240
1937 :default t)
1938 (vhost-handler-register "localhost"
1939 '(("/chat" chat-frames)
1940 ("/chat-lines" chat-lines)
1941 ("/chat-prompt" chat-prompt)))
1942 (vhost-handler-register "localhost"
1943 '(("/names" ne-names)
1944 ("/name-details" ne-details)))
1945 (mime-load "mime-types.lisp")
1946 (server-init (make-server-config :listen-address "0.0.0.0"
1947 :listen-port 7777
1948 :serve-function 'http-serve
1949 :overflow-function 'http-overflow
1950 :buffer 65536
1951 :log-connections
1952 (debug-feature :log-connections)))
1953 t)
1954
1955 (defvar *initialized* (httpd-init))
1956
1957 (defun httpd-cleanup ()
1958 (server-cleanup)
1959 (setf *initialized* nil))