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

Allow customising the web server read request exception handler

Browse source
This commit is contained in:
Christopher Baines 2025-02-07 10:48:50 +00:00
parent 025449ea0d
commit 19c1fe235b
1 changed files with 19 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

24
knots/web-server.scm
View file

@ -195,6 +195,16 @@ on the procedure being called at any particular time."
((0) (memq 'keep-alive (response-connection response))))) ((0) (memq 'keep-alive (response-connection response)))))
(else #f))))) (else #f)))))
(define (default-read-request-exception-handler exn)
(display "While reading request:\n" (current-error-port))
(print-exception
(current-error-port)
#f
'%exception
(list exn))
#f)
(define (default-write-response-exception-handler exn request) (define (default-write-response-exception-handler exn request)
(simple-format (simple-format
(current-error-port) (current-error-port)
@ -224,16 +234,15 @@ on the procedure being called at any particular time."
"internal server error"))) "internal server error")))
(define (handle-request handler client (define (handle-request handler client
read-request-exception-handler
write-response-exception-handler write-response-exception-handler
exception-handler) exception-handler)
(let ((request (let ((request
(catch #t (with-exception-handler
read-request-exception-handler
(lambda () (lambda ()
(read-request client)) (read-request client))
(lambda (key . args) #:unwind? #t)))
(display "While reading request:\n" (current-error-port))
(print-exception (current-error-port) #f key args)
#f))))
(let ((response (let ((response
body body
(cond (cond
@ -328,6 +337,7 @@ on the procedure being called at any particular time."
(define* (client-loop client handler (define* (client-loop client handler
exception-handler exception-handler
read-request-exception-handler
write-response-exception-handler write-response-exception-handler
connection-idle-timeout connection-idle-timeout
buffer-size) buffer-size)
@ -357,6 +367,7 @@ on the procedure being called at any particular time."
(close-port client)) (close-port client))
(else (else
(let ((keep-alive? (handle-request handler client (let ((keep-alive? (handle-request handler client
read-request-exception-handler
write-response-exception-handler write-response-exception-handler
exception-handler))) exception-handler)))
(if keep-alive? (if keep-alive?
@ -381,6 +392,8 @@ on the procedure being called at any particular time."
(socket (make-default-socket family addr port)) (socket (make-default-socket family addr port))
(exception-handler (exception-handler
default-exception-handler) default-exception-handler)
(read-request-exception-handler
default-read-request-exception-handler)
(write-response-exception-handler (write-response-exception-handler
default-write-response-exception-handler) default-write-response-exception-handler)
(connection-idle-timeout 60) (connection-idle-timeout 60)
@ -418,6 +431,7 @@ before sending back to the client."
(spawn-fiber (lambda () (spawn-fiber (lambda ()
(client-loop client handler (client-loop client handler
exception-handler exception-handler
read-request-exception-handler
write-response-exception-handler write-response-exception-handler
connection-idle-timeout connection-idle-timeout
connection-buffer-size)) connection-buffer-size))