Remove obsolete test-httpd.lisp, now httpd.lisp
[mmondor.git] / mmsoftware / cl / server / httpd.lisp
CommitLineData
9fd068a8 1;;;; $Id: httpd.lisp,v 1.10 2012/09/03 17:00:47 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*
9fd068a8 118 "$Id: httpd.lisp,v 1.10 2012/09/03 17:00:47 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
38e2dc27
MM
1123;;; HTTP variable access for user code
1124
c0aa17ee
MM
1125(defun req-var (req type &optional name default)
1126 "Queries the request environment REQ for a variable of TYPE :GET, :POST
1127or :COOKIE, named NAME \(may be a symbol or a string\). DEFAULT is
1128returned if no such binding exists \(which defaults to NIL\). If NAME is
1129omited, a list is returned of all variable bindings of the specified TYPE."
38e2dc27 1130 (let ((ht (cond ((eq :get type) ; CASE might not use EQ
c0aa17ee
MM
1131 (http-request-vars-get req))
1132 ((eq :post type)
1133 (http-request-vars-post req))
1134 ((eq :cookie type)
1135 (http-request-vars-cookie req))
1136 (t (error "TYPE not one of :GET :POST :COOKIE")))))
1137 (cond ((null name)
1138 (loop
1139 for key being each hash-key of ht using (hash-value val)
1140 collect `(,key ,val)))
1141 (t
1142 (multiple-value-bind (val exists-p)
1143 (gethash (string-downcase (string name)) ht)
1144 (if exists-p
1145 val
1146 default))))))
1147
1148(defmacro with-http-let (req bindings &body body)
1149 "Helper macro for REQ-VAR. Permits to perform multiple local bindings
1150with variables bound in the request environment REQ. BINDINGS consists of
1151a list of LET-like bindings with the following elements:
1152\(VAR TYPE &optional NAME DEFAULT\) where VAR is the variable to lexically
1153bind, TYPE is one of :GET, :POST or :COOKIE, NAME is the name of the
1154variable in the environment \(represented by a symbol or string\), and
1155DEFAULT is the default value to bind to VAR if NAME is not bound \(defaults
1156to NIL\). If NAME is omited, a list of all bound variables of TYPE in
1157REQ is bound to VAR."
1158 (let ((s-req (gensym)))
1159 `(let ((,s-req ,req))
1160 (let (,@(loop
1161 for binding in bindings
1162 for (var type name default) = binding
1163 collect `(,var (req-var ,s-req ,type ,name ,default))))
1164 ,@body))))
1165
1166
1167;;; Debugging
1168
1169(defvar *debug* '(:log :log-errors :test))
1170
1171(defun debug-feature (keyword)
1172 (let ((debug *debug*))
1173 (and debug (position keyword debug :test #'eq))))
1174
1175(defun beep ()
1176 (handler-case
1177 (with-open-file (s "/dev/speaker" :direction :output)
1178 (write-string "O1L15D" s))
1179 (t ()
1180 nil)))
1181
1182(defun dump-vars (ht)
1183 (with-output-to-string (out)
1184 (maphash #'(lambda (k v)
1185 (format out "~A = ~S~%" k v))
1186 ht)))
1187
1188
1189(defun html-test-page (req connection)
1190 (http-reply-send
1191 (connection-stream connection)
1192 (do-html nil
9fd068a8
MM
1193 (:html (:head (:title "Interactively developed test server")
1194 (:/link :rel "stylesheet"
1195 :href "/css/test.css"
1196 :type "text/css"))
c0aa17ee
MM
1197 (:body
1198 (:h1 "Interactively developed test server")
1199 (:p "This page, forms and server code may change anytime "
38e2dc27
MM
1200 "without interruption; a live SWANK connection can "
1201 "be maintained from Emacs and SLIME to the server, and "
1202 "the system is developed interactively as spare time "
1203 "permits. A particularity of Lisp is that it can be "
1204 "used as a scripting language interactively, with wanted "
1205 "modified clode blocks reapplied in the live image. "
9fd068a8 1206 "These code blocks may be reapplied as compiled bytecode "
38e2dc27
MM
1207 "for interpretation (or in this case, using ECL, be "
1208 "recompiled efficiently to C and linked as a dynamic "
1209 "loadable module, and reloaded immediately when typing "
1210 "C-c C-c on a code block in Emacs).")
c0aa17ee
MM
1211 (:p
1212 "Follow " (:a :href "/" "this link") " to proceed to a "
1213 "mirror of my site hosted on this test server.")
1214 (:p
1215 "The source code of this server is also available "
1216 (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
1217 :target "_blank"
1218 "here") ".")
1219 (:p
1220 "The first test application can be found "
1221 (:a :href "/chat" "here") ", and a second one to help "
1222 "accumulate name suggestions for this server "
1223 (:a :href "/names" "here") ".")
1224
c0aa17ee
MM
1225 (:h2 "Test form")
1226 (:form :action (html-escape
1227 (format nil
1228 "/test?id=~64,'0X" (random
1229 #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)))
1230 :method "post"
1231 "First name: "
1232 (:/input :name "first-name"
1233 :type "text"
1234 :size "32"
1235 :maxlength "64"
1236 :value (html-escape
1237 (req-var req :post :first-name
1238 "First name")))
1239 (:/br)
1240 "Last name: "
1241 (:/input :name "last-name"
1242 :type "text"
1243 :size "32"
1244 :maxlength "64"
1245 :value (html-escape
1246 (req-var req :post :last-name
1247 "Last name")))
1248 (:/br)
1249 (do-html-loop (for i from 1 to 10
1250 for s = (format nil "~2,'0D" i)
1251 for v = (format nil "box-~2,'0D" i))
1252 "Box " s
1253 (let* ((a (req-var req :post :box[] nil))
1254 (c (if a (find v a :test #'string=) nil)))
1255 (do-html-if c
1256 (:/input :name "box[]"
1257 :type "checkbox"
1258 :value v
1259 :/checked)
1260 (:/input :name "box[]"
1261 :type "checkbox"
1262 :value v))))
1263 (:/br)
1264 (:textarea :name "message"
1265 :rows 10
1266 :cols 60
1267 (html-escape
1268 (req-var req :post :message
1269 "Message text.")))
1270 (:/br)
38e2dc27
MM
1271 (:/input :type "submit" :value "Post message"))
1272 (:h2 "Test form 2 (multipart/form-data)")
1273 (:p (:em "This test is expected to fail for now."))
c0aa17ee
MM
1274 (:form :action "/test"
1275 :method "post"
1276 :enctype "multipart/form-data"
1277 (:/input :name "description"
1278 :type "text"
1279 :size "32"
1280 :maxlength "64"
1281 :value (html-escape
1282 (req-var req :post :description
38e2dc27 1283 "File description")))
c0aa17ee
MM
1284 (:/br)
1285 (:/input :name "file"
1286 :type "file"
1287 :size "32"
1288 :maxlength "64"
1289 :value "File to send")
1290 (:/br)
1291 (:/input :type "submit"
38e2dc27
MM
1292 :value "Upload file"))
1293
1294 (:h2 "Client information")
1295 (:h3 "Originator")
1296 (:p (connection-address-string connection) ":"
1297 (connection-port connection))
1298 (:h3 "Browser request")
c0aa17ee
MM
1299 (:pre
1300 (do-html-loop (for line in (http-request-raw req))
1301 (html-escape (format nil "~A~%" line))))
38e2dc27
MM
1302
1303 (:h2 "Request state information")
1304 (:h3 "Path and VHost")
1305 (:p (html-escape (format nil "~S on ~S"
1306 (http-request-path req)
1307 (vhost-hostname
1308 (http-request-vhost req)))))
c0aa17ee 1309 (do-html-when (http-request-query req)
38e2dc27 1310 (:h3 "GET variables")
c0aa17ee
MM
1311 (:pre
1312 (html-escape (format nil "~A~%"
1313 (http-request-query req))))
1314 (:pre
1315 (html-escape (dump-vars (http-request-vars-get req)))))
1316 (do-html-when (http-request-post req)
38e2dc27 1317 (:h3 "POST variables")
c0aa17ee
MM
1318 (:pre
1319 (html-escape (format nil "~A~%"
1320 (http-request-post req))))
1321 (:pre
1322 (html-escape (dump-vars
1323 (http-request-vars-post req)))))
1324 (do-html-when (> (hash-table-count
1325 (http-request-vars-cookie req)) 0)
38e2dc27 1326 (:h3 "COOKIE variables")
c0aa17ee
MM
1327 (:pre
1328 (html-escape (dump-vars
1329 (http-request-vars-cookie req)))))
38e2dc27 1330
c0aa17ee
MM
1331 (:h2 "Server information")
1332 (:p *server-version* " "
1333 (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
1334 :target "_blank"
1335 "(Source available here)."))
1336 (:p (do-html-loop
1337 (with packages = (list-all-packages)
1338 for p in packages
1339 for s = (find-symbol "*RCSID*" p)
1340 for v = (if (and s (boundp s))
1341 (html-escape (symbol-value s)) nil)
1342 when v)
1343 (:code v) (:/br)))
1344 (:p "HTTP server uptime: " (server-uptime))
1345 (:code (html-escape (lisp-implementation-type)) " "
1346 (html-escape (lisp-implementation-version)) " ("
1347 (html-escape (first (mp::uname))) ")")
1348 (:p (:a :href "http://validator.w3.org/check?uri=referer"
1349 (:/img :src "/images/valid-xhtml.png"
1350 :alt "Valid XHTML 1.0 Transitional"
1351 :height "31"
1352 :width "88"))))))))
1353
1354(defun http-dynamic-dispatch (req connection path)
1355 (let ((method (http-request-method req))
1356 (stream (connection-stream connection)))
1357 (cond
1358 ;; HEAD not allowed for HTTP/0.9
1359 ((and (< (http-request-protocol req) 1.0) (eq :head method))
1360 (http-error stream 400 "Bad Request"
1361 "HTTP versions <= 0.9 have no HEAD method."))
1362 ;; Allow these for dynamic handlers
1363 ((member method '(:get :head :post) :test #'eq))
1364 ;; But forbid these
1365 ((member method '(:options :delete :trace) :test #'eq)
1366 (http-error stream 405 "Method Not Allowed"
1367 "Method not allowed for dynamic handlers."))
1368 ((eq :connect method)
1369 (http-error stream 405 "NO CARRIER")) ; Easter egg
1370 ;; Any other is unimplemented for dynamic content
1371 (t
1372 (http-error-unimplemented stream)))
1373 (unless path
1374 (http-error stream 403 "Forbidden"
1375 "You do not have the permission to access that resource.")))
1376
1377 (let ((vpath (path-virtual path)))
1378 (when (debug-feature :test)
1379 (when (string= "/test" vpath)
1380 (html-test-page req connection)))
1381 (let ((fun (vhost-handler-query (http-request-vhost req) vpath)))
1382 (when fun
a837d3f7
MM
1383 (handler-case
1384 (funcall fun req connection)
e45c0358
MM
1385 ((not (or http-reply-signal http-reply-signal-nokeepalive)) (c)
1386 (log-error c)
a837d3f7
MM
1387 (http-error (connection-stream connection) 500 "Internal Error"
1388 "A temporary internal error has occurred.")))
c0aa17ee
MM
1389 (return-from http-dynamic-dispatch t))))
1390 nil)
1391
1392(defun http-static-dispatch (req connection path)
1393 (let ((vhost (http-request-vhost req))
1394 (stream (connection-stream connection))
1395 truepath)
1396
1397 ;; Allowed method?
1398 (let ((method (http-request-method req)))
1399 (cond
1400 ;; HEAD not allowed for HTTP/0.9
1401 ((and (< (http-request-protocol req) 1.0) (eq :head method))
1402 (http-error stream 400 "Bad Request"
1403 "HTTP versions <= 0.9 have no HEAD method."))
1404 ;; Allow these for static content
1405 ((member method '(:get :head) :test #'eq))
1406 ;; But forbid these
1407 ((member method '(:options :delete :trace :post)
1408 :test #'eq)
1409 (http-error stream 405 "Method Not Allowed"
1410 "Method not allowed for static resources."))
1411 ((eq :connect method)
1412 (http-error stream 405 "NO CARRIER")) ; Easter egg
1413 ;; Any other is unimplemented for static content
1414 (t
1415 (http-error-unimplemented stream))))
1416 (unless path
1417 (http-error stream 403 "Forbidden"
1418 "You do not have the permission to access that resource."))
1419
a837d3f7
MM
1420 ;; File/directory exists? 404 if not, 403 on error.
1421 (handler-case
1422 (unless (setf truepath (probe-file (path-real path)))
1423 (http-error stream 404 "Not Found"
1424 "\"~A\" could not be found."
1425 (path-virtual path)))
1426 (file-error ()
1427 (http-error stream 403 "Forbidden"
1428 "You do not have the permission to access \"~A\"."
1429 (path-virtual path))))
c0aa17ee
MM
1430
1431 ;; If a directory, send index file if exists, but 403 otherwise.
1432 (let ((s-truepath (directory-namestring truepath)))
1433 (when (and (= 0 (length (file-namestring truepath)))
1434 (eql (position #\/ s-truepath :test #'char= :from-end t)
1435 (1- (length s-truepath))))
1436 ;; Points to a directory, make sure that "/" is part of the path
1437 ;; not to confuse browsers
1438 (let ((vpath (path-virtual path)))
1439 (unless (char= #\/ (schar vpath (1- (length vpath))))
1440 (http-redirect stream req (concatenate 'string
1441 vpath "/"))))
1442 ;; Check if we can find the index
1443 (let ((tp
1444 (probe-file
1445 (path-valid (concatenate 'string
1446 "/" (path-real path) "/"
1447 (vhost-index vhost))))))
1448 (setf truepath nil)
1449 (if tp
1450 (setf truepath tp)
1451 (if (vhost-autoindex vhost)
1452 (http-send-index stream path)
1453 (http-error stream 403 "Forbidden"
1454 "You do not have the permission to access \"~A\"."
1455 (path-virtual path)))))))
1456
1457 ;; Prepare to send file
1458 (when truepath
1459 (let* ((mime-type (mime-query
1460 (path-extension (file-namestring truepath))))
1461 (reply (make-http-reply :mime-type mime-type
1462 :charset (vhost-charset vhost)))
1463 (lastmodsecs (file-write-date truepath))
1464 (lastmod (server-time-rfc lastmodsecs)))
1465
1466 ;; If-modified/If-unmodified
1467 (let ((modified-since (http-request-modified-since req)))
1468 (when (and modified-since
1469 (<= lastmodsecs modified-since))
1470 (setf (http-reply-code reply) 304
1471 (http-reply-description reply) "Not Modified")
1472 (http-reply-flush reply stream 0)))
1473 (let ((unmodified-since (http-request-unmodified-since req)))
1474 (when (and unmodified-since
1475 (> lastmodsecs unmodified-since))
1476 (setf (http-reply-code reply) 412
1477 (http-reply-description reply) "Precondition Failed")
1478 (http-reply-flush reply stream 0)))
1479
1480 ;; Range
1481 ;; XXX 416 Requested Range Not Satisfiable
1482
1483 ;; Finally send file (except for HEAD)
1484 (http-reply-header-add reply "Last-Modified: ~A" lastmod)
a837d3f7
MM
1485 (handler-case
1486 (progn
1487 (with-open-file (in truepath
1488 :direction :input
1489 :element-type '(unsigned-byte 8))
1490 (http-reply-flush reply stream (file-length in))
1491 (unless (eq :head (http-request-method req))
1492 (loop
1493 with seq = *buffer*
1494 with seqsize of-type fixnum = (array-dimension seq 0)
1495 for len of-type fixnum = (read-sequence seq in)
1496 do (write-sequence seq stream :end len)
1497 while (= seqsize len))
1498 (finish-output stream))))
1499 (file-error ()
1500 (http-error stream 403 "Forbidden"
1501 "You do not have the permission to access \"~A\"."
1502 (path-virtual path))))))))
c0aa17ee
MM
1503
1504;;; Actual entry point from SERVER
1505(defun http-serve (connection)
1506 (loop
1507 with config = *config*
1508 with max-size = (config-request-max-size config)
1509 with keep-alive of-type boolean = nil
1510 with keep-alive-max of-type fixnum = (config-request-keepalive-max
1511 config)
1512 for keep-alive-count of-type fixnum from 0 below keep-alive-max
1513 do
1514 (when (debug-feature :beep)
1515 (beep))
1516 (handler-case
1517 (let* ((stream (connection-stream connection))
1518 (session (connection-session connection)))
1519
1520 (when (= 1 keep-alive-count)
1521 (setf (connection-input-timeout connection)
1522 (config-request-keepalive-timeout config)))
1523 (multiple-value-bind (status lines)
1524 (http-request-read stream)
1525
1526 (when (eq :no-request status)
1527 (unless keep-alive
1528 (when (debug-feature :log-errors)
51017907
MM
1529 (log-line "~X ~A No request"
1530 session
1531 (connection-address-string connection))))
c0aa17ee
MM
1532 (return-from http-serve nil))
1533
1534 (let* ((req (http-request-parse lines stream))
1535 (*request* req)
1536 (vhost (http-request-vhost req))
1537 (path (vhost-path vhost (http-request-path req))))
1538
1539 (unless keep-alive
1540 (setf keep-alive (http-request-keep-alive req)))
1541
1542 (when (debug-feature :log-requests)
1543 (let ((*print-pretty* nil))
51017907
MM
1544 (log-line "~X ~A ~S"
1545 session
1546 (connection-address-string connection)
1547 req)))
c0aa17ee
MM
1548
1549 (cond ((eq :success status))
1550 ((eq :request-size-exceeded status)
1551 (when (debug-feature :log-errors)
51017907
MM
1552 (log-line "~X ~A Query length exceeds ~A bytes"
1553 session
1554 (connection-address-string connection)
1555 max-size))
c0aa17ee
MM
1556 (http-error stream 413 "Request Entity Too Large"
1557 "Query length exceeds ~A bytes."
1558 max-size))
1559 ((eq :request-timeout status)
1560 (unless keep-alive
1561 (when (debug-feature :log-errors)
51017907
MM
1562 (log-line "~X ~A Request Timeout"
1563 session
1564 (connection-address-string
1565 connection)))
c0aa17ee
MM
1566 (http-error stream 408 "Request Timeout"))
1567 (return-from http-serve nil)))
1568
1569 ;; We could alternatively accept HTTP > 1.1 and behave
1570 ;; like for HTTP 1.1.
1571 ;; XXX Also see RFC 2616 section 3.1 and RFC 2145
1572 ;; about replying with a version Entity.
1573 (let ((protocol (http-request-protocol req)))
1574 (when (or (null protocol)
1575 (>= protocol 2.0))
1576 (when (debug-feature :log-errors)
51017907
MM
1577 (log-line "~X ~A Unsupported protocol version ~A"
1578 session
1579 (connection-address-string connection)
1580 protocol))
c0aa17ee
MM
1581 (http-error stream 505 "Version Not Supported"
1582 "This server supports HTTP versions <= 2.0.")))
1583 (when (and (>= (http-request-protocol req) 1.1)
1584 (null (http-request-host req)))
1585 (http-error stream 400 "Bad Request"
1586 "HTTP versions >= 1.1 require a Host header."))
1587
1588 ;; Prioritize any existing dynamic handler over static
1589 (unless (http-dynamic-dispatch req connection path)
1590 (http-static-dispatch req connection path)))))
1591
1592 (http-reply-signal-no-keepalive ()
1593 (loop-finish))
1594 (http-reply-signal ()
1595 t)
1596 (end-of-file ()
1597 (unless keep-alive
1598 (when (debug-feature :log-errors)
51017907
MM
1599 (log-line "~X ~A End of file"
1600 (connection-session connection)
1601 (connection-address-string connection))))
c0aa17ee
MM
1602 (loop-finish)))
1603 while keep-alive)
1604 nil)
1605
1606;;; Second entry point from SERVER to handle errors
1607(defun http-overflow (connection reason)
1608 (declare (ignore reason))
1609 (handler-case
1610 (let ((stream (connection-stream connection)))
1611 (http-error stream 403.9 "Too many connections"
1612 "Connection limit exceeded for your address. Try again later."))
1613 (http-reply-signal ()
1614 t))
1615 nil)
1616
1617
1618;;; Initialization and startup
1619
1620(defvar *initialized* nil)
1621
1622;; Set a minimal default vhost
1623(vhost-register (make-vhost :hostname "localhost"
1624 :root "/tmp/htdocs/"
1625 :autoindex nil))
1626
1627#-:mm-ecl-standalone
1628(eval-when (:load-toplevel :execute)
1629 ;; Not standalone, attempt to load config file in current path
4bcf8ca1
MM
1630 (handler-case
1631 (load "httpd-config.lisp")
1632 (error (e)
1633 (format *error-output* "~%Error loading configuration file~%~A~%"
1634 e))))
c0aa17ee
MM
1635
1636(defun httpd-init ()
1637 (check-type *config* httpd-config)
f1f7c601
MM
1638 (let* ((config *config*)
1639 (server-config (config-server-config config)))
c0aa17ee
MM
1640 (check-type server-config server-config)
1641 (setf *debug* (config-debug config)
1642 (server::config-serve-function server-config) #'http-serve
1643 (server::config-overflow-function server-config) #'http-overflow
1644 (server::config-buffer server-config) 65536
1645 (server::config-log-connections server-config) (debug-feature
1646 :log-connections))
1647 (server-init server-config)
1648 (setf *config* config
1649 *initialized* t))
1650 t)
1651
c0aa17ee
MM
1652(defun httpd-cleanup ()
1653 (if *initialized*
1654 (progn
1655 (server-cleanup)
1656 (setf *initialized* nil)
1657 t)
1658 nil))
1659
51017907
MM
1660
1661;;; Initialize implicitely if started in interactive mode
1662
1663#-:mm-ecl-standalone
1664(httpd-init)
1665
1666
1667;;; Standalone/daemon mode handling
1668
c0aa17ee 1669#+:mm-ecl-standalone
51017907
MM
1670(defun swank-loop ()
1671 ;; Set the default debug hook to log and exit
1672 (setf *debugger-hook* #'(lambda (condition hook)
1673 (declare (ignore hook))
1674 (server::log-error condition)
1675 (ext:exit -1)))
1676
1677 ;; Launch swank is necessary, or just loop
1678 (cond ((config-swank-create-server *config*)
1679 (push :unix *features*)
1680 (load (config-swank-loader *config*))
1681 (with-input-from-string (s
1682"(swank-loader:init :delete nil
1683 :reload nil
1684 :load-contribs nil)")
1685 (with-log-errors
1686 (eval (read s))))
1687 (with-input-from-string (s (format nil
1688"(let ((swank::*loopback-interface* ~S))
1689 (swank:create-server :dont-close t
1690 :port ~D)))"
1691 (config-swank-address *config*)
1692 (config-swank-port *config*)))
1693 (with-log-errors
1694 (eval (read s)))
1695 (ext:exit)))
1696 (t
1697 (with-log-errors
1698 (loop
1699 do
1700 (sleep 60)))
1701 (ext:exit))))
1702
c0aa17ee
MM
1703#+:mm-ecl-standalone
1704(defparameter config-file nil)
51017907 1705
c0aa17ee
MM
1706#+:mm-ecl-standalone
1707(defun standalone-main ()
1708 (let ((ext:*lisp-init-file-list* nil))
1709 (defun help (stream)
1710 (format stream "~%~A [-config <file>]~%" (first ext:*command-args*))
1711 (ext:quit 1))
1712
1713 (handler-case
1714 (ext:process-command-args
1715 :rules '(("-config" 1 (setf config-file 1) :noloadrc)
1716 ("*DEFAULT*" 0 (help *standard-output*))))
1717 (error ()
1718 (help *error-output*)))
1719
1720 (unless config-file
1721 (help *error-output*))
1722
1723 (handler-case
af8238cc
MM
1724 (let ((*load-verbose* t))
1725 (load config-file))
4bcf8ca1
MM
1726 (error (e)
1727 (format *error-output* "~%Error loading configuration file~%~A~%" e)
c0aa17ee
MM
1728 (ext:quit -1)))
1729 (httpd-init)
1730 (swank-loop)))
51017907 1731
c0aa17ee
MM
1732#+:mm-ecl-standalone
1733(standalone-main)