Author: hhubner Date: Fri Feb 15 16:22:21 2008 New Revision: 2510 Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp branches/trunk-reorg/bknr/web/src/web/template-handler.lisp branches/trunk-reorg/bknr/web/src/web/web-utils.lisp branches/trunk-reorg/projects/quickhoney/website/static/styles.css branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Log: More xhtmlgen fixes. Make error handling work again. Errors are displayed to the user unless *catch-errors-p* is true. Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp Fri Feb 15 16:22:21 2008 @@ -233,15 +233,16 @@ (redirect-uri (parse-uri (script-name)))) (redirect (website-make-path *website* "login"))) (if *catch-errors-p* - (handle handler) - (handler-bind ((error #'(lambda (e) - (with-http-response (:content-type "text/html; charset=UTF-8" - :response +http-internal-server-error+) - (with-http-body () - (website-show-error-page *website* e))) - (do-error-log-request e) - (error e)))) - (handle handler)))) + (handler-bind + ((error #'(lambda (e) + (with-http-response (:content-type "text/html; charset=UTF-8" + :response +http-internal-server-error+) + (return-from invoke-handler (prog1 + (with-http-body () + (website-show-error-page *website* e)) + (do-error-log-request e))))))) + (handle handler)) + (handle handler))) (handler-case (mapcar #'delete-file (mapcar #'cdr (request-uploaded-files))) (error (e) @@ -468,8 +469,7 @@ (defgeneric xml-object-handler-show-object (handler object)) (defmethod xml-object-handler-show-object ((handler xml-object-handler) object) - (write-to-xml object - :string-rod-fn #'cxml::utf8-string-to-rod)) + (write-to-xml object)) (defmethod handle-object ((handler xml-object-handler) object) (xml-object-handler-show-object handler object)) @@ -499,8 +499,8 @@ (defmethod handle-object ((handler blob-handler) (blob blob)) (with-http-response (:content-type (blob-mime-type blob)) (setf (content-length) (blob-size blob)) - (with-http-body (:external-format '(unsigned-byte 8)) - (blob-to-stream blob *html-stream*)))) + (let ((stream (send-headers))) + (blob-to-stream blob stream)))) (defclass import-handler (form-handler) ((require-user-flag :initform :admin) @@ -522,7 +522,6 @@ (defmethod website-show-page ((website website) fn title) (html - (:html (:head (header :title title)) @@ -535,6 +534,20 @@ (funcall fn) (session-info))))) +(defmethod website-show-error-page ((website website) error) + (if (and (website-template-handler website) + (error-template-pathname (website-template-handler website))) + (send-error-response (website-template-handler website) (princ-to-string error)) + (html + (:html + (:head + (header :title "Error processing your request")) + ((:body :class "cms") + (:h1 "Error processing your request") + (:p "While processing your request, an error occured:") + ((:div :class "error") + (:princ-safe error))))))) + (defun show-page-with-error-handlers (fn &key (response +http-ok+) title) (setf (return-code) response) (with-http-response (:content-type "text/html; charset=UTF-8" :response response) Modified: branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp Fri Feb 15 16:22:21 2008 @@ -10,5 +10,5 @@ (defmethod handle-object ((handler rss-handler) (channel bknr.rss:rss-channel)) (with-http-response (:content-type "text/xml; charset=UTF-8") - (with-http-body () - (bknr.rss:rss-channel-xml channel *html-stream*)))) + (with-output-to-string (stream) + (bknr.rss:rss-channel-xml channel stream)))) Modified: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/template-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp Fri Feb 15 16:22:21 2008 @@ -262,13 +262,16 @@ env))) (template-not-found template-pathname)))) +(defmethod error-template-pathname (handler &optional (error-type "user-error")) + (find-template-pathname handler error-type)) + (defun send-error-response (handler message &key (response-code +http-internal-server-error+)) (with-http-response (:content-type "text/html; charset=UTF-8" :response response-code) (with-output-to-string (stream) (emit-template handler stream - (get-cached-template (find-template-pathname handler "user-error") handler) + (get-cached-template (error-template-pathname handler) handler) (acons :error-message message (initial-template-environment handler)))))) Modified: branches/trunk-reorg/bknr/web/src/web/web-utils.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-utils.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/web-utils.lisp Fri Feb 15 16:22:21 2008 @@ -120,8 +120,7 @@ value)) (defun query-param-list (param-name) - (format *debug-io* "questionable: query-param-list~%") - (assoc-values param-name (request-query) :test #'string-equal)) + (assoc-values param-name (get-parameters) :test #'string-equal)) (defun request-variable (var) (gethash var *req-var-hash*)) Modified: branches/trunk-reorg/projects/quickhoney/website/static/styles.css ============================================================================== --- branches/trunk-reorg/projects/quickhoney/website/static/styles.css (original) +++ branches/trunk-reorg/projects/quickhoney/website/static/styles.css Fri Feb 15 16:22:21 2008 @@ -425,3 +425,11 @@ width: 0px; border: 0px none #FFFFFF; } + +.error { + margin: 2em; + padding: 1em; + border: 1pt solid #aa0000; + color:#f00; + font-size: 110%; +} \ No newline at end of file Modified: branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp (original) +++ branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Fri Feb 15 16:22:21 2008 @@ -142,11 +142,8 @@ (defun emit-without-quoting (str) ;; das ist fuer WPDISPLAY - (format t "emit-without-quoting does not work~%") - #+(or) - (let ((s (cxml::chained-handler *html-sink*))) - (cxml::maybe-close-tag s) - (map nil (lambda (c) (cxml::write-rune c s)) str))) + (cxml::maybe-close-tag *html-sink*) + (map nil (lambda (c) (cxml::%write-rune c *html-sink*)) str)) (defun princ-http (val) #+(or)