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)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-71)
#:use-module (ice-9 control)
#:use-module (fibers)
#:use-module (fibers timers)
#:use-module (fibers operations)
@ -30,6 +31,7 @@
#:use-module (ice-9 exceptions)
#:use-module ((srfi srfi-9 gnu) #:select (set-field))
#:use-module (system repl error-handling)
#:use-module (web uri)
#:use-module (web http)
#:use-module (web request)
#:use-module (web response)
@ -167,6 +169,24 @@ on the procedure being called at any particular time."
#f)
(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)
;; TODO Make this configurable
(string->utf8
@ -192,47 +212,37 @@ on the procedure being called at any particular time."
#:headers '((content-length . 0)))
#vu8()))
(else
(with-exception-handler
(lambda (exn)
(exception-handler exn request))
(lambda ()
(call-with-values (lambda ()
(with-stack-and-prompt
(lambda ()
(with-throw-handler #t
(lambda ()
(handler request))
(lambda (key . args)
(let ((stack (make-stack #t)))
(print-exception
(current-error-port)
(stack-ref stack 2)
key
args)
(display-backtrace
stack
(current-error-port)
2)))))))
(match-lambda*
((response body)
(sanitize-response request response body))
(other
(let ((stack (make-stack #t))
(exception
(make-exception-with-irritants
(list (make-exception-with-message
(simple-format
#f
"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)))))
(call-with-values
(lambda ()
(call-with-escape-continuation
(lambda (return)
(with-exception-handler
(lambda (exn)
(call-with-values
(lambda ()
(exception-handler exn request))
return))
(lambda ()
(start-stack #t (handler request)))))))
(match-lambda*
((response body)
(sanitize-response request response body))
(other
(let ((stack (make-stack #t))
(exception
(make-exception-with-irritants
(list (make-exception-with-message
(simple-format
#f
"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)))))))))
(with-exception-handler
(lambda (exn)
(write-response-exception-handler exn request))