src/conditions.lisp

   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
   5            #:fatal-error
   6            #:condition-http-return-code
   7            #:error-to-html
   8            #:lw2-error
   9            #:csrf-check-failed
  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            #:abort-response
  15            #:abort-response-if-unrecoverable
  16            #:with-error-html-block)
  17   (:recycle #:lw2.backend #:lw2-viewer))
  18
  19 (in-package #:lw2.conditions)
  20
  21 (named-readtables:in-readtable html-reader)
  22
  23 (defvar *debug-mode* nil)
  24 (defvar *error-explanation-hook*)
  25
  26 (deftype fatal-error () `(or serious-condition usocket:ns-condition usocket:socket-condition))
  27
  28 (defgeneric condition-http-return-code (c)
  29   (:method ((c condition)) 500))
  30
  31 (defmethod error-to-html :around ((condition condition))
  32   <div class="gw-error">
  33     <h1>Error</h1>
  34     (call-next-method)
  35     (when (boundp '*error-explanation-hook*)
  36       (funcall *error-explanation-hook* condition))
  37     (when *debug-mode*
  38       <h2>Backtrace</h2>
  39       <code><pre>
  40         (with-output-to-string (outstream)
  41           (sb-debug:print-backtrace :stream outstream :from :interrupted-frame :print-frame-source t))
  42       </pre></code>)
  43   </div>)
  44
  45 (defmethod error-to-html ((condition condition))
  46   <code><pre>(princ-to-string condition)</pre></code>)
  47
  48 (define-condition lw2-error (error) ((http-return-code :allocation :class :reader condition-http-return-code :initform 503)))
  49
  50 (defmethod error-to-html ((condition lw2-error))
  51   <p>(princ-to-string condition)</p>)
  52
  53 (define-condition lw2-client-error (lw2-error) ((http-return-code :allocation :class :initform 400)))
  54
  55 (define-condition csrf-check-failed (lw2-error) ()
  56   (:report "CSRF check failed."))
  57
  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>)
  61
  62 (define-condition lw2-not-found-error (lw2-client-error) ((http-return-code :allocation :class :initform 404))
  63   (:report "Document not found."))
  64
  65 (define-condition lw2-user-not-found-error (lw2-not-found-error) ()
  66   (:report "User not found."))
  67
  68 (define-condition lw2-not-allowed-error (lw2-client-error) ((http-return-code :allocation :class :initform 403))
  69   (:report "LW server reports: not allowed."))
  70
  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."))
  73
  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)))))
  79
  80 (define-condition lw2-connection-error (lw2-server-error)
  81   ((introduction :allocation :class :initform "Unable to connect to LW server")))
  82
  83 (define-condition lw2-unknown-error (lw2-server-error)
  84   ((introduction :allocation :class :initform "Unrecognized LW server error")))
  85
  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>)
  89
  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*))
  95        ,expression)))
  96
  97 (defun html-output-stream-error-p (condition)
  98   (and (typep condition 'stream-error)
  99        *html-output*
 100        (compare-streams (stream-error-stream condition) *html-output*)))
 101
 102 (defun interesting-condition-p (condition)
 103   (not (or (typep condition 'lw2-client-error)
 104            (html-output-stream-error-p condition))))
 105
 106 (defun log-condition (condition)
 107   (with-open-file (outstream "./logs/error.log" :direction :output :if-exists :append :if-does-not-exist :create)
 108     (format outstream "~%~A: ~S ~A~%" (local-time:format-timestring nil (local-time:now)) condition condition)
 109     (sb-debug:print-backtrace :stream outstream :from :interrupted-frame :print-frame-source t)))
 110
 111 (defmacro log-conditions (&body body)
 112   `(block log-conditions
 113      (handler-bind
 114          (((or warning serious-condition) (lambda (c) (when (interesting-condition-p c) (log-condition c)))))
 115        ,@body)))
 116
 117 (defmacro log-and-ignore-errors (&body body)
 118   `(block log-and-ignore-errors
 119      (handler-bind
 120          ((fatal-error
 121            (lambda (c)
 122              (when (interesting-condition-p c) (log-condition c))
 123              (return-from log-and-ignore-errors (values nil c)))))
 124        ,@body)))
 125
 126 (defun abort-response ()
 127   (throw 'abort-response nil))
 128
 129 (defun abort-response-if-unrecoverable (condition)
 130   (when (html-output-stream-error-p condition)
 131     (abort-response)))
 132
 133 (defmacro with-error-html-block (() &body body)
 134   "If an error occurs within BODY, write an HTML representation of the
 135 signaled condition to *HTML-OUTPUT*."
 136   `(block with-error-html-block
 137      (handler-bind ((serious-condition (lambda (c)
 138                                          (abort-response-if-unrecoverable c)
 139                                          (error-to-html c)
 140                                          (return-from with-error-html-block nil))))
 141        (log-conditions (progn ,@body)))))