1 (uiop:define-package
#:lw2.conditions
2 (:use
#:cl
#:alexandria
#:lw2.utils
#:lw2.html-reader
)
3 (:export
#:*debug-mode
*
4 #:*error-explanation-hook
* #:error-explanation-case
6 #:condition-http-return-code
10 #:lw2-client-error
#:lw2-not-found-error
#:lw2-user-not-found-error
#:lw2-not-allowed-error
#:lw2-login-required-error
#:lw2-server-error
#:lw2-connection-error
#:lw2-unknown-error
11 #:html-output-stream-error-p
12 #:log-condition
#:log-conditions
13 #:log-and-ignore-errors
15 #:abort-response-if-unrecoverable
16 #:with-error-html-block
)
17 (:recycle
#:lw2.backend
#:lw2-viewer
))
19 (in-package #:lw2.conditions
)
21 (named-readtables:in-readtable html-reader
)
23 (defvar *debug-mode
* nil
)
24 (defvar *error-explanation-hook
*)
26 (deftype fatal-error
() `(or serious-condition usocket
:ns-condition usocket
:socket-condition
))
28 (defgeneric condition-http-return-code
(c)
29 (:method
((c condition
)) 500))
31 (defmethod error-to-html :around
((condition condition
))
32 <div class
="gw-error">
35 (when (boundp '*error-explanation-hook
*)
36 (funcall *error-explanation-hook
* condition
))
40 (with-output-to-string (outstream)
41 (sb-debug:print-backtrace
:stream outstream
:from
:interrupted-frame
:print-frame-source t
))
45 (defmethod error-to-html ((condition condition
))
46 <code
><pre
>(princ-to-string condition
)</pre
></code
>)
48 (define-condition lw2-error
(error) ((http-return-code :allocation
:class
:reader condition-http-return-code
:initform
503)))
50 (defmethod error-to-html ((condition lw2-error
))
51 <p
>(princ-to-string condition
)</p
>)
53 (define-condition lw2-client-error
(lw2-error) ((http-return-code :allocation
:class
:initform
400)))
55 (define-condition csrf-check-failed
(lw2-error) ()
56 (:report
"CSRF check failed."))
58 (defmethod error-to-html ((condition csrf-check-failed
))
59 <p
>CSRF check failed.
</p
>
60 <p
>You may need to adjust your browser settings to allow cookies.
</p
>)
62 (define-condition lw2-not-found-error
(lw2-client-error) ((http-return-code :allocation
:class
:initform
404))
63 (:report
"Document not found."))
65 (define-condition lw2-user-not-found-error
(lw2-not-found-error) ()
66 (:report
"User not found."))
68 (define-condition lw2-not-allowed-error
(lw2-client-error) ((http-return-code :allocation
:class
:initform
403))
69 (:report
"LW server reports: not allowed."))
71 (define-condition lw2-login-required-error
(lw2-client-error) ((http-return-code :allocation
:class
:initform
403))
72 (:report
"This document is only visible to logged-in users."))
74 (define-condition lw2-server-error
(lw2-error)
75 ((message :initarg
:message
:reader lw2-server-error-message
)
76 (introduction :allocation
:class
:reader condition-introduction
))
77 (:report
(lambda (c s
)
78 (format s
"~A:~%~A" (condition-introduction c
) (lw2-server-error-message c
)))))
80 (define-condition lw2-connection-error
(lw2-server-error)
81 ((introduction :allocation
:class
:initform
"Unable to connect to LW server")))
83 (define-condition lw2-unknown-error
(lw2-server-error)
84 ((introduction :allocation
:class
:initform
"Unrecognized LW server error")))
86 (defmethod error-to-html ((condition lw2-server-error
))
87 <p
>(condition-introduction condition
):</p
>
88 <code
><pre
>(lw2-server-error-message condition
)</pre
></code
>)
90 (defmacro error-explanation-case
(expression &rest clauses
)
91 (with-gensyms (condition)
92 `(let ((*error-explanation-hook
* (lambda (,condition
)
93 (typecase ,condition
,@clauses
))))
94 (declare (dynamic-extent *error-explanation-hook
*))
97 (defun html-output-stream-error-p (condition)
98 (and (typep condition
'stream-error
)
100 (compare-streams (stream-error-stream condition
) *html-output
*)))
102 (defun interesting-condition-p (condition)
103 (not (or (typep condition
'lw2-client-error
)
104 (html-output-stream-error-p condition
))))
106 (defun log-condition (condition)
108 (with-open-file (outstream "./logs/error.log" :direction
:output
:if-exists
:append
:if-does-not-exist
:create
)
109 (format outstream
"~%~A: ~S ~A~%" (local-time:format-timestring nil
(local-time:now
)) condition condition
)
110 (sb-debug:print-backtrace
:stream outstream
:from
:interrupted-frame
:print-frame-source t
))
111 (serious-condition ()
114 (defmacro log-conditions
(&body body
)
115 `(block log-conditions
117 (((or warning serious-condition
) (lambda (c) (when (interesting-condition-p c
) (log-condition c
)))))
120 (defmacro log-and-ignore-errors
(&body body
)
121 `(block log-and-ignore-errors
125 (when (interesting-condition-p c
) (log-condition c
))
126 (return-from log-and-ignore-errors
(values nil c
)))))
129 (defun abort-response ()
130 (throw 'abort-response nil
))
132 (defun abort-response-if-unrecoverable (condition)
133 (when (html-output-stream-error-p condition
)
136 (defmacro with-error-html-block
(() &body body
)
137 "If an error occurs within BODY, write an HTML representation of the
138 signaled condition to *HTML-OUTPUT*."
139 `(block with-error-html-block
140 (handler-bind ((serious-condition (lambda (c)
141 (abort-response-if-unrecoverable c
)
143 (return-from with-error-html-block nil
))))
144 (log-conditions (progn ,@body
)))))