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
)
14 (:recycle
#:lw2.backend
#:lw2-viewer
))
16 (in-package #:lw2.conditions
)
18 (named-readtables:in-readtable html-reader
)
20 (defvar *debug-mode
* nil
)
21 (defvar *error-explanation-hook
*)
23 (deftype fatal-error
() `(or serious-condition usocket
:ns-condition usocket
:socket-condition
))
25 (defgeneric condition-http-return-code
(c)
26 (:method
((c condition
)) 500))
28 (defmethod error-to-html :around
((condition condition
))
29 <div class
="gw-error">
32 (when (boundp '*error-explanation-hook
*)
33 (funcall *error-explanation-hook
* condition
))
37 (with-output-to-string (outstream)
38 (sb-debug:print-backtrace
:stream outstream
:from
:interrupted-frame
:print-frame-source t
))
42 (defmethod error-to-html ((condition condition
))
43 <code
><pre
>(princ-to-string condition
)</pre
></code
>)
45 (define-condition lw2-error
(error) ((http-return-code :allocation
:class
:reader condition-http-return-code
:initform
503)))
47 (defmethod error-to-html ((condition lw2-error
))
48 <p
>(princ-to-string condition
)</p
>)
50 (define-condition lw2-client-error
(lw2-error) ((http-return-code :allocation
:class
:initform
400)))
52 (define-condition csrf-check-failed
(lw2-error) ()
53 (:report
"CSRF check failed."))
55 (defmethod error-to-html ((condition csrf-check-failed
))
56 <p
>CSRF check failed.
</p
>
57 <p
>You may need to adjust your browser settings to allow cookies.
</p
>)
59 (define-condition lw2-not-found-error
(lw2-client-error) ((http-return-code :allocation
:class
:initform
404))
60 (:report
"Document not found."))
62 (define-condition lw2-user-not-found-error
(lw2-not-found-error) ()
63 (:report
"User not found."))
65 (define-condition lw2-not-allowed-error
(lw2-client-error) ((http-return-code :allocation
:class
:initform
403))
66 (:report
"LW server reports: not allowed."))
68 (define-condition lw2-login-required-error
(lw2-client-error) ((http-return-code :allocation
:class
:initform
403))
69 (:report
"This document is only visible to logged-in users."))
71 (define-condition lw2-server-error
(lw2-error)
72 ((message :initarg
:message
:reader lw2-server-error-message
)
73 (introduction :allocation
:class
:reader condition-introduction
))
74 (:report
(lambda (c s
)
75 (format s
"~A:~%~A" (condition-introduction c
) (lw2-server-error-message c
)))))
77 (define-condition lw2-connection-error
(lw2-server-error)
78 ((introduction :allocation
:class
:initform
"Unable to connect to LW server")))
80 (define-condition lw2-unknown-error
(lw2-server-error)
81 ((introduction :allocation
:class
:initform
"Unrecognized LW server error")))
83 (defmethod error-to-html ((condition lw2-server-error
))
84 <p
>(condition-introduction condition
):</p
>
85 <code
><pre
>(lw2-server-error-message condition
)</pre
></code
>)
87 (defmacro error-explanation-case
(expression &rest clauses
)
88 (with-gensyms (condition)
89 `(let ((*error-explanation-hook
* (lambda (,condition
)
90 (typecase ,condition
,@clauses
))))
91 (declare (dynamic-extent *error-explanation-hook
*))
94 (defun html-output-stream-error-p (condition)
95 (and (typep condition
'stream-error
)
97 (compare-streams (stream-error-stream condition
) *html-output
*)))
99 (defun interesting-condition-p (condition)
100 (not (or (typep condition
'lw2-client-error
)
101 (html-output-stream-error-p condition
))))
103 (defun log-condition (condition)
104 (with-open-file (outstream "./logs/error.log" :direction
:output
:if-exists
:append
:if-does-not-exist
:create
)
105 (format outstream
"~%~A: ~S ~A~%" (local-time:format-timestring nil
(local-time:now
)) condition condition
)
106 (sb-debug:print-backtrace
:stream outstream
:from
:interrupted-frame
:print-frame-source t
)))
108 (defmacro log-conditions
(&body body
)
109 `(block log-conditions
111 (((or warning serious-condition
) (lambda (c) (when (interesting-condition-p c
) (log-condition c
)))))
114 (defmacro log-and-ignore-errors
(&body body
)
115 `(block log-and-ignore-errors
119 (when (interesting-condition-p c
) (log-condition c
))
120 (return-from log-and-ignore-errors
(values nil c
)))))