[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/
BKNR Commits
bknr at bknr.net
Fri Jan 21 22:31:40 UTC 2011
Revision: 4637
Author: hans
URL: http://bknr.net/trac/changeset/4637
Improve error handling. Move code around in START-OUTPUT so that
if content has been supplied, it is first converted to binary if
necessary before anything is written to the client. Move error
logging up to process-request. If START-OUTPUT fails, try logging
and sending error information back to the client.
U trunk/thirdparty/hunchentoot/acceptor.lisp
U trunk/thirdparty/hunchentoot/headers.lisp
U trunk/thirdparty/hunchentoot/request.lisp
Modified: trunk/thirdparty/hunchentoot/acceptor.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/acceptor.lisp 2011-01-21 22:13:30 UTC (rev 4636)
+++ trunk/thirdparty/hunchentoot/acceptor.lisp 2011-01-21 22:31:40 UTC (rev 4637)
@@ -437,11 +437,6 @@
handler."
(handler-bind ((error
(lambda (cond)
- (when *log-lisp-errors-p*
- (log-message *lisp-errors-log-level*
- "~A~@[~%~A~]"
- cond
- (and *log-lisp-backtraces-p* (get-backtrace))))
;; if the headers were already sent, the error
;; happened within the body and we have to close
;; the stream
Modified: trunk/thirdparty/hunchentoot/headers.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/headers.lisp 2011-01-21 22:13:30 UTC (rev 4636)
+++ trunk/thirdparty/hunchentoot/headers.lisp 2011-01-21 22:31:40 UTC (rev 4637)
@@ -70,22 +70,15 @@
(:method (key value)
(write-header-line key (princ-to-string value))))
-(defun start-output (&key (content nil content-provided-p)
- (request *request*))
+(defun start-output (&optional (content nil content-provided-p))
"Sends all headers and maybe the content body to
*HUNCHENTOOT-STREAM*. Returns immediately and does nothing if called
more than once per request. Handles the supported return codes
accordingly. Called by PROCESS-REQUEST and/or SEND-HEADERS. Returns
the stream to write to."
- ;; send headers only once
- (when *headers-sent*
- (return-from start-output))
- (setq *headers-sent* t)
- ;; Read post data to clear stream - Force binary mode to avoid OCTETS-TO-STRING overhead.
- (raw-post-data :force-binary t)
(let* ((return-code (return-code*))
(chunkedp (and (acceptor-output-chunking-p *acceptor*)
- (eq (server-protocol request) :http/1.1)
+ (eq (server-protocol *request*) :http/1.1)
;; only turn chunking on if the content
;; length is unknown at this point...
(null (or (content-length*) content-provided-p))
@@ -94,11 +87,11 @@
;; own content
(member return-code *approved-return-codes*)))
(reason-phrase (reason-phrase return-code))
- (request-method (request-method request))
+ (request-method (request-method *request*))
(head-request-p (eq request-method :head))
content-modified-p)
(multiple-value-bind (keep-alive-p keep-alive-requested-p)
- (keep-alive-p request)
+ (keep-alive-p *request*)
(when keep-alive-p
(setq keep-alive-p
;; use keep-alive if there's a way for the client to
@@ -115,7 +108,7 @@
(cond (keep-alive-p
(setf *close-hunchentoot-stream* nil)
(when (and (acceptor-read-timeout *acceptor*)
- (or (not (eq (server-protocol request) :http/1.1))
+ (or (not (eq (server-protocol *request*) :http/1.1))
keep-alive-requested-p))
;; persistent connections are implicitly assumed for
;; HTTP/1.1, but we return a 'Keep-Alive' header if the
@@ -162,20 +155,14 @@
"The server could not verify that you are authorized to access the document requested. Either you supplied the wrong credentials \(e.g., bad password), or your browser doesn't understand how to supply the credentials required.")
((#.+http-forbidden+)
(format nil "You don't have permission to access ~A on this server."
- (escape-for-html (script-name request))))
+ (escape-for-html (script-name *request*))))
((#.+http-not-found+)
(format nil "The requested URL ~A was not found on this server."
- (escape-for-html (script-name request))))
+ (escape-for-html (script-name *request*))))
((#.+http-bad-request+)
"Your browser sent a request that this server could not understand.")
(otherwise ""))
(address-string))))))
- ;; start with status line
- (let ((first-line
- (format nil "HTTP/1.1 ~D ~A" return-code reason-phrase)))
- (write-sequence (map 'list #'char-code first-line) *hunchentoot-stream*)
- (write-sequence +crlf+ *hunchentoot-stream*)
- (maybe-write-to-header-stream first-line))
(when (and (stringp content)
(not content-modified-p)
(starts-with-one-of-p (or (content-type*) "")
@@ -192,6 +179,18 @@
;; the Content-Length header properly; maybe the user specified
;; a different content length, but that will wrong anyway
(setf (header-out :content-length) (length content)))
+ ;; send headers only once
+ (when *headers-sent*
+ (return-from start-output))
+ (setq *headers-sent* t)
+ ;; Read post data to clear stream - Force binary mode to avoid OCTETS-TO-STRING overhead.
+ (raw-post-data :force-binary t)
+ ;; start with status line
+ (let ((first-line
+ (format nil "HTTP/1.1 ~D ~A" return-code reason-phrase)))
+ (write-sequence (map 'list #'char-code first-line) *hunchentoot-stream*)
+ (write-sequence +crlf+ *hunchentoot-stream*)
+ (maybe-write-to-header-stream first-line))
;; write all headers from the REPLY object
(loop for (key . value) in (headers-out*)
when value
Modified: trunk/thirdparty/hunchentoot/request.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/request.lisp 2011-01-21 22:13:30 UTC (rev 4636)
+++ trunk/thirdparty/hunchentoot/request.lisp 2011-01-21 22:31:40 UTC (rev 4637)
@@ -212,26 +212,32 @@
"Standard implementation for processing a request. You should not
change or replace this functionality unless you know what you're
doing."
- (let (*tmp-files* *headers-sent*)
+ (let (*tmp-files*
+ *headers-sent*
+ (*request* request))
(unwind-protect
- (with-mapped-conditions ()
- (let* ((*request* request))
- (multiple-value-bind (body error backtrace)
- ;; skip dispatch if bad request
- (when (eql (return-code *reply*) +http-ok+)
- (catch 'handler-done
- (handle-request *acceptor* *request*)))
- (when error
- (setf (return-code *reply*)
- +http-internal-server-error+))
- (start-output :content (cond ((and error *show-lisp-errors-p*)
- (format nil "<pre>~A~@[~%~%Backtrace:~A~]</pre>"
- (escape-for-html (format nil "~A" error))
- (when *show-lisp-backtraces-p*
- (escape-for-html (format nil "~A" backtrace)))))
- (error
- "An error has occured.")
- (t body))))))
+ (with-mapped-conditions ()
+ (labels
+ ((report-error-to-client (error &optional backtrace)
+ (setf (return-code *reply*) +http-internal-server-error+)
+ (when *log-lisp-errors-p*
+ (log-message *lisp-errors-log-level* "~A~@[~%~A~]" error backtrace))
+ (start-output (if *show-lisp-errors-p*
+ (format nil "<pre>~A</pre>" (escape-for-html (format nil "~A" error)))
+ "An error has occured") )))
+ (multiple-value-bind (body error backtrace)
+ ;; skip dispatch if bad request
+ (when (eql (return-code *reply*) +http-ok+)
+ (catch 'handler-done
+ (handle-request *acceptor* *request*)))
+ (when error
+ ;; error occured in request handler
+ (report-error-to-client error backtrace))
+ (handler-case
+ (start-output body)
+ (error (e)
+ ;; error occured while writing to the client. attempt to report.
+ (report-error-to-client e))))))
(dolist (path *tmp-files*)
(when (and (pathnamep path) (probe-file path))
;; the handler may have chosen to (re)move the uploaded
More information about the Bknr-cvs
mailing list