PageRenderTime 21ms CodeModel.GetById 14ms app.highlight 5ms RepoModel.GetById 1ms app.codeStats 0ms

/src/error.lisp

http://github.com/mtravers/wuwei
Lisp | 159 lines | 94 code | 21 blank | 44 comment | 1 complexity | de26b8d76dda3a5d809f6ad8caad2e36 MD5 | raw file
  1(in-package :wu)
  2
  3;;; +=========================================================================+
  4;;; | Copyright (c) 2009, 2010  Mike Travers and CollabRx, Inc                |
  5;;; |                                                                         |
  6;;; | Released under the MIT Open Source License                              |
  7;;; |   http://www.opensource.org/licenses/mit-license.php                    |
  8;;; |                                                                         |
  9;;; | Permission is hereby granted, free of charge, to any person obtaining   |
 10;;; | a copy of this software and associated documentation files (the         |
 11;;; | "Software"), to deal in the Software without restriction, including     |
 12;;; | without limitation the rights to use, copy, modify, merge, publish,     |
 13;;; | distribute, sublicense, and/or sell copies of the Software, and to      |
 14;;; | permit persons to whom the Software is furnished to do so, subject to   |
 15;;; | the following conditions:                                               |
 16;;; |                                                                         |
 17;;; | The above copyright notice and this permission notice shall be included |
 18;;; | in all copies or substantial portions of the Software.                  |
 19;;; |                                                                         |
 20;;; | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,         |
 21;;; | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF      |
 22;;; | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  |
 23;;; | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY    |
 24;;; | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,    |
 25;;; | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE       |
 26;;; | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.                  |
 27;;; +=========================================================================+
 28
 29;;; Author:  Mike Travers and David Sobeck
 30
 31(export '(error-box render-error clear-error
 32	  with-html-error-handling
 33	  with-json-error-handling
 34	  with-html-safe-error-handling
 35	  with-ajax-error-handler
 36	  ))
 37
 38(defun system-info ()
 39  "Replace with commands to get your system version info, eg by running 'hg log -l 1' in a shell")
 40
 41(defun report-bug-button (&optional (info ""))
 42  (html
 43   ((:a :href (format nil "~a?description=~A" *bug-report-url* (uriencode-string (format nil "In ~A:~%~%~a" (system-info) info)))
 44	:target "error") "Report a bug")))
 45
 46;;; Insert an error box for use by the error handler (++ should have a clear button)
 47(defun error-box ()
 48  (html ((:div :id "error_box" :style "display:none;")))) ;invisible until replaced
 49
 50;;; This isn't called anywhere  (and should :update and set invisible rather than :replace)
 51(defun clear-error ()
 52  (render-update
 53   (:replace "error_box" (html ((:div :id "error_box"))))))
 54
 55;;; This isn't called anywhere (and should :update rather than :replace)
 56(defun render-error (msg &key stack-trace user-error?)
 57  (render-update
 58    (:replace "error_box"
 59              (html
 60                ((:div :class (if user-error? "uerror" "error") :id "error_box") ;!!! have to keep this id or later errors won't work
 61                 (:princ-safe msg)
 62		 (unless user-error?
 63		   (html
 64		    (report-bug-button stack-trace)
 65		    ((:a :onclick "toggle_visibility('error_box_stack_trace');") " Show stack ")
 66		    ((:div :id "error_box_stack_trace" :style "display:none;")  ;:class "error"
 67		     (:pre
 68		      (:princ-safe stack-trace))
 69		     ))))))))
 70
 71
 72;;; Set to T to use the error box rather than alert method.  
 73(def-session-variable *ajax-error-box?* nil)
 74
 75;;; ++ needs better name: this composes, logs, and sends it back to client
 76(defun compose-error-message (path &key error stack-trace extra-js)
 77  (let ((message (format nil "Lisp error while servicing ~a: ~A~:[~;~a~]" path error *developer-mode* stack-trace)))
 78    (log-message message)
 79    ;;; This doesn't work; the header is already generated and sent.
 80    ;(setf (request-reply-code *ajax-request*) 400)
 81    (if *multipart-request*
 82        (html
 83          (:princ (json:encode-json-to-string `((failure . true)
 84                                                ;;(success . false)
 85                                                (records ((data . ,(clean-upload-js-string message))))))))
 86	(let ((estring (princ-to-string error)))
 87	  (if *ajax-error-box?*
 88	      (render-update
 89		(:update "error_box" (:princ-safe estring))
 90		(:show "error_box"))
 91	      ;; alertbox method
 92	      (render-update
 93		(:alert (clean-js-string estring))))
 94	  (when extra-js
 95	    (render-update
 96	      (:js extra-js)))
 97	  ))))
 98
 99
100;; --> conditionalize to use html or javascript, depending on context.
101;; Scrub the string more vigorously!
102(defun html-report-error (&key error stack-trace)
103  ;; Log this?
104  (log-message (format nil "~%Unhandled exception caught by with-html-error-handling: ~a~%~a~%" error stack-trace))
105  (html
106    ((:div :class "error")
107     (:b
108      (:princ-safe (string+ "Error: " (princ-to-string error))
109                   ))
110     (if (and stack-trace *developer-mode*)
111         (html
112           (:pre
113            (:princ-safe stack-trace))
114           )
115         )
116     )
117    ))
118
119(defun create-block-for-error (&key error stack-trace)
120  (html-report-error :error error :stack-trace stack-trace)
121  (write-string (html-string
122    (html-report-error :error error))))
123
124;;; Another method: do all generation to a string; if an error occurs catch it and make a error block instead
125(defmacro with-html-safe-error-handling (&body body)
126  `(without-unwinding-restart (create-block-for-error)
127     (write-string (html-string ,@body) *html-stream*)))
128
129(defmacro with-ajax-error-handler ((name &key extra-js) &body body)
130  `(without-unwinding-restart (compose-error-message ,name :extra-js ,extra-js)
131    ,@body
132    ))
133
134(defun json-report-error (&key error stack-trace)
135  (log-message (format nil "~%Unhandled exception caught by with-html-error-handling: ~a~%~a~%" error stack-trace))
136  (html
137    (:princ (json:encode-json-to-string `((failure . true)
138					  (success . false)
139					  (message . ,(format nil "~A" error)))))))
140
141(defmacro with-json-error-handling (&body body)
142  `(without-unwinding-restart (json-report-error)
143     ,@body))
144
145;;; Note: has to be inside of with-http-response-and-body or equivalent
146;;;   unfortunately this means that errors can't cause a 404 or 500 or whatever HTTP response like they should +++ rethinking needed
147;;; If you want to close off html elements in case of an error, I think you need to add unwind-protects to  html-body-key-form
148;;;  in /misc/downloads/cl-portable-aserve-1.2.42/aserve/htmlgen/htmlgen.cl
149;;;  get-frames-list for a backtrace (but probably need a different kind of handler in that case)
150(defmacro with-html-error-handling (&body body)
151  `(without-unwinding-restart (html-report-error)
152     ,@body))
153
154(defvar *logging* t)
155(defvar *logging-stream* *standard-output*)
156
157(defun log-message (message)
158  (if *logging*
159      (format *logging-stream* "~a ~a~%" (net.aserve::universal-time-to-date (get-universal-time))  message)))