cbaines/guile-knots
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Rework exception handling in the web server

Browse source
This commit is contained in:
Christopher Baines 2025-02-03 11:19:52 +01:00
parent dc98ef9dcc
commit 40cf026ea4
1 changed files with 51 additions and 41 deletions
Download patch file Download diff file Expand all files Collapse all files

92
knots/web-server.scm
View file

@ -18,6 +18,7 @@
(define-module (knots web-server) (define-module (knots web-server)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-71) #:use-module (srfi srfi-71)
#:use-module (ice-9 control)
#:use-module (fibers) #:use-module (fibers)
#:use-module (fibers timers) #:use-module (fibers timers)
#:use-module (fibers operations) #:use-module (fibers operations)
@ -30,6 +31,7 @@
#:use-module (ice-9 exceptions) #:use-module (ice-9 exceptions)
#:use-module ((srfi srfi-9 gnu) #:select (set-field)) #:use-module ((srfi srfi-9 gnu) #:select (set-field))
#:use-module (system repl error-handling) #:use-module (system repl error-handling)
#:use-module (web uri)
#:use-module (web http) #:use-module (web http)
#:use-module (web request) #:use-module (web request)
#:use-module (web response) #:use-module (web response)
@ -167,6 +169,24 @@ on the procedure being called at any particular time."
#f) #f)
(define (default-exception-handler exn request) (define (default-exception-handler exn request)
(let* ((stack (make-stack #t))
(error-string
(call-with-output-string
(lambda (port)
(simple-format
port
"exception when processing: ~A ~A\n"
(request-method request)
(uri-path (request-uri request)))
(display-backtrace stack port 4)
(print-exception
port
(stack-ref stack 4)
'%exception
(list exn))))))
(display error-string
(current-error-port)))
(values (build-response #:code 500) (values (build-response #:code 500)
;; TODO Make this configurable ;; TODO Make this configurable
(string->utf8 (string->utf8
@ -192,47 +212,37 @@ on the procedure being called at any particular time."
#:headers '((content-length . 0))) #:headers '((content-length . 0)))
#vu8())) #vu8()))
(else (else
(with-exception-handler (call-with-values
(lambda (exn) (lambda ()
(exception-handler exn request)) (call-with-escape-continuation
(lambda () (lambda (return)
(call-with-values (lambda () (with-exception-handler
(with-stack-and-prompt (lambda (exn)
(lambda () (call-with-values
(with-throw-handler #t (lambda ()
(lambda () (exception-handler exn request))
(handler request)) return))
(lambda (key . args) (lambda ()
(let ((stack (make-stack #t))) (start-stack #t (handler request)))))))
(print-exception (match-lambda*
(current-error-port) ((response body)
(stack-ref stack 2) (sanitize-response request response body))
key (other
args) (let ((stack (make-stack #t))
(display-backtrace (exception
stack (make-exception-with-irritants
(current-error-port) (list (make-exception-with-message
2))))))) (simple-format
(match-lambda* #f
((response body) "wrong number of values returned from handler, expecting 2, got ~A"
(sanitize-response request response body)) (length other)))
(other handler))))
(let ((stack (make-stack #t)) (print-exception
(exception (current-error-port)
(make-exception-with-irritants (stack-ref stack 2)
(list (make-exception-with-message '%exception
(simple-format (list exception))
#f (raise-exception exception)))))))))
"wrong number of values returned from handler, expecting 2, got ~A"
(length other)))
handler))))
(print-exception
(current-error-port)
(stack-ref stack 2)
'%exception
(list exception))
(raise-exception exception))))))
#:unwind? #t)))))
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(write-response-exception-handler exn request)) (write-response-exception-handler exn request))