[bknr-cvs] r1909 - branches/xml-class-rework/bknr/src/web
bknr at bknr.net
bknr at bknr.net
Wed Mar 8 06:51:01 UTC 2006
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)
More information about the Bknr-cvs
mailing list