sunet/httpd-error.scm

132 lines
5.3 KiB
Scheme
Raw Normal View History

2000-09-26 10:35:26 -04:00
;;; Error stuff for the http server. -*- Scheme -*-
;;; Copyright (c) 1995 by Olin Shivers.
;;; An http error condition is a data structure with the following pieces:
;;; (error-code request message . irritants)
;;; You recognise one with HTTP-ERROR?, and retrieve the pieces with
;;; CONDITION-STUFF.
;;;
;;; You can find out more about the Scheme 48 condition system by consulting
;;; s48-error.txt, where I scribbled some notes as I was browsing the source
;;; code when I wrote this file.
;;; ,open conditions signals handle
;;; HTTP error condition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Define a sub-type of the S48 error condition, the HTTP error condition.
;;; An HTTP error is one that corresponds to one of the HTTP error reply
;;; codes, so you can reliably use an HTTP error condition to construct an
;;; error reply message to send back to the HTTP client.
(define-condition-type 'http-error '(error))
(define http-error? (condition-predicate 'http-error))
(define (http-error error-code req . args)
(apply signal 'http-error error-code req args))
;;; Syntax error condition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Scheme 48 has a "syntax error" error condition, but it isn't an error
;;; condition! It's a warning condition. I don't understand this.
;;; We define a *fatal* syntax error here for the parsers to use.
(define-condition-type 'fatal-syntax-error '(error))
(define fatal-syntax-error? (condition-predicate 'fatal-syntax-error))
(define (fatal-syntax-error msg . irritants)
(apply signal 'fatal-syntax-error msg irritants))
;;; (with-fatal-error-handler* handler thunk)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Call THUNK, and return whatever it returns. If THUNK signals a condition,
;;; and that condition is an error condition (or a subtype of error), then
;;; HANDLER gets a chance to handle it.
;;; The HANDLER proc is applied to two values:
;;; (HANDLER condition decline)
;;; HANDLER's continuation is WITH-FATAL-ERROR-HANDLER*'s; whatever HANDLER
;;; returns is returned from WITH-FATAL-ERROR-HANDLER. HANDLER declines to
;;; handle the error by throwing to DECLINE, a nullary continuation.
;;;
;;; Why is it called with-FATAL-error-handler*? Because returning to the
;;; guy that signalled the error is not an option.
;;;
;;; Why the nested outer pair of CALL/CC's? Well, what happens if the user's
;;; error handler *itself* raises an error? This could potentially give
;;; rise to an infinite loop, because WITH-HANDLER runs its handler in
;;; the original condition-signaller's context, so you'd search back for a
;;; handler, and find yourself again. For example, here is an infinite loop:
;;;
;;; (with-handler (lambda (condition more)
;;; (display "Loop!")
;;; (error "ouch")) ; Get back, Loretta.
;;; (lambda () (error "start me up")))
;;;
;;; I could require W-F-E-H* users to code carefully, but instead I make sure
;;; the user's fatal-error handler runs in w-f-e-h*'s handler context, so
;;; if it signals a condition, we'll start the search from there. That's the
;;; point of continuation K. When the original thunk completes successfully,
;;; we dodge the K hackery by using ACCEPT to make a normal return.
(define (with-fatal-error-handler* handler thunk)
(call-with-current-continuation
(lambda (accept)
((call-with-current-continuation
(lambda (k)
(with-handler (lambda (condition more)
(if (error? condition)
(call-with-current-continuation
(lambda (decline)
(k (lambda () (handler condition decline))))))
(more)) ; Keep looking for a handler.
(lambda () (call-with-values thunk accept)))))))))
(define-syntax with-fatal-error-handler
(syntax-rules ()
((with-fatal-error-handler handler body ...)
(with-fatal-error-handler* handler
(lambda () body ...)))))
;This one ran HANDLER in the signaller's condition-handler context.
;It was therefore susceptible to infinite loops if you didn't code
;your handler's carefully.
;
;(define (with-fatal-error-handler* handler thunk)
; (call-with-current-continuation
; (lambda (accept)
; (with-handler (lambda (condition more)
; (if (error? condition)
; (call-with-current-continuation
; (lambda (decline)
; (accept (handler condition decline)))))
; (more)) ; Keep looking for a handler.
; thunk))))
;;; (%error-handler-cond kont eh-clauses cond-clauses)
;;; Transform error-handler clauses into COND clauses by wrapping continuation
;;; KONT around the body of each e-h clause, so that if it fires, the result
;;; is thrown to KONT, but if no clause fires, the cond returns to the default
;;; continuation.
;(define-syntax %error-handler-cond
; (syntax-rules (=> else)
;
; ((%error-handler-cond kont ((test => proc) clause ...) (ans ...))
; (%error-handler-cond kont
; (clause ...)
; ((test => (lambda (v) (kont (proc v)))) ans ...)))
;
; ((%error-handler-cond kont ((test body ...) clause ...) (ans ...))
; (%error-handler-cond kont
; (clause ...)
; ((test (kont (begin body ...))) ans ...)))
;
; ((%error-handler-cond kont ((else body ...)) (ans-clause ...))
; (cond (else body ...) ans-clause ...))
;
; ((%error-handler-cond kont () (ans-clause ...))
; (cond ans-clause ...))))