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