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