conditions.lisp

   1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
   2
   3 ;;; Copyright (c) 2008-2009, Dr. Edmund Weitz.  All rights reserved.
   4
   5 ;;; Redistribution and use in source and binary forms, with or without
   6 ;;; modification, are permitted provided that the following conditions
   7 ;;; are met:
   8
   9 ;;;   * Redistributions of source code must retain the above copyright
  10 ;;;     notice, this list of conditions and the following disclaimer.
  11
  12 ;;;   * Redistributions in binary form must reproduce the above
  13 ;;;     copyright notice, this list of conditions and the following
  14 ;;;     disclaimer in the documentation and/or other materials
  15 ;;;     provided with the distribution.
  16
  17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28
  29 (in-package :hunchentoot)
  30
  31 (define-condition hunchentoot-condition (condition)
  32   ()
  33   (:documentation "Superclass for all conditions related to Hunchentoot."))
  34
  35 (define-condition hunchentoot-error (hunchentoot-condition error)
  36   ()
  37   (:documentation "Superclass for all errors related to Hunchentoot."))
  38
  39 (define-condition hunchentoot-simple-error (hunchentoot-error simple-condition)
  40   ()
  41   (:documentation "Like HUNCHENTOOT-ERROR but with formatting capabilities."))
  42
  43 (defun hunchentoot-error (format-control &rest format-arguments)
  44   "Signals an error of type HUNCHENTOOT-SIMPLE-ERROR with the provided
  45 format control and arguments."
  46   (error 'hunchentoot-simple-error
  47          :format-control format-control
  48          :format-arguments format-arguments))
  49
  50 (define-condition hunchentoot-warning (hunchentoot-condition warning)
  51   ()
  52   (:documentation "Superclass for all warnings related to Hunchentoot."))
  53
  54 (define-condition hunchentoot-simple-warning (hunchentoot-warning simple-condition)
  55   ()
  56   (:documentation "Like HUNCHENTOOT-WARNING but with formatting capabilities."))
  57
  58 (defun hunchentoot-warn (format-control &rest format-arguments)
  59   "Signals a warning of type HUNCHENTOOT-SIMPLE-WARNING with the
  60 provided format control and arguments."
  61   (warn 'hunchentoot-simple-warning
  62         :format-control format-control
  63         :format-arguments format-arguments))
  64
  65 (define-condition parameter-error (hunchentoot-simple-error)
  66   ()
  67   (:documentation "Signalled if a function was called with incosistent or illegal parameters."))
  68
  69 (defun parameter-error (format-control &rest format-arguments)
  70   "Signals an error of type PARAMETER-ERROR with the provided
  71 format control and arguments."
  72   (error 'parameter-error
  73          :format-control format-control
  74          :format-arguments format-arguments))
  75
  76 (define-condition operation-not-implemented (hunchentoot-error)
  77   ((operation :initarg :operation
  78               :reader hunchentoot-operation-not-implemented-operation
  79               :documentation "The name of the unimplemented operation."))
  80   (:report (lambda (condition stream)
  81              (format stream "The operation ~A is not yet implemented for the implementation ~A.
  82 Consider sending a patch..."
  83                      (hunchentoot-operation-not-implemented-operation condition)
  84                      (lisp-implementation-type))))
  85   (:documentation "This warning is signalled when an operation \(like
  86 SETUID for example) is not implemented for a specific Lisp."))
  87
  88 (defun not-implemented (name)
  89   "Used to signal an error if an operation named NAME is not implemented."
  90   (error 'operation-not-implemented :operation name))
  91
  92 (define-condition bad-request (hunchentoot-error)
  93   ())
  94
  95 ;;;
  96
  97 (defgeneric maybe-invoke-debugger (condition)
  98   (:documentation "This generic function is called whenever a
  99 condition CONDITION is signaled in Hunchentoot.  You might want to
 100 specialize it on specific condition classes for debugging purposes.")
 101   (:method (condition)
 102    "The default method invokes the debugger with CONDITION if
 103 *CATCH-ERRORS-P* is NIL."
 104    (unless *catch-errors-p*
 105      (invoke-debugger condition))))
 106
 107 (defmacro with-debugger (&body body)
 108   "Executes BODY and invokes the debugger if an error is signaled and
 109 *CATCH-ERRORS-P* is NIL."
 110   `(handler-bind ((bad-request (lambda (c)
 111                                  (declare (ignore c))
 112                                  (setf (return-code *reply*) +http-bad-request+)
 113                                  (abort-request-handler)))
 114                   (error #'maybe-invoke-debugger))
 115      ,@body))
 116
 117 (defmacro ignore-errors* (&body body)
 118   "Like IGNORE-ERRORS, but observes *CATCH-ERRORS-P*."
 119   `(ignore-errors (with-debugger ,@body)))
 120
 121 (defmacro handler-case* (expression &rest clauses)
 122   "Like HANDLER-CASE, but observes *CATCH-ERRORS-P*."
 123   `(handler-case (with-debugger ,expression)
 124      ,@clauses))
 125
 126 (defun get-backtrace ()
 127   "Returns a string with a backtrace of what the Lisp system thinks is
 128 the \"current\" error."
 129   (handler-case
 130       (with-output-to-string (s)
 131         (trivial-backtrace:print-backtrace-to-stream s))
 132     (error (condition)
 133       (format nil "Could not generate backtrace: ~A." condition))))