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   (:recycle #:lw2.backend #:lw2-viewer))
  15
  16 (in-package #:lw2.conditions)
  17
  18 (named-readtables:in-readtable html-reader)
  19
  20 (defvar *debug-mode* nil)
  21 (defvar *error-explanation-hook*)
  22
  23 (deftype fatal-error () `(or serious-condition usocket:ns-condition usocket:socket-condition))
  24
  25 (defgeneric condition-http-return-code (c)
  26   (:method ((c condition)) 500))
  27
  28 (defmethod error-to-html :around ((condition condition))
  29   <div class="gw-error">
  30     <h1>Error</h1>
  31     (call-next-method)
  32     (when (boundp '*error-explanation-hook*)
  33       (funcall *error-explanation-hook* condition))
  34     (when *debug-mode*
  35       <h2>Backtrace</h2>
  36       <code><pre>
  37         (with-output-to-string (outstream)
  38           (sb-debug:print-backtrace :stream outstream :from :interrupted-frame :print-frame-source t))
  39       </pre></code>)
  40   </div>)
  41
  42 (defmethod error-to-html ((condition condition))
  43   <code><pre>(princ-to-string condition)</pre></code>)
  44
  45 (define-condition lw2-error (error) ((http-return-code :allocation :class :reader condition-http-return-code :initform 503)))
  46
  47 (defmethod error-to-html ((condition lw2-error))
  48   <p>(princ-to-string condition)</p>)
  49
  50 (define-condition lw2-client-error (lw2-error) ((http-return-code :allocation :class :initform 400)))
  51
  52 (define-condition csrf-check-failed (lw2-error) ()
  53   (:report "CSRF check failed."))
  54
  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>)
  58
  59 (define-condition lw2-not-found-error (lw2-client-error) ((http-return-code :allocation :class :initform 404))
  60   (:report "Document not found."))
  61
  62 (define-condition lw2-user-not-found-error (lw2-not-found-error) ()
  63   (:report "User not found."))
  64
  65 (define-condition lw2-not-allowed-error (lw2-client-error) ((http-return-code :allocation :class :initform 403))
  66   (:report "LW server reports: not allowed."))
  67
  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."))
  70
  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)))))
  76
  77 (define-condition lw2-connection-error (lw2-server-error)
  78   ((introduction :allocation :class :initform "Unable to connect to LW server")))
  79
  80 (define-condition lw2-unknown-error (lw2-server-error)
  81   ((introduction :allocation :class :initform "Unrecognized LW server error")))
  82
  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>)
  86
  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*))
  92        ,expression)))
  93
  94 (defun html-output-stream-error-p (condition)
  95   (and (typep condition 'stream-error)
  96        *html-output*
  97        (compare-streams (stream-error-stream condition) *html-output*)))
  98
  99 (defun interesting-condition-p (condition)
 100   (not (or (typep condition 'lw2-client-error)
 101            (html-output-stream-error-p condition))))
 102
 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)))
 107
 108 (defmacro log-conditions (&body body)
 109   `(block log-conditions
 110      (handler-bind
 111          (((or warning serious-condition) (lambda (c) (when (interesting-condition-p c) (log-condition c)))))
 112        ,@body)))
 113
 114 (defmacro log-and-ignore-errors (&body body)
 115   `(block log-and-ignore-errors
 116      (handler-bind
 117          ((fatal-error
 118            (lambda (c)
 119              (when (interesting-condition-p c) (log-condition c))
 120              (return-from log-and-ignore-errors (values nil c)))))
 121        ,@body)))