Author: hhubner Date: 2006-03-08 01:51:00 -0500 (Wed, 08 Mar 2006) New Revision: 1909
Modified: branches/xml-class-rework/bknr/src/web/handlers.lisp branches/xml-class-rework/bknr/src/web/templates.lisp branches/xml-class-rework/bknr/src/web/web-macros.lisp branches/xml-class-rework/bknr/src/web/web-utils.lisp Log: Improve error message generation. Now the template based error page is used all over. The website class is getting more and more messed up, though.
Modified: branches/xml-class-rework/bknr/src/web/handlers.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/handlers.lisp 2006-03-08 06:49:37 UTC (rev 1908) +++ branches/xml-class-rework/bknr/src/web/handlers.lisp 2006-03-08 06:51:00 UTC (rev 1909) @@ -47,6 +47,12 @@ :accessor website-login-logo-url) (import-spool-directory :initarg :import-spool-directory :accessor website-import-spool-directory) + (template-base-directory :initarg :template-base-directory + :reader website-template-base-directory) + (template-command-packages :initarg :template-command-packages + :reader website-template-command-packages) + (template-handler :initform nil + :reader website-template-handler) (show-page-function :initarg :show-page-function :accessor website-show-page-function) (show-error-page-function :initarg :show-error-page-function @@ -63,6 +69,8 @@ :login-logo-url "/image/bknr-logo" :site-logo-url "/image/bknr-logo" :import-spool-directory #p"/home/bknr/spool/" + :template-base-directory nil + :template-command-packages nil :show-page-function #'show-page :show-error-page-function #'show-error-page))
@@ -124,7 +132,14 @@ (mapcar #'(lambda (module-name) (or (gethash (symbol-name module-name) *website-modules*) (warn "bknr module ~A not known" module-name))) (website-modules website))))) - + (when (website-template-base-directory website) + (setf (slot-value website 'template-handler) (make-instance 'template-handler + :name "/" + :site website + :destination (website-template-base-directory website) + :command-packages (website-template-command-packages website))) + (push (website-template-handler website) + (website-handlers website))) (mapc #'(lambda (handler) (publish-handler website handler)) (website-handlers website))) @@ -209,15 +224,7 @@ (redirect-uri (request-uri req))) (redirect "/login" req)) (handler-bind ((error #'(lambda (e) - (with-bknr-page (req :title "error processing your request" - :response *response-internal-server-error*) - (if (or (admin-p *user*) - *bknr-debug*) - (html (:pre (:princ-safe e) - #+cmu - ((:font :size "-3") - (debug:backtrace 30 *html-stream*)))) - (html "error processing your request"))) + (funcall (website-show-error-page-function *website*) e) (do-error-log-request req e) (error e)))) (handle handler req)))
Modified: branches/xml-class-rework/bknr/src/web/templates.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/templates.lisp 2006-03-08 06:49:37 UTC (rev 1908) +++ branches/xml-class-rework/bknr/src/web/templates.lisp 2006-03-08 06:51:00 UTC (rev 1909) @@ -310,7 +310,7 @@ (length (page-handler-prefix handler))) :env (initial-template-environment handler req) :request req))) - ;; ... und wenn keine Fehler entdeckt wurden, rauschreiben + ;; ... und wenn keine Fehler entdeckt wurden, rausschreiben (if body (with-bknr-http-response (req :content-type "text/html; charset=UTF-8"
Modified: branches/xml-class-rework/bknr/src/web/web-macros.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/web-macros.lisp 2006-03-08 06:49:37 UTC (rev 1908) +++ branches/xml-class-rework/bknr/src/web/web-macros.lisp 2006-03-08 06:51:00 UTC (rev 1909) @@ -94,16 +94,18 @@ (session-info)))))
(defun show-error-page (error) - (html - (princ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" *html-stream*) - (princ #\Newline *html-stream*) - (:html - (:head - (header :title "Error processing your request")) - ((:body :class "cms") - (:h1 "Error processing your request") - (:p "While processing your request, an error occured:") - (:pre (:princ-safe error)))))) + (if (website-template-handler *website*) + (send-error-response (website-template-handler *website*) *req* (princ-to-string error)) + (html + (princ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" *html-stream*) + (princ #\Newline *html-stream*) + (:html + (:head + (header :title "Error processing your request")) + ((:body :class "cms") + (:h1 "Error processing your request") + (:p "While processing your request, an error occured:") + (:pre (:princ-safe error)))))))
(defun show-page-with-error-handlers (fn req &key response title (show-page (website-show-page-function *website*))
Modified: branches/xml-class-rework/bknr/src/web/web-utils.lisp =================================================================== --- branches/xml-class-rework/bknr/src/web/web-utils.lisp 2006-03-08 06:49:37 UTC (rev 1908) +++ branches/xml-class-rework/bknr/src/web/web-utils.lisp 2006-03-08 06:51:00 UTC (rev 1909) @@ -65,17 +65,30 @@ (loop for name-value in (form-urlencoded-to-query (get-request-body request)) do (push name-value (getf (request-reply-plist request) 'bknr-parsed-parameters))))
-(defun get-parameters-from-body (request) +(defun parse-request-body (request &key uploads) + (let ((content-type (header-slot-value request :content-type))) + (cond + ((null content-type) + nil) + ((scan #?r"^(?i)application/x-www-form-urlencoded" content-type) + (get-urlencoded-form-data request)) + ((and uploads (scan #?r"^(?i)multipart/form-data" content-type)) + (get-multipart-form-data request))))) + +(defgeneric get-parameters-from-body (request) + (:documentation "Generic function to read in the parameters of a +request. This is a generic function because unauthorized request +bodies must not be completely read as that is done in the request +authorization phase. In this phase, processing must be fast and may +not return errors due to exceeded upload file size limits.")) + +(defmethod get-parameters-from-body ((request http-request)) + (parse-request-body request :uploads nil)) + +(defmethod get-parameters-from-body ((request bknr-request)) (unless (getf (request-reply-plist request) 'body-parsed) (setf (getf (request-reply-plist request) 'bknr-parsed-parameters) nil) - (let ((content-type (header-slot-value request :content-type))) - (cond - ((null content-type) - nil) - ((scan #?r"^(?i)application/x-www-form-urlencoded" content-type) - (get-urlencoded-form-data request)) - ((scan #?r"^(?i)multipart/form-data" content-type) - (get-multipart-form-data request)))) + (parse-request-body request :uploads t) (setf (getf (request-reply-plist request) 'body-parsed) t)))
(defun request-uploaded-files (request)