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))))