Better error handling and reporting
[mmondor.git] / mmsoftware / cl / server / httpd.lisp
CommitLineData
a837d3f7 1;;;; $Id: httpd.lisp,v 1.7 2012/09/03 12:17:55 mmondor Exp $
c0aa17ee
MM
2
3#|
4
5Copyright (c) 2012, Matthew Mondor
6All rights reserved.
7
8Redistribution and use in source and binary forms, with or without
9modification, are permitted provided that the following conditions
10are met:
111. Redistributions of source code must retain the above copyright
12 notice, this list of conditions and the following disclaimer.
132. 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
17THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
18IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
19OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
20IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
21INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
22BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
23USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
26THIS 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;;;; - There is a race condition related to MP:PROCESS-KILL used by the
34;;;; thread manager of ecl-mp-server.lisp.
35;;;; Try an alternative ecl-mp-server, which launches a configured number
36;;;; of fixed accept-threads, which then delegate FDs to a dynamic pool
37;;;; of threads. Use the new MP:MAILBOX API for interthread communication,
38;;;; and introduce a special message to notify an extraneous thread to exit.
39;;;; To mitigate this, we currently configure the server to not downscale
40;;;; the threads pool.
c0aa17ee
MM
41;;;; - Perhaps make the interface to HTTP-REPLY, HTTP-REPLY-SEND and
42;;;; HTTP-ERROR better so that user code doesn't always have to carry
43;;;; and care about STREAM, etc. *CONNECTION* already holds it...
44;;;; - Implement RANGE
c0aa17ee
MM
45;;;; - Perhaps support chunked streams
46;;;; - Multipart POST parsing so that files can be uploaded.
47;;;; Unfortunately, the silly standard does not make Content-Length
48;;;; obligatory, so less efficient ad-hoc line-based parsing must be used
49;;;; when it's absent.
50;;;; - Session helper code, with support for session ID cookie and
51;;;; anti-XSS GET session-tied IDs, URL generator to use these IDs,
52;;;; user session-specific variables/objects
a837d3f7 53;;;; - Possibly also generic authentication features (HTTP and form-based)
c0aa17ee
MM
54;;;; - Form generator with form-instance IDs for matching responses to
55;;;; queries
c0aa17ee
MM
56;;;; - Possibly implement simple filter types to allow the equivalent to the
57;;;; following directive for Apache+secmod:
58;;;; SecRule HTTP_User-Agent "GSLFbot" "deny,log,status:403"
59;;;; Determine if we should support these per-vhost, global or both.
60;;;; We might also want to define a hook system for configuration files
61;;;; to easily create custom filter code.
62;;;; - Perhaps make error handlers configurable. This could either be done
63;;;; using CLOS generic functions or a simpler, possibly faster dispatch
64;;;; system. Maybe also make the page indexer configurable.
a837d3f7
MM
65;;;; - Make dynamic dispatching matching more powerful such that user
66;;;; code could perform custom dispatching, i.e. all of / with path
67;;;; supplied, all of /foo/<n> with <n> supplied, etc.
68;;;; - Perhaps consider CLOS to allow user code to customize dispatching
69;;;; and error pages... but also test the performance impact.
c0aa17ee
MM
70
71
72
73(declaim (optimize (speed 3) (safety 1) (debug 3)))
74
4bcf8ca1
MM
75#+:mm-ecl-standalone
76(setf *load-verbose* nil)
77(eval-when (:compile-toplevel #-:mm-ecl-standalone :load-toplevel)
c0aa17ee
MM
78 (load "ecl-mp-server")
79 (load "html")
80 (load "character"))
81
82(defpackage :httpd
83 (:use :cl :server :html :character)
84 (:export #:httpd-config
85 #:make-httpd-config
86 #:httpd-init
87 #:vhost
88 #:make-vhost
89 #:vhost-register
90 #:vhost-unregister
91 #:vhost-handler-register
92 #:vhost-handler-list
93 #:vhost-handler-unregister
94 #:mime-register
95 #:mime-unregister
96 #:mime-query
97 #:mime-load
98 #:mime-reload
99 #:http-reply
100 #:make-http-reply
101 #:http-reply-nocache
102 #:http-reply-header-add
103 #:http-reply-content-add
104 #:http-reply-log-time
105 #:http-reply-flush
106 #:http-reply-send
107 #:http-error
108 #:http-redirect
109 #:url-decode
110 #:url-encode
111 #:req-var
22b9809f 112 #:with-http-let
c0aa17ee
MM
113 #:debug-feature))
114
115(in-package :httpd)
116
117(defparameter *rcsid*
a837d3f7 118 "$Id: httpd.lisp,v 1.7 2012/09/03 12:17:55 mmondor Exp $")
c0aa17ee
MM
119
120(defparameter *server-version*
121 (let ((parts (string-split *rcsid*
122 :separators '(#\Space #\,))))
123 (concatenate 'string
124 (svref parts 1) "/" (svref parts 3))))
125
126
127(defstruct (httpd-config (:conc-name config-))
128 (server-config nil :type (or null
129 server:server-config))
130 ;; Supported DEBUG features:
131 ;; :log-requests :log-connections :log-errors :test :beep
132 (debug '(:log :log-errors :test) :type list)
133
51017907
MM
134 ;; For the standalone-mode swank server
135 (swank-create-server t :type boolean)
136 (swank-loader "/home/foo/slime/swank-loader" :type string)
137 (swank-address "127.0.0.1" :type string)
138 (swank-port 4005 :type fixnum)
139
c0aa17ee
MM
140 (request-timeout 60 :type fixnum)
141 (request-max-size 4096 :type fixnum)
142 (request-keepalive-timeout 20 :type fixnum)
143 (request-keepalive-max 100 :type fixnum)
144 (request-log t :type boolean)) ; XXX Optional?
145
146(defvar *config* (make-httpd-config :server-config (make-server-config)))
147
148
149;;; Paths
150
151(defvar *path-max* 255)
152(defvar *path-valid-char-table*
153 (make-valid-character-table (character-intervals
154 '(#\a #\z)
155 '(#\A #\Z)
156 '(#\0 #\9)
157 #\. #\/ #\- #\_)))
158
159;;; Returns copy of PATH or NIL. Always begins with "/", with multiple
160;;; "/" collapsed into one. Makes sure that PATH only contains allowed
161;;; characters (in *PATH-VALID-CHAR-TABLE*) and is shorter than *PATH-MAX*.
162;;; Does not allow '.' at the start of PATH or after any '/'.
163(defun path-valid (path)
164 (let ((out (make-array (1+ (length path))
165 :element-type 'character
166 :fill-pointer 0)))
167 (macrolet ((add-char (c)
168 `(vector-push ,c out)))
169 (add-char #\/)
170 (if
171 (loop
172 with char-table = *path-valid-char-table*
173 with last of-type character = #\/
174 for c of-type character across path
175 do
176 (block continue
177 (when (char= #\/ last)
178 ;; Collapse multiple '/' and prohibit '.' at start
179 (if (char= #\/ c)
180 (return-from continue)
181 (when (char= #\. c)
182 (return nil))))
183 (unless (character-valid-p char-table c)
184 (return nil))
185 (add-char c)
186 (setf last c))
187 finally (return out))
188 (if (> (length out) *path-max*)
189 nil
190 out)
191 nil))))
192
193(defstruct path
194 real virtual)
195
196;;; Should always be called when processing user-supplied paths.
197;;; The application should then only trust the objects returned by
198;;; this function. Returns NIL if the path is invalid. On success,
199;;; returns a PATH object with:
200;;; REAL: System-wide absolute real fullpath, to be used to access the
201;;; file/directory in question
202;;; VIRTUAL: The virtual root based absolute fullpath, useful to report
203;;; to the user.
204;;; Note that supplied ROOT should previously have been passed through
205;;; PATH-VALID, and that both ROOT and PATH should be absolute paths.
206(defun path-valid-virtual (root path)
207 (let* ((virtual (path-valid (concatenate 'string "/" path)))
208 (real (if virtual (path-valid (concatenate 'string
209 "/" root "/" virtual))
210 nil)))
211 (if (and virtual real)
212 (make-path :real real
213 :virtual virtual)
214 nil)))
215
216(defun path-extension (path)
217 (let ((dot (position #\. path
218 :test #'char=
219 :from-end t)))
220 (if dot
221 (string-downcase (subseq path (1+ dot)))
222 nil)))
223
224
225;;; VHosts
226
227(defvar *vhost-default* nil)
228
229(defstruct vhost
230 (hostname "" :type string :read-only t)
231 (root "/" :type string)
232 (index "/index.html" :type string)
233 (charset :utf-8 :type keyword)
234 (autoindex nil :type boolean)
235 (post-max-size 1048576 :type integer)
236 (post-timeout 240 :type fixnum)
237 (%handlers (make-hash-table :test #'equal) :type hash-table :read-only t))
238
239(defvar *vhosts* (make-hash-table :test #'equal))
240(defvar *vhosts-lock* (mp:make-lock :name 'vhosts-lock))
241
242(defun vhost-register (vhost &key (aliases '()) (default nil))
243 (check-type vhost vhost)
244 (check-type aliases list)
245 (check-type default boolean)
246 (with-accessors ((name vhost-hostname)
247 (root vhost-root)
248 (index vhost-index)) vhost
249 (unless (path-valid root)
250 (error "Invalid root path \"~A\"" root))
251 (unless (path-valid index)
252 (error "Invalid index path \"~A\"" index))
253 (mp:with-lock (*vhosts-lock*)
254 (let ((vhosts *vhosts*))
255 (setf (gethash (string-downcase name) vhosts) vhost)
256 (loop
257 for alias in aliases
258 do
259 (setf (gethash (string-downcase alias) vhosts) vhost))
260 (when default
261 (setf *vhost-default* vhost)))))
262 t)
263
264(defun vhost-unregister (name)
265 (mp:with-lock (*vhosts-lock*)
266 (let ((vhosts *vhosts*))
267 (multiple-value-bind (vhost exists-p)
268 (gethash (string-downcase name) vhosts)
269 (when exists-p
270 (loop
271 for key being each hash-key of vhosts using (hash-value val)
272 when (eq val vhost) do (remhash key vhosts))))))
273 t)
274
275(defun vhost-query (name &key (default nil))
276 (mp:with-lock (*vhosts-lock*)
277 (multiple-value-bind (vhost exists-p)
278 (gethash (string-downcase name) *vhosts*)
279 (let ((vhost-default *vhost-default*))
280 (cond ((and default vhost-default (not exists-p))
281 vhost-default)
282 (exists-p
283 vhost)
284 (t
285 nil))))))
286
287;;; User-supplied paths should be passed through this function, returning
288;;; NIL or an object supplied by PATH-VALID-VIRTUAL on VHOST's ROOT and
289;;; PATH.
290(defun vhost-path (vhost path)
291 (path-valid-virtual (vhost-root vhost) path))
292
293;;; VHost dynamic handlers
294(defun vhost-handler-register (vhost-name handlers)
295 (let ((vhost (vhost-query vhost-name)))
296 (check-type vhost vhost)
297 (check-type handlers list)
298 (mp:with-lock (*vhosts-lock*)
299 (mapc #'(lambda (l)
300 (destructuring-bind (path function) l
301 (check-type path string)
302 (let ((vpath (string-downcase (path-valid path))))
303 (setf (gethash vpath (vhost-%handlers vhost))
304 function))))
305 handlers)))
306 nil)
307
308(defun vhost-handler-list (vhost-name)
309 (let* ((vhost (vhost-query vhost-name))
310 (list '()))
311 (when vhost
312 (mp:with-lock (*vhosts-lock*)
313 (maphash #'(lambda (k v)
314 (push `(,k ,v) list))
315 (vhost-%handlers vhost))))
316 (sort list #'string< :key #'first)))
317
318(defun vhost-handler-unregister (vhost-name handlers)
319 (let ((vhost (vhost-query vhost-name)))
320 (when (and vhost handlers)
321 (mp:with-lock (*vhosts-lock*)
322 (mapc #'(lambda (s)
323 (check-type s string)
324 (let ((function (gethash s (vhost-%handlers vhost))))
325 (when function
326 (remhash s (vhost-%handlers vhost)))))
327 handlers)))))
328
329(defun vhost-handler-query (vhost vpath)
330 (let ((function nil))
331 (mp:with-lock (*vhosts-lock*)
332 (let ((fun (gethash vpath (vhost-%handlers vhost))))
333 (setf function fun)))
334 function))
335
336
337;;; Mime types
338
339(defvar *mime-type-table* (make-hash-table :test #'equal))
340(defvar *mime-type-lock* (mp:make-lock :name 'mime-type-lock))
341(defvar *mime-type-file* "mime-types.lisp")
342(defvar *mime-types*)
343
344(defun mime-register (mimetype extensions)
345 (let ((type (string-downcase mimetype)))
346 (mp:with-lock (*mime-type-lock*)
347 (mapc #'(lambda (e)
348 (setf (gethash (string-downcase e) *mime-type-table*) type))
349 extensions))
350 type))
351
352(defun mime-register-list (types)
353 (mapc #'(lambda (type)
354 (destructuring-bind (mimetype extensions) type
355 (mime-register mimetype extensions)))
356 types)
357 t)
358
359(defun mime-unregister (extension)
360 (mp:with-lock (*mime-type-lock*)
361 (let ((table *mime-type-table*))
362 (multiple-value-bind (type exists-p)
363 (gethash (string-downcase extension) table)
364 (when exists-p
365 (loop
366 for key being each hash-key of table using (hash-value val)
367 when (eq val type) do (remhash key table))))))
368 t)
369
370(defun mime-query (extension &optional (default "application/octet-stream"))
371 (mp:with-lock (*mime-type-lock*)
372 (multiple-value-bind (type exists-p)
373 (gethash (string-downcase extension) *mime-type-table*)
374 (if exists-p
375 type
376 default))))
377
378(defun mime-load (file)
379 (load file)
380 (setf *mime-type-file* file)
381 (mime-register-list *mime-types*))
382
383(defun mime-reload ()
384 (load *mime-type-file*)
385 (mime-register-list *mime-types*))
386
387
388;;; HTTP reply
389
390;;; Dynamically bound to request object for us
391(defvar *request* nil)
392
393;;; Useful to elegantly longjmp back to the request reader as soon as a
394;;; request is flushed.
395(define-condition http-reply-signal
396 (simple-error)
397 ())
398
399(define-condition http-reply-signal-no-keepalive
400 (http-reply-signal)
401 ())
402
403;;; XXX Accesses dynamic variable symbols more than once
404(defstruct http-reply
405 (date (server-time-rfc) :type string)
406 (code 200 :type real)
407 (description "Ok" :type string)
408 (headers (list
409 (format nil "Server: ~A" *server-version*)
410 "Accept-Ranges: bytes")
411 :type list)
412 (content '() :type list)
413 (mime-type "text/html" :type string)
414 (charset (if *request*
415 (vhost-charset (http-request-vhost *request*))
416 :utf-8)
417 :type keyword)
418 (protocol (if *request*
419 (let ((protocol (http-request-protocol *request*)))
420 (if protocol
421 protocol
422 0.9))
423 0.9)
424 :type float)
425 (no-keepalive nil))
426
427(defun http-reply-nocache (reply)
428 (nconc (http-reply-headers reply)
429 (list
430 "Expires: Mon, 26 Jul 1997 05:00:00 GMT"
431 (format nil "Last-Modified: ~A" (http-reply-date reply))
432 "Cache-Control: no-cache, must-revalidate"
433 "Pragma: no-cache")))
434
435(defun http-reply-header-add (reply fmt &rest fmt-args)
436 (push (apply #'format nil fmt fmt-args) (http-reply-headers reply)))
437
438(defun http-reply-content-add (reply content)
439 (push content (http-reply-content reply)))
440
441(defun http-reply-log-time (&optional (ut (server-time)))
442 (let ((months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
443 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
444 (multiple-value-bind
445 (second minute hour date month year)
446 (decode-universal-time ut 0)
447 (format nil "[~2,'0D/~A/~4,'0D:~2,'0D:~2,'0D:~2,'0D -0000]"
448 date (svref months (1- month)) year
449 hour minute second))))
450
451;;; Should only be called once per HTTP-REPLY object.
452;;; If size is not provided or is zero, signal HTTP-REPLY-SIGNAL.
453(defun http-reply-flush (reply stream &optional (size nil))
454 (let* ((config *config*)
455 (request *request*)
456 (encoding (if request
457 (vhost-charset (http-request-vhost request))
458 (vhost-charset *vhost-default*)))
459 (content (if (eq :utf-8 encoding)
460 (mapcar #'utf-8-string-encode
461 (http-reply-content reply))
462 (http-reply-content reply)))
463 (content-len (if size
464 size
465 (loop
466 for s in content
467 sum (length s) into len of-type fixnum
468 finally (return len))))
469 (crlf (format nil "~C~C" #\Return #\LineFeed)))
470
471 (when request
472 (let ((connection *connection*))
473 (when (http-reply-no-keepalive reply)
474 (http-request-disable-keepalive request))
475 (macrolet ((field (f &optional (type :string))
476 `(let ((%f ,f))
477 ,(if (eq type :string)
478 `(if %f %f "-")
479 `(if (zerop %f) "-" %f)))))
480 (when (config-request-log config)
481 (log-line-nostamp "~X ~A - - ~A ~A ~S ~A ~A \"~A\" \"~A\""
482 (connection-session connection)
483 (connection-address-string connection)
484 (http-reply-log-time)
485 (vhost-hostname (http-request-vhost request))
486 (first (http-request-raw request))
487 (http-reply-code reply)
488 (field content-len :integer)
489 (field (http-request-referer request))
490 (field (http-request-agent request)))))))
491
492 (when (> (http-reply-protocol reply) 0.9)
493 (with-accessors ((headers http-reply-headers)) reply
494 (push (format nil "Date: ~A" (http-reply-date reply)) headers)
495 (push (format nil "Content-Length: ~D" content-len) headers)
496 (push (format nil "Content-Type: ~A; charset=~A"
497 (http-reply-mime-type reply)
498 (symbol-name (http-reply-charset reply)))
499 headers)
500 (if (and request
501 (http-request-keep-alive request))
502 (when (= 1.0 (http-request-protocol request))
503 (push (format nil "Keep-Alive: timeout=~D, max=~D"
504 (config-request-keepalive-timeout config)
505 (config-request-keepalive-max config))
506 headers)
507 (push "Connection: Keep-Alive" headers))
508 (push "Connection: close" headers))
509 ;; Must push last so that it gets displayed first
510 (push (format nil "HTTP/1.1 ~A ~A"
511 (http-reply-code reply)
512 (http-reply-description reply))
513 headers)
514 (write-string
515 (concatenate 'string
516 (reduce #'(lambda (a b)
517 (concatenate 'string a crlf b))
518 headers)
519 crlf crlf)
520 stream)))
521 (unless size
522 (loop
523 with rcontent = (reverse content)
524 for s in rcontent
525 do
526 (write-sequence s stream)))
527 (finish-output stream))
528 (when (or (null size) (zerop size))
a837d3f7
MM
529 (error (if (http-reply-no-keepalive reply)
530 'http-reply-signal-no-keepalive
531 'http-reply-signal)))
c0aa17ee
MM
532 t)
533
534(defun http-reply-send (stream string)
535 (http-reply-flush (make-http-reply :content (list string)) stream))
536
537(defun http-error (stream code message &optional fmt &rest fmt-args)
538 (let ((reply (make-http-reply :code code
539 :description message
540 :no-keepalive t))
541 (description (if fmt
542 (apply #'format nil fmt fmt-args)
543 nil)))
544 (http-reply-nocache reply)
545 (http-reply-content-add
546 reply
547 (let ((title (html-escape (format nil "~A - ~A" code message))))
548 (do-html nil
549 (:html (:head (:title title))
550 (:body
551 (:h1 title)
552 (do-html-when description
553 (:p (html-escape description)))
554 (:small (html-escape *server-version*)))))))
555 (http-reply-flush reply stream)))
556
557(defun http-error-unimplemented (stream)
558 (let ((reply (make-http-reply :code 501
559 :description "Method Not Implemented"
560 :no-keepalive t)))
561 (http-reply-nocache reply)
562 (http-reply-header-add reply "Allow: GET, HEAD, POST")
563 (http-reply-content-add
564 reply
565 (let ((title "501 - Method Not Implemented"))
566 (do-html nil
567 (:html (:head (:title title))
568 (:body
569 (:h1 title)
570 (:small (html-escape *server-version*)))))))
571 (http-reply-flush reply stream)))
572
573(defun http-redirect (stream req vpath)
574 (let* ((vhost (http-request-vhost req))
575 (path (vhost-path vhost vpath))
576 (reply (make-http-reply :code 301
577 :description "Moved Permanently"
578 :charset (vhost-charset vhost)))
579 (movedto (format nil "http://~A~A"
580 (http-request-host req)
581 (if path (path-virtual path) nil)))
582 (title "301 - Moved Permanently"))
583 (unless path
584 (http-error stream 403 "Forbidden"
a837d3f7 585 "You do not have the permission to access this resource."))
c0aa17ee
MM
586 (http-reply-nocache reply)
587 (http-reply-header-add reply "Location: ~A" movedto)
588 (http-reply-content-add
589 reply
590 (do-html nil
591 (:html (:head (:title title))
592 (:body
593 (:h1 title)
594 (:p
595 "The document was permanently moved to "
596 (:a :href movedto
597 movedto) ".")
598 (:small (html-escape *server-version*))))))
599 (http-reply-flush reply stream)))
600
601(defun http-index-time (&optional (ut (server-time)))
602 (let ((months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
603 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
604 (multiple-value-bind
605 (second minute hour date month year)
606 (decode-universal-time ut 0)
607 (format nil "~2,'0D-~A-~4,'0D~C~2,'0D:~2,'0D:~2,'0D"
608 date (svref months (1- month)) year #\U00A0
609 hour minute second))))
610
611(defun http-index-size (bytes)
612 (format nil "~,3F&nbsp;KB" (float (/ bytes 1024))))
613
614(defun http-send-index (stream path)
615 (let ((title (html-escape (format nil "Index of ~A" (path-virtual path))))
616 (dirs
617 (sort (remove-if-not
618 #'path-valid
619 (mapcar #'(lambda (d)
620 (concatenate 'string
621 (car (last (pathname-directory d)))
622 "/"))
623 (directory
624 (concatenate 'string
625 (path-real path) "/*/"))))
626 #'string-lessp))
627 (files
628 (sort (remove-if-not
629 #'path-valid
630 (mapcar #'file-namestring
631 (directory
632 (concatenate 'string
633 (path-real path) "/*.*"))))
634 #'string-lessp)))
635 (http-reply-send
636 stream
637 (do-html nil
638 (:html (:head (:title title))
639 (:body :style "background: #d0d0d0;"
640 (:h1 title)
641 (:/hr)
642 (:ul (:li (:a :href "../"
643 (:code "../") " (Parent directory)")))
644 (do-html-unless (or dirs files)
645 (:/hr)
646 (:h2 "Directory empty."))
647 (do-html-when dirs
648 (:/hr)
649 (:h2 "Directories")
650 (:ul
651 (do-html-loop (for i in dirs
652 for l = (html-escape i))
653 (:li (:a :href l (:code l))))))
654 (do-html-when files
655 (:/hr)
656 (:h2 "Files")
657 (:table :cellpadding "3"
658 (:tr (:th :width "70%" :align "left" (:b "Name"))
659 (:th :width "10%" :align "right" (:b "Size"))
660 (:th :width "20%" :align "center"
661 (:b "Modified&nbsp;(UTC)")))
662 (do-html-loop (for i in files
663 for c from 0
664 for color = (if (evenp c)
665 "#b0b0b0"
666 "#c0c0c0")
667 for l = (html-escape i)
668 for rpath = (concatenate 'string
669 (path-real path)
670 "/" i)
671 for lastmod = (html-escape
672 (http-index-time
673 (file-write-date rpath)))
a837d3f7
MM
674 for size = (handler-case
675 (with-open-file
676 (s rpath
677 :direction :input)
678 (file-length s))
679 (file-error ()
680 nil))
681 unless size do (incf c)
682 when size)
c0aa17ee
MM
683 (:tr :style (format nil "background: ~A;" color)
684 (:td (:a :href l (:code l)))
685 (:td :align "right" (:code (http-index-size size)))
686 (:td :align "center" (:code lastmod))))))
687 (:/hr)
688 (:small (html-escape *server-version*))))))))
689
690
691;;; HTTP request parsing
692
693;;; Decodes the URL supplied in STRING to another string, returning it.
694(defun url-decode (string)
695 (macrolet ((get-octet ()
696 `(if (= input-max input-pos)
697 (loop-finish)
698 (prog1
699 (aref input input-pos)
700 (the fixnum (incf (the fixnum input-pos))))))
701 (put-octet (o)
702 `(vector-push ,o output)))
703 (loop
704 with input = (utf-8-string-encode string)
705 with input-pos of-type fixnum = 0
706 with input-max of-type fixnum = (length input)
707 with output = (make-array (length input)
708 :element-type '(unsigned-byte 8)
709 :fill-pointer 0)
710 for o of-type (unsigned-byte 8) = (get-octet)
711 when (= 37 o) do (let ((c1 (code-char (get-octet)))
712 (c2 (code-char (get-octet))))
713 (when (and (digit-char-p c1 16)
714 (digit-char-p c2 16))
715 (put-octet (parse-integer
716 (map 'string #'identity `(,c1 ,c2))
717 :radix 16))))
718 else when (= 43 o) do (put-octet 32)
719 else do (put-octet o)
720 finally (return (utf-8-string-decode output)))))
721
722(defvar *url-safe-char-table*
723 (make-valid-character-table
724 (character-intervals '(#\A #\Z)
725 '(#\a #\z)
726 '(#\0 #\9))))
727
728;;; Encodes the supplied URL in STRING to another string, returning it.
729(defun url-encode (string)
730 (flet ((url-encode-char (c)
731 (if (character-valid-p *url-safe-char-table* c)
732 c
733 (reduce #'(lambda (a b)
734 (concatenate 'string a b))
735 (map 'list #'(lambda (o)
736 (format nil "%~2,'0X" o))
737 (utf-8-string-encode (string c)))))))
738 (with-output-to-string (out)
739 (with-input-from-string (in string)
740 (loop
741 for c = (handler-case
742 (read-char in)
743 (end-of-file ()
744 nil))
745 for toc = (if c (url-encode-char c) nil)
746 while toc
747 when (characterp toc) do (write-char toc out)
748 else do (write-string toc out))))))
749
750;;; Supplied with a hash table and a string set statement in the form
751;;; "variable=value" or "variable[]=value", add the association binding.
752;;; If the variable name terminates with "[]", it denotes that the variable
753;;; is an array, in which case multiple values may be accumulated into it.
754(defun property-set (ht str)
755 (let ((parts (string-split str :separators '(#\=) :max 2)))
756 (when (= (length parts) 2)
757 (let ((var (string-downcase (svref parts 0)))
758 (val (if (= 1 (length parts)) "" (svref parts 1)))
759 (array-p nil))
760 ;; Escape and sanity-check VAR
761 (setf var (url-decode var))
762 (when (and (> (length var) 0)
763 (every #'(lambda (c)
764 (or (alphanumericp c)
765 (member c '(#\- #\[ #\]) :test #'char=)))
766 var))
767 ;; Unescape VAL
768 (setf val (url-decode val))
769 ;; An array?
770 (let ((len (length var)))
771 (declare (type fixnum len))
772 (when (and (> len 2)
773 (char= #\] (schar var (- len 1)))
774 (char= #\[ (schar var (- len 2))))
775 (setf array-p t)))
776 (multiple-value-bind (o exists-p)
777 (gethash var ht)
778 (cond (array-p
779 ;; Array
780 (when (not exists-p)
781 (setf o (make-array 16
782 :element-type 'string
783 :adjustable t
784 :fill-pointer 0)
785 (gethash var ht) o))
786 (vector-push-extend val o 16))
787 (t
788 ;; Normal associative variable
789 (setf (gethash var ht) val)))))))))
790
791(defun http-get-parse (ht str)
792 (loop
793 with parts = (string-split str
794 :separators '(#\&)
795 :trim-parts '(#\Newline #\Return))
796 for p across parts
797 do
798 (property-set ht p)))
799
800;;; Reads the HTTP client request from STREAM, and returns two values,
801;;; a status keyword symbol and a list consisting of the collected lines.
802;;; :NO-REQUEST no request was sent (empty request)
803;;; :REQUEST-SIZE-EXCEEDED request exceeded allowed request size
804;;; :REQUEST-TIMEOUT allowed time for request to complete exceeded
805;;; :SUCCESS success
806(defun http-request-read (stream)
807 (loop
808 with config = *config*
809 with max-time of-type integer = (+ (server-time)
810 (config-request-timeout config))
811 with request-max-size of-type fixnum = (config-request-max-size config)
812 with timeout-signal = nil
813 for line = (handler-case
814 (line-read stream)
815 (sb-bsd-sockets:operation-timeout-error ()
816 (setf timeout-signal t)
817 "<TIMEOUT>"))
818 for words = (if (= nlines 0)
819 (string-split line :max 3)
820 #())
821 until timeout-signal ; Timeout signal
822 while (< chars request-max-size) ; Request size exceeded
823 while (< (server-time) max-time) ; Request timeout
824 until (string= "" line) ; End of HTTP/1.x request
825 until (and (= nlines 0) ; End of HTTP/0.x request
826 (< (length words) 3))
827 sum (length line) into chars of-type fixnum
828 count line into nlines of-type fixnum
829 collect line into lines
830 finally
831 (return
832 (values (cond
833 ((and (= nlines 0)
834 (= (length words) 0))
835 :no-request)
836 ((> chars request-max-size)
837 :request-size-exceeded)
838 ((or (>= (server-time) max-time)
839 timeout-signal)
840 :request-timeout)
841 ((and (= nlines 0)
842 (< (length words) 3))
843 (push line lines)
844 :success)
845 (t
846 :success))
847 lines))))
848
849;;; Request parsing preprocessor.
850;;; Extracts query from the first request line and coalesces continuating
851;;; header lines. Returns the request line as first value and the list
852;;; of preprocessed lines as second value.
853(defun http-request-parse-1 (lines)
854 (values (pop lines)
855 (loop
856 with list = '()
857 with last = nil
858 for line in lines
859 do
860 (cond ((and (let ((c (schar line 0)))
861 (or (char= #\Space c) (char= #\Tab c)))
862 last)
863 (setf (car last)
864 (concatenate 'string (car last) " "
865 (string-trim '(#\Space #\Tab)
866 line))))
867 (t
868 (let ((words
869 (string-split line
870 :separators '(#\:)
871 :trim-parts '(#\Space #\Tab)
872 :max 2)))
873 (when (= 2 (length words))
874 (push line list)
875 (setf last list)))))
876 finally (return list))))
877
878
879(defstruct http-request
880 (raw nil)
881 (protocol 0.9 :type (or null float))
882 (method nil)
883 (host nil)
884 (vhost *vhost-default*)
885 (path nil)
886 (query nil)
887 (post nil)
888 (vars-get (make-hash-table :test 'equal))
889 (vars-post (make-hash-table :test 'equal))
890 (vars-cookie (make-hash-table :test 'equal))
891 (agent nil)
892 (referer nil)
893 (keep-alive nil :type boolean)
894 (content-type "application/x-www-form-urlencoded")
895 (content-length -1 :type integer)
896 (modified-since nil)
897 (unmodified-since nil)
898 (range nil))
899
900(defun http-request-disable-keepalive (request)
901 (setf (http-request-keep-alive request) nil))
902
903;;; List of headers we care about and functions to fill them.
904;;; We later on fill a hash table using this list for fast lookups.
905;;; CLOS could have been used instead after interning a keyword symbol
906;;; from the header variable string, but that would probably be slower.
907;;; The performance of a large COND, or of running this list, would vary
908;;; depending on the order of received headers and number of headers we care
909;;; about.
910(defparameter *header-list*
911 `(("host"
912 ,#'(lambda (o v)
913 (let* ((pos (position #\: v :from-end t))
914 (h (if pos (subseq v 0 pos) v)))
915 (setf (http-request-host o) v
916 (http-request-vhost o) (vhost-query h :default t)))))
917 ("user-agent"
918 ,#'(lambda (o v)
919 (setf (http-request-agent o) v)))
920 ("referer"
921 ,#'(lambda (o v)
922 (setf (http-request-referer o) v)))
923 ("connection"
924 ,#'(lambda (o v)
925 (cond ((string-equal "keep-alive" v)
926 (setf (http-request-keep-alive o) t))
927 ((string-equal "close" v)
928 (setf (http-request-keep-alive o) nil)))))
929 ("content-type"
930 ,#'(lambda (o v)
931 (setf (http-request-content-type o) v)))
932 ("content-length"
933 ,#'(lambda (o v)
934 (let ((i (handler-case
935 (parse-integer v)
936 (t ()
937 -1))))
938 (setf (http-request-content-length o) i))))
939 ("if-modified-since"
940 ,#'(lambda (o v)
941 (setf (http-request-modified-since o)
942 (server-time-rfc-parse v))))
943 ("if-unmodified-since"
944 ,#'(lambda (o v)
945 (setf (http-request-unmodified-since o)
946 (server-time-rfc-parse v))))
947 ("range"
948 ,#'(lambda (o v)
949 (setf (http-request-range o) v)))
950 ("cookie"
951 ,#'(lambda (o v)
952 (property-set (http-request-vars-cookie o) v)))))
953
954(defparameter *header-table*
955 (let ((ht (make-hash-table :test 'equal)))
956 (mapc #'(lambda (l)
957 (destructuring-bind (field function) l
958 (setf (gethash field ht) function)))
959 *header-list*)
960 ht))
961
962;;; Reads and parses POST data request if any
963;;; XXX Should at least also support "multipart/form-data" enctype
964(defun http-post-parse (stream)
965 (let* ((req *request*)
966 (req-length (http-request-content-length req))
967 (req-vhost (http-request-vhost req))
968 (req-type (let* ((type (http-request-content-type req))
969 (pos (position #\; type)))
970 (if pos
971 (subseq type 0 pos)
972 type))))
973 (unless (eq (http-request-method req) :post)
974 (return-from http-post-parse))
975 (unless (string= req-type "application/x-www-form-urlencoded")
976 (http-error stream 415 "Unsupported Media Type"
977 "The POST enctype \"~A\" is unsupported." req-type))
978 (when (= -1 req-length)
979 (http-error stream 411 "Length Required"))
980 (unless (< 0 req-length (vhost-post-max-size req-vhost))
981 (http-error stream 413 "Request Entity Too Large"))
982 (let ((pd
983 (handler-case
984 (loop
985 with max-time of-type integer = (+ (server-time)
986 (vhost-post-timeout
987 req-vhost))
988 with timeout-signal = nil
989 with vector = (make-array req-length
990 :element-type 'character
991 :initial-element #\Nul)
992 sum (handler-case
993 (read-sequence vector stream
994 :start read-length)
995 (simple-error ()
996 (setf timeout-signal t)
997 0)) into read-length
998 until timeout-signal
999 while (< (server-time) max-time)
1000 while (< read-length req-length)
1001 finally
1002 (progn
1003 (when (or (>= (server-time) max-time)
1004 timeout-signal)
1005 (http-error stream 408 "Request Timeout"))
1006 (return vector)))
1007 (ext:stream-decoding-error ()
1008 (http-error stream 500 "Internal Server Error"
1009 "Character decoding error.")))))
1010 (if pd
1011 (progn
1012 (http-get-parse (http-request-vars-post req) pd)
1013 pd)
1014 nil))))
1015
1016;;; To avoid constant INTERNing, simply match method strings to keywords.
1017;;; Matching symbols using EQ afterwards is simple and as efficient as matching
1018;;; numbers.
1019(defun method-keyword (method)
1020 (let* ((methods #("GET" "POST" "HEAD" "PUT"
1021 "DELETE" "TRACE" "CONNECT" "OPTIONS"))
1022 (keywords #(:get :post :head :put
1023 :delete :trace :connect :options))
1024 (pos (position method methods :test #'string=)))
1025 (if pos
1026 (svref keywords pos)
1027 :unknown)))
1028
1029;;; Used to parse the HTTP version
1030(defun parse-float (string)
1031 (when (char= #\. (char string 0))
1032 (setf string (concatenate 'string "0" string)))
1033 (let ((w (string-split string :separators '(#\.) :max 2)))
1034 (if (= 2 (length w))
1035 (let ((i1 (handler-case
1036 (parse-integer (aref w 0))
1037 (t ()
1038 nil)))
1039 (i2 (handler-case
1040 (parse-integer (aref w 1))
1041 (t ()
1042 nil))))
1043 (if (and i1 i2)
1044 (float (+ i1 (/ i2 (expt 10 (length (aref w 1))))))
1045 nil))
1046 nil)))
1047
1048;;; Parse supplied HTTP version STRING, returning NIL on error or
1049;;; a floating point representing the number.
1050(defun version-parse (string)
1051 (let ((w (string-split string :separators '(#\/) :max 2)))
1052 (if (and (= 2 (length w))
1053 (string-equal "HTTP" (aref w 0)))
1054 (parse-float (aref w 1))
1055 nil)))
1056
1057;;; Actual request parsing function.
1058(defun http-request-parse (lines stream)
1059 ;; Preprocessing
1060 (multiple-value-bind (request headers)
1061 (http-request-parse-1 lines)
1062 (let ((req (make-http-request))
1063 (valid nil))
1064 (setf (http-request-raw req) lines)
1065
1066 ;; Request method/path/protocol
1067 (let* ((words (string-split request :max 4))
1068 (nwords (length words)))
1069 (cond ((< nwords 3)
1070 (setf (http-request-method req) (method-keyword
1071 (svref words 0))
1072 (http-request-path req) (if (= 2 (length words))
1073 (svref words 1)
1074 "/")
1075 valid t))
1076 ((= 3 nwords)
1077 (setf (http-request-protocol req) (version-parse
1078 (svref words 2))
1079 (http-request-method req) (method-keyword
1080 (svref words 0))
1081 (http-request-path req) (svref words 1)
1082 valid t))))
1083
1084 ;; Keep-Alive on by default for >= HTTP/1.1, headers might change it
1085 (let ((protocol (http-request-protocol req)))
1086 (when (and protocol (>= protocol 1.1))
1087 (setf (http-request-keep-alive req) t)))
1088
1089 ;; Headers
1090 (when valid
1091 (loop
1092 with header-table = *header-table*
1093 for line in headers
1094 for var = (string-trim
1095 '(#\Space)
1096 (string-downcase
1097 (subseq line 0 (position #\: line))))
1098 for val = (string-trim
1099 '(#\Space)
1100 (subseq line (1+ (position #\: line :start
1101 (length var)))))
1102 for fun = (gethash var header-table)
1103 when fun do (funcall fun req val)))
1104
1105 ;; Separate path from query variables; fill in GET variables if any.
1106 (let* ((path (http-request-path req))
1107 (pos (position #\? path :test #'char=))
1108 (epos (position #\; path :test #'char= :from-end t)))
1109 (when pos
1110 (let ((get (subseq path (1+ pos) (if epos epos (length path)))))
1111 (setf (http-request-path req) (subseq path 0 pos)
1112 (http-request-query req) get)
1113 (http-get-parse (http-request-vars-get req) get))))
1114
1115 ;; Read and parse POST data if any
1116 (let ((*request* req))
1117 (setf (http-request-post req) (http-post-parse stream)))
1118
1119 ;; Finally return request object for eventual dispatching
1120 req)))
1121
1122
1123;;; Currently used by the test code.
1124(defun req-var (req type &optional name default)
1125 "Queries the request environment REQ for a variable of TYPE :GET, :POST
1126or :COOKIE, named NAME \(may be a symbol or a string\). DEFAULT is
1127returned if no such binding exists \(which defaults to NIL\). If NAME is
1128omited, a list is returned of all variable bindings of the specified TYPE."
1129 (let ((ht (cond ((eq :get type)
1130 (http-request-vars-get req))
1131 ((eq :post type)
1132 (http-request-vars-post req))
1133 ((eq :cookie type)
1134 (http-request-vars-cookie req))
1135 (t (error "TYPE not one of :GET :POST :COOKIE")))))
1136 (cond ((null name)
1137 (loop
1138 for key being each hash-key of ht using (hash-value val)
1139 collect `(,key ,val)))
1140 (t
1141 (multiple-value-bind (val exists-p)
1142 (gethash (string-downcase (string name)) ht)
1143 (if exists-p
1144 val
1145 default))))))
1146
1147(defmacro with-http-let (req bindings &body body)
1148 "Helper macro for REQ-VAR. Permits to perform multiple local bindings
1149with variables bound in the request environment REQ. BINDINGS consists of
1150a list of LET-like bindings with the following elements:
1151\(VAR TYPE &optional NAME DEFAULT\) where VAR is the variable to lexically
1152bind, TYPE is one of :GET, :POST or :COOKIE, NAME is the name of the
1153variable in the environment \(represented by a symbol or string\), and
1154DEFAULT is the default value to bind to VAR if NAME is not bound \(defaults
1155to NIL\). If NAME is omited, a list of all bound variables of TYPE in
1156REQ is bound to VAR."
1157 (let ((s-req (gensym)))
1158 `(let ((,s-req ,req))
1159 (let (,@(loop
1160 for binding in bindings
1161 for (var type name default) = binding
1162 collect `(,var (req-var ,s-req ,type ,name ,default))))
1163 ,@body))))
1164
1165
1166;;; Debugging
1167
1168(defvar *debug* '(:log :log-errors :test))
1169
1170(defun debug-feature (keyword)
1171 (let ((debug *debug*))
1172 (and debug (position keyword debug :test #'eq))))
1173
1174(defun beep ()
1175 (handler-case
1176 (with-open-file (s "/dev/speaker" :direction :output)
1177 (write-string "O1L15D" s))
1178 (t ()
1179 nil)))
1180
1181(defun dump-vars (ht)
1182 (with-output-to-string (out)
1183 (maphash #'(lambda (k v)
1184 (format out "~A = ~S~%" k v))
1185 ht)))
1186
1187
1188(defun html-test-page (req connection)
1189 (http-reply-send
1190 (connection-stream connection)
1191 (do-html nil
1192 (:html (:head (:title "Interactively developed test server"))
1193 (:body
1194 (:h1 "Interactively developed test server")
1195 (:p "This page, forms and server code may change anytime "
1196 "without interruption; a live SWANK connection is "
1197 "maintained from Emacs and SLIME, and the system is "
1198 "developed interactively on spare time.")
1199 (:p
1200 "Follow " (:a :href "/" "this link") " to proceed to a "
1201 "mirror of my site hosted on this test server.")
1202 (:p
1203 "The source code of this server is also available "
1204 (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
1205 :target "_blank"
1206 "here") ".")
1207 (:p
1208 "The first test application can be found "
1209 (:a :href "/chat" "here") ", and a second one to help "
1210 "accumulate name suggestions for this server "
1211 (:a :href "/names" "here") ".")
1212
1213 (:h2 "WITH-HTTP-LET Test")
1214 (:p (with-http-let req
1215 ((id :get :id -1)
1216 (first-name :post :last-name "first-name")
1217 (last-name :post :first-name "last-name")
1218 (foo :get :foo)
1219 (get :get))
1220 (html-escape
1221 (format nil "id=~S, name=\"~A ~A\", foo=~S, get=~S."
1222 id first-name last-name foo get))))
1223
1224 (:h2 "Location")
1225 (:p "IP address/port: "
1226 (connection-address-string connection) ":"
1227 (connection-port connection))
1228 (:h2 "Test form")
1229 (:form :action (html-escape
1230 (format nil
1231 "/test?id=~64,'0X" (random
1232 #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)))
1233 :method "post"
1234 "First name: "
1235 (:/input :name "first-name"
1236 :type "text"
1237 :size "32"
1238 :maxlength "64"
1239 :value (html-escape
1240 (req-var req :post :first-name
1241 "First name")))
1242 (:/br)
1243 "Last name: "
1244 (:/input :name "last-name"
1245 :type "text"
1246 :size "32"
1247 :maxlength "64"
1248 :value (html-escape
1249 (req-var req :post :last-name
1250 "Last name")))
1251 (:/br)
1252 (do-html-loop (for i from 1 to 10
1253 for s = (format nil "~2,'0D" i)
1254 for v = (format nil "box-~2,'0D" i))
1255 "Box " s
1256 (let* ((a (req-var req :post :box[] nil))
1257 (c (if a (find v a :test #'string=) nil)))
1258 (do-html-if c
1259 (:/input :name "box[]"
1260 :type "checkbox"
1261 :value v
1262 :/checked)
1263 (:/input :name "box[]"
1264 :type "checkbox"
1265 :value v))))
1266 (:/br)
1267 (:textarea :name "message"
1268 :rows 10
1269 :cols 60
1270 (html-escape
1271 (req-var req :post :message
1272 "Message text.")))
1273 (:/br)
1274 (:/input :type "submit" :value "Post"))
1275 (:h2 "Test form 2 (multipart)")
1276 (:form :action "/test"
1277 :method "post"
1278 :enctype "multipart/form-data"
1279 (:/input :name "description"
1280 :type "text"
1281 :size "32"
1282 :maxlength "64"
1283 :value (html-escape
1284 (req-var req :post :description
1285 "Description")))
1286 (:/br)
1287 (:/input :name "file"
1288 :type "file"
1289 :size "32"
1290 :maxlength "64"
1291 :value "File to send")
1292 (:/br)
1293 (:/input :type "submit"
1294 :value "Send"))
1295 (:h2 "Browser request")
1296 (:pre
1297 (do-html-loop (for line in (http-request-raw req))
1298 (html-escape (format nil "~A~%" line))))
1299 (:p (:code
1300 (html-escape (format nil "~S~%" req))))
1301 (:h2 "Path")
1302 (html-escape (format nil "~A~%"
1303 (http-request-path req)))
1304 (do-html-when (http-request-query req)
1305 (:h2 "GET data")
1306 (:pre
1307 (html-escape (format nil "~A~%"
1308 (http-request-query req))))
1309 (:pre
1310 (html-escape (dump-vars (http-request-vars-get req)))))
1311 (do-html-when (http-request-post req)
1312 (:h2 "POST data")
1313 (:pre
1314 (html-escape (format nil "~A~%"
1315 (http-request-post req))))
1316 (:pre
1317 (html-escape (dump-vars
1318 (http-request-vars-post req)))))
1319 (do-html-when (> (hash-table-count
1320 (http-request-vars-cookie req)) 0)
1321 (:h2 "COOKIE data")
1322 (:pre
1323 (html-escape (dump-vars
1324 (http-request-vars-cookie req)))))
1325 (:h2 "Server information")
1326 (:p *server-version* " "
1327 (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
1328 :target "_blank"
1329 "(Source available here)."))
1330 (:p (do-html-loop
1331 (with packages = (list-all-packages)
1332 for p in packages
1333 for s = (find-symbol "*RCSID*" p)
1334 for v = (if (and s (boundp s))
1335 (html-escape (symbol-value s)) nil)
1336 when v)
1337 (:code v) (:/br)))
1338 (:p "HTTP server uptime: " (server-uptime))
1339 (:code (html-escape (lisp-implementation-type)) " "
1340 (html-escape (lisp-implementation-version)) " ("
1341 (html-escape (first (mp::uname))) ")")
1342 (:p (:a :href "http://validator.w3.org/check?uri=referer"
1343 (:/img :src "/images/valid-xhtml.png"
1344 :alt "Valid XHTML 1.0 Transitional"
1345 :height "31"
1346 :width "88"))))))))
1347
1348(defun http-dynamic-dispatch (req connection path)
1349 (let ((method (http-request-method req))
1350 (stream (connection-stream connection)))
1351 (cond
1352 ;; HEAD not allowed for HTTP/0.9
1353 ((and (< (http-request-protocol req) 1.0) (eq :head method))
1354 (http-error stream 400 "Bad Request"
1355 "HTTP versions <= 0.9 have no HEAD method."))
1356 ;; Allow these for dynamic handlers
1357 ((member method '(:get :head :post) :test #'eq))
1358 ;; But forbid these
1359 ((member method '(:options :delete :trace) :test #'eq)
1360 (http-error stream 405 "Method Not Allowed"
1361 "Method not allowed for dynamic handlers."))
1362 ((eq :connect method)
1363 (http-error stream 405 "NO CARRIER")) ; Easter egg
1364 ;; Any other is unimplemented for dynamic content
1365 (t
1366 (http-error-unimplemented stream)))
1367 (unless path
1368 (http-error stream 403 "Forbidden"
1369 "You do not have the permission to access that resource.")))
1370
1371 (let ((vpath (path-virtual path)))
1372 (when (debug-feature :test)
1373 (when (string= "/test" vpath)
1374 (html-test-page req connection)))
1375 (let ((fun (vhost-handler-query (http-request-vhost req) vpath)))
1376 (when fun
a837d3f7
MM
1377 (handler-case
1378 (funcall fun req connection)
1379 ((or http-reply-signal http-reply-signal-nokeepalive) (c)
1380 (error c))
1381 (t (e)
1382 (log-error e)
1383 (http-error (connection-stream connection) 500 "Internal Error"
1384 "A temporary internal error has occurred.")))
c0aa17ee
MM
1385 (return-from http-dynamic-dispatch t))))
1386 nil)
1387
1388(defun http-static-dispatch (req connection path)
1389 (let ((vhost (http-request-vhost req))
1390 (stream (connection-stream connection))
1391 truepath)
1392
1393 ;; Allowed method?
1394 (let ((method (http-request-method req)))
1395 (cond
1396 ;; HEAD not allowed for HTTP/0.9
1397 ((and (< (http-request-protocol req) 1.0) (eq :head method))
1398 (http-error stream 400 "Bad Request"
1399 "HTTP versions <= 0.9 have no HEAD method."))
1400 ;; Allow these for static content
1401 ((member method '(:get :head) :test #'eq))
1402 ;; But forbid these
1403 ((member method '(:options :delete :trace :post)
1404 :test #'eq)
1405 (http-error stream 405 "Method Not Allowed"
1406 "Method not allowed for static resources."))
1407 ((eq :connect method)
1408 (http-error stream 405 "NO CARRIER")) ; Easter egg
1409 ;; Any other is unimplemented for static content
1410 (t
1411 (http-error-unimplemented stream))))
1412 (unless path
1413 (http-error stream 403 "Forbidden"
1414 "You do not have the permission to access that resource."))
1415
a837d3f7
MM
1416 ;; File/directory exists? 404 if not, 403 on error.
1417 (handler-case
1418 (unless (setf truepath (probe-file (path-real path)))
1419 (http-error stream 404 "Not Found"
1420 "\"~A\" could not be found."
1421 (path-virtual path)))
1422 (file-error ()
1423 (http-error stream 403 "Forbidden"
1424 "You do not have the permission to access \"~A\"."
1425 (path-virtual path))))
c0aa17ee
MM
1426
1427 ;; If a directory, send index file if exists, but 403 otherwise.
1428 (let ((s-truepath (directory-namestring truepath)))
1429 (when (and (= 0 (length (file-namestring truepath)))
1430 (eql (position #\/ s-truepath :test #'char= :from-end t)
1431 (1- (length s-truepath))))
1432 ;; Points to a directory, make sure that "/" is part of the path
1433 ;; not to confuse browsers
1434 (let ((vpath (path-virtual path)))
1435 (unless (char= #\/ (schar vpath (1- (length vpath))))
1436 (http-redirect stream req (concatenate 'string
1437 vpath "/"))))
1438 ;; Check if we can find the index
1439 (let ((tp
1440 (probe-file
1441 (path-valid (concatenate 'string
1442 "/" (path-real path) "/"
1443 (vhost-index vhost))))))
1444 (setf truepath nil)
1445 (if tp
1446 (setf truepath tp)
1447 (if (vhost-autoindex vhost)
1448 (http-send-index stream path)
1449 (http-error stream 403 "Forbidden"
1450 "You do not have the permission to access \"~A\"."
1451 (path-virtual path)))))))
1452
1453 ;; Prepare to send file
1454 (when truepath
1455 (let* ((mime-type (mime-query
1456 (path-extension (file-namestring truepath))))
1457 (reply (make-http-reply :mime-type mime-type
1458 :charset (vhost-charset vhost)))
1459 (lastmodsecs (file-write-date truepath))
1460 (lastmod (server-time-rfc lastmodsecs)))
1461
1462 ;; If-modified/If-unmodified
1463 (let ((modified-since (http-request-modified-since req)))
1464 (when (and modified-since
1465 (<= lastmodsecs modified-since))
1466 (setf (http-reply-code reply) 304
1467 (http-reply-description reply) "Not Modified")
1468 (http-reply-flush reply stream 0)))
1469 (let ((unmodified-since (http-request-unmodified-since req)))
1470 (when (and unmodified-since
1471 (> lastmodsecs unmodified-since))
1472 (setf (http-reply-code reply) 412
1473 (http-reply-description reply) "Precondition Failed")
1474 (http-reply-flush reply stream 0)))
1475
1476 ;; Range
1477 ;; XXX 416 Requested Range Not Satisfiable
1478
1479 ;; Finally send file (except for HEAD)
1480 (http-reply-header-add reply "Last-Modified: ~A" lastmod)
a837d3f7
MM
1481 (handler-case
1482 (progn
1483 (with-open-file (in truepath
1484 :direction :input
1485 :element-type '(unsigned-byte 8))
1486 (http-reply-flush reply stream (file-length in))
1487 (unless (eq :head (http-request-method req))
1488 (loop
1489 with seq = *buffer*
1490 with seqsize of-type fixnum = (array-dimension seq 0)
1491 for len of-type fixnum = (read-sequence seq in)
1492 do (write-sequence seq stream :end len)
1493 while (= seqsize len))
1494 (finish-output stream))))
1495 (file-error ()
1496 (http-error stream 403 "Forbidden"
1497 "You do not have the permission to access \"~A\"."
1498 (path-virtual path))))))))
c0aa17ee
MM
1499
1500;;; Actual entry point from SERVER
1501(defun http-serve (connection)
1502 (loop
1503 with config = *config*
1504 with max-size = (config-request-max-size config)
1505 with keep-alive of-type boolean = nil
1506 with keep-alive-max of-type fixnum = (config-request-keepalive-max
1507 config)
1508 for keep-alive-count of-type fixnum from 0 below keep-alive-max
1509 do
1510 (when (debug-feature :beep)
1511 (beep))
1512 (handler-case
1513 (let* ((stream (connection-stream connection))
1514 (session (connection-session connection)))
1515
1516 (when (= 1 keep-alive-count)
1517 (setf (connection-input-timeout connection)
1518 (config-request-keepalive-timeout config)))
1519 (multiple-value-bind (status lines)
1520 (http-request-read stream)
1521
1522 (when (eq :no-request status)
1523 (unless keep-alive
1524 (when (debug-feature :log-errors)
51017907
MM
1525 (log-line "~X ~A No request"
1526 session
1527 (connection-address-string connection))))
c0aa17ee
MM
1528 (return-from http-serve nil))
1529
1530 (let* ((req (http-request-parse lines stream))
1531 (*request* req)
1532 (vhost (http-request-vhost req))
1533 (path (vhost-path vhost (http-request-path req))))
1534
1535 (unless keep-alive
1536 (setf keep-alive (http-request-keep-alive req)))
1537
1538 (when (debug-feature :log-requests)
1539 (let ((*print-pretty* nil))
51017907
MM
1540 (log-line "~X ~A ~S"
1541 session
1542 (connection-address-string connection)
1543 req)))
c0aa17ee
MM
1544
1545 (cond ((eq :success status))
1546 ((eq :request-size-exceeded status)
1547 (when (debug-feature :log-errors)
51017907
MM
1548 (log-line "~X ~A Query length exceeds ~A bytes"
1549 session
1550 (connection-address-string connection)
1551 max-size))
c0aa17ee
MM
1552 (http-error stream 413 "Request Entity Too Large"
1553 "Query length exceeds ~A bytes."
1554 max-size))
1555 ((eq :request-timeout status)
1556 (unless keep-alive
1557 (when (debug-feature :log-errors)
51017907
MM
1558 (log-line "~X ~A Request Timeout"
1559 session
1560 (connection-address-string
1561 connection)))
c0aa17ee
MM
1562 (http-error stream 408 "Request Timeout"))
1563 (return-from http-serve nil)))
1564
1565 ;; We could alternatively accept HTTP > 1.1 and behave
1566 ;; like for HTTP 1.1.
1567 ;; XXX Also see RFC 2616 section 3.1 and RFC 2145
1568 ;; about replying with a version Entity.
1569 (let ((protocol (http-request-protocol req)))
1570 (when (or (null protocol)
1571 (>= protocol 2.0))
1572 (when (debug-feature :log-errors)
51017907
MM
1573 (log-line "~X ~A Unsupported protocol version ~A"
1574 session
1575 (connection-address-string connection)
1576 protocol))
c0aa17ee
MM
1577 (http-error stream 505 "Version Not Supported"
1578 "This server supports HTTP versions <= 2.0.")))
1579 (when (and (>= (http-request-protocol req) 1.1)
1580 (null (http-request-host req)))
1581 (http-error stream 400 "Bad Request"
1582 "HTTP versions >= 1.1 require a Host header."))
1583
1584 ;; Prioritize any existing dynamic handler over static
1585 (unless (http-dynamic-dispatch req connection path)
1586 (http-static-dispatch req connection path)))))
1587
1588 (http-reply-signal-no-keepalive ()
1589 (loop-finish))
1590 (http-reply-signal ()
1591 t)
1592 (end-of-file ()
1593 (unless keep-alive
1594 (when (debug-feature :log-errors)
51017907
MM
1595 (log-line "~X ~A End of file"
1596 (connection-session connection)
1597 (connection-address-string connection))))
c0aa17ee
MM
1598 (loop-finish)))
1599 while keep-alive)
1600 nil)
1601
1602;;; Second entry point from SERVER to handle errors
1603(defun http-overflow (connection reason)
1604 (declare (ignore reason))
1605 (handler-case
1606 (let ((stream (connection-stream connection)))
1607 (http-error stream 403.9 "Too many connections"
1608 "Connection limit exceeded for your address. Try again later."))
1609 (http-reply-signal ()
1610 t))
1611 nil)
1612
1613
1614;;; Initialization and startup
1615
1616(defvar *initialized* nil)
1617
1618;; Set a minimal default vhost
1619(vhost-register (make-vhost :hostname "localhost"
1620 :root "/tmp/htdocs/"
1621 :autoindex nil))
1622
1623#-:mm-ecl-standalone
1624(eval-when (:load-toplevel :execute)
1625 ;; Not standalone, attempt to load config file in current path
4bcf8ca1
MM
1626 (handler-case
1627 (load "httpd-config.lisp")
1628 (error (e)
1629 (format *error-output* "~%Error loading configuration file~%~A~%"
1630 e))))
c0aa17ee
MM
1631
1632(defun httpd-init ()
1633 (check-type *config* httpd-config)
f1f7c601
MM
1634 (let* ((config *config*)
1635 (server-config (config-server-config config)))
c0aa17ee
MM
1636 (check-type server-config server-config)
1637 (setf *debug* (config-debug config)
1638 (server::config-serve-function server-config) #'http-serve
1639 (server::config-overflow-function server-config) #'http-overflow
1640 (server::config-buffer server-config) 65536
1641 (server::config-log-connections server-config) (debug-feature
1642 :log-connections))
1643 (server-init server-config)
1644 (setf *config* config
1645 *initialized* t))
1646 t)
1647
c0aa17ee
MM
1648(defun httpd-cleanup ()
1649 (if *initialized*
1650 (progn
1651 (server-cleanup)
1652 (setf *initialized* nil)
1653 t)
1654 nil))
1655
51017907
MM
1656
1657;;; Initialize implicitely if started in interactive mode
1658
1659#-:mm-ecl-standalone
1660(httpd-init)
1661
1662
1663;;; Standalone/daemon mode handling
1664
c0aa17ee 1665#+:mm-ecl-standalone
51017907
MM
1666(defun swank-loop ()
1667 ;; Set the default debug hook to log and exit
1668 (setf *debugger-hook* #'(lambda (condition hook)
1669 (declare (ignore hook))
1670 (server::log-error condition)
1671 (ext:exit -1)))
1672
1673 ;; Launch swank is necessary, or just loop
1674 (cond ((config-swank-create-server *config*)
1675 (push :unix *features*)
1676 (load (config-swank-loader *config*))
1677 (with-input-from-string (s
1678"(swank-loader:init :delete nil
1679 :reload nil
1680 :load-contribs nil)")
1681 (with-log-errors
1682 (eval (read s))))
1683 (with-input-from-string (s (format nil
1684"(let ((swank::*loopback-interface* ~S))
1685 (swank:create-server :dont-close t
1686 :port ~D)))"
1687 (config-swank-address *config*)
1688 (config-swank-port *config*)))
1689 (with-log-errors
1690 (eval (read s)))
1691 (ext:exit)))
1692 (t
1693 (with-log-errors
1694 (loop
1695 do
1696 (sleep 60)))
1697 (ext:exit))))
1698
c0aa17ee
MM
1699#+:mm-ecl-standalone
1700(defparameter config-file nil)
51017907 1701
c0aa17ee
MM
1702#+:mm-ecl-standalone
1703(defun standalone-main ()
1704 (let ((ext:*lisp-init-file-list* nil))
1705 (defun help (stream)
1706 (format stream "~%~A [-config <file>]~%" (first ext:*command-args*))
1707 (ext:quit 1))
1708
1709 (handler-case
1710 (ext:process-command-args
1711 :rules '(("-config" 1 (setf config-file 1) :noloadrc)
1712 ("*DEFAULT*" 0 (help *standard-output*))))
1713 (error ()
1714 (help *error-output*)))
1715
1716 (unless config-file
1717 (help *error-output*))
1718
1719 (handler-case
af8238cc
MM
1720 (let ((*load-verbose* t))
1721 (load config-file))
4bcf8ca1
MM
1722 (error (e)
1723 (format *error-output* "~%Error loading configuration file~%~A~%" e)
c0aa17ee
MM
1724 (ext:quit -1)))
1725 (httpd-init)
1726 (swank-loop)))
51017907 1727
c0aa17ee
MM
1728#+:mm-ecl-standalone
1729(standalone-main)