[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/server.lisp

[BKNR Commits]

Revision: 3419
Author: edi
URL: http://bknr.net/trac/changeset/3419

Fix handling of chunked requests (bug caught by Cyrus Harmon)

U   trunk/thirdparty/hunchentoot/server.lisp

Modified: trunk/thirdparty/hunchentoot/server.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/server.lisp	2008-07-09 05:55:22 UTC (rev 3418)
+++ trunk/thirdparty/hunchentoot/server.lisp	2008-07-09 07:30:39 UTC (rev 3419)
@@ -462,6 +462,15 @@
               ;; request - note that *SERVER* was bound above already
               (let ((*reply* (make-instance 'reply))
                     (*session* nil))
+                (when (server-input-chunking-p *server*)
+                  (let ((transfer-encodings (cdr (assoc* :transfer-encoding headers-in))))
+                    (when transfer-encodings
+                      (setq transfer-encodings
+                            (split "\\s*,\\*" transfer-encodings)))
+                    (when (member "chunked" transfer-encodings :test #'equalp)
+                      ;; turn chunking on before we read the request body
+                      (setf *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*)
+                            (chunked-stream-input-chunking-p *hunchentoot-stream*) t))))
                 (multiple-value-bind (remote-addr remote-port)
                     (get-peer-address-and-port socket)
                   (process-request (make-instance (server-request-class *server*)
@@ -491,66 +500,56 @@
 using START-OUTPUT.  If all goes as planned, the function returns T."
   (let (*tmp-files* *headers-sent*)
     (unwind-protect
-        (progn
-          (when (server-input-chunking-p *server*)
-            (let ((transfer-encodings (header-in :transfer-encoding request)))
-              (when transfer-encodings
-                (setq transfer-encodings
-                      (split "\\s*,\\*" transfer-encodings)))
-              (when (member "chunked" transfer-encodings :test #'equalp)
-                ;; turn chunking on before we read the request body
-                (setf *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*)
-                      (chunked-stream-input-chunking-p *hunchentoot-stream*) t))))
-          (let* ((*request* request)
-                 backtrace)
-            (multiple-value-bind (body error)
-                (catch 'handler-done
-                  (handler-bind ((error
-                                  (lambda (cond)
-                                    ;; only generate backtrace if needed
-                                    (setq backtrace
-                                          (and (or (and *show-lisp-errors-p*
-                                                        *show-lisp-backtraces-p*)
-                                                   (and *log-lisp-errors-p*
-                                                        *log-lisp-backtraces-p*))
-                                               (get-backtrace cond)))
-                                    (when *log-lisp-errors-p*
-                                      (log-message* *lisp-errors-log-level*
-                                                    "~A~:[~*~;~%~A~]"
-                                                    cond
-                                                    *log-lisp-backtraces-p*
-                                                    backtrace))
-                                    ;; if the headers were already sent
-                                    ;; the error happens within the body
-                                    ;; and we have to close the stream
-                                    (when *headers-sent*
-                                      (setq *close-hunchentoot-stream* t))
-                                    (throw 'handler-done
-                                           (values nil cond))))
-                                 (warning
-                                  (lambda (cond)
-                                    (when *log-lisp-warnings-p*
-                                      (log-message* *lisp-warnings-log-level*
-                                                    "~A~:[~*~;~%~A~]"
-                                                    cond
-                                                    *log-lisp-backtraces-p*
-                                                    backtrace)))))
-                    ;; skip dispatch if bad request
-                    (when (eql (return-code) +http-ok+)
-                      ;; now do the work
-                      (dispatch-request *server* *request* *reply*))))
-              (when error
-                (setf (return-code *reply*)
-                      +http-internal-server-error+))
-              (start-output :content (cond ((and error *show-lisp-errors-p*)
-                                            (format nil "<pre>~A~:[~*~;~%~%~A~]</pre>"
-                                                    (escape-for-html (format nil "~A" error))
-                                                    *show-lisp-backtraces-p*
-                                                    (escape-for-html (format nil "~A" backtrace))))
-                                           (error
-                                            "An error has occured.")
-                                           (t body))))
-            t))
+        (let* ((*request* request)
+               backtrace)
+          (multiple-value-bind (body error)
+              (catch 'handler-done
+                (handler-bind ((error
+                                (lambda (cond)
+                                  ;; only generate backtrace if needed
+                                  (setq backtrace
+                                        (and (or (and *show-lisp-errors-p*
+                                                      *show-lisp-backtraces-p*)
+                                                 (and *log-lisp-errors-p*
+                                                      *log-lisp-backtraces-p*))
+                                             (get-backtrace cond)))
+                                  (when *log-lisp-errors-p*
+                                    (log-message* *lisp-errors-log-level*
+                                                  "~A~:[~*~;~%~A~]"
+                                                  cond
+                                                  *log-lisp-backtraces-p*
+                                                  backtrace))
+                                  ;; if the headers were already sent
+                                  ;; the error happens within the body
+                                  ;; and we have to close the stream
+                                  (when *headers-sent*
+                                    (setq *close-hunchentoot-stream* t))
+                                  (throw 'handler-done
+                                         (values nil cond))))
+                               (warning
+                                (lambda (cond)
+                                  (when *log-lisp-warnings-p*
+                                    (log-message* *lisp-warnings-log-level*
+                                                  "~A~:[~*~;~%~A~]"
+                                                  cond
+                                                  *log-lisp-backtraces-p*
+                                                  backtrace)))))
+                  ;; skip dispatch if bad request
+                  (when (eql (return-code) +http-ok+)
+                    ;; now do the work
+                    (dispatch-request *server* *request* *reply*))))
+            (when error
+              (setf (return-code *reply*)
+                    +http-internal-server-error+))
+            (start-output :content (cond ((and error *show-lisp-errors-p*)
+                                          (format nil "<pre>~A~:[~*~;~%~%~A~]</pre>"
+                                                  (escape-for-html (format nil "~A" error))
+                                                  *show-lisp-backtraces-p*
+                                                  (escape-for-html (format nil "~A" backtrace))))
+                                         (error
+                                          "An error has occured.")
+                                         (t body))))
+          t)
       (dolist (path *tmp-files*)
         (when (and (pathnamep path) (probe-file path))
           ;; the handler may have chosen to (re)move the uploaded