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

Try to better handle exceptions in the web server

Browse source
This commit is contained in:
Christopher Baines 2025-01-23 09:34:54 +01:00
parent d572f591a3
commit 42d885c553
2 changed files with 166 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

161
knots/web-server.scm
View file

@ -25,6 +25,7 @@
#:use-module (ice-9 textual-ports)
#:use-module (ice-9 iconv)
#:use-module (ice-9 match)
#:use-module (ice-9 exceptions)
#:use-module ((srfi srfi-9 gnu) #:select (set-field))
#:use-module (system repl error-handling)
#:use-module (web http)
@ -33,6 +34,8 @@
#:use-module (knots non-blocking)
#:export (run-knots-web-server
default-write-response-exception-handler
web-server?
web-server-socket
web-server-port))
@ -98,12 +101,20 @@ on the procedure being called at any particular time."
(string->bytevector body charset))))
((not (or (bytevector? body)
(procedure? body)))
(error "unexpected body type"))
(raise-exception
(make-exception-with-irritants
(list (make-exception-with-message
"unexpected body type")
body))))
((and (response-must-not-include-body? response)
body
;; FIXME make this stricter: even an empty body should be prohibited.
(not (zero? (bytevector-length body))))
(error "response with this status code must not include body" response))
(raise-exception
(make-exception-with-irritants
(list (make-exception-with-message
"response with this status code must not include body")
response))))
(else
;; check length; assert type; add other required fields?
(values (if (procedure? body)
@ -120,10 +131,11 @@ on the procedure being called at any particular time."
(error "bad content-length" rlen blen)))
(else (extend-response response 'content-length blen)))))
(if (eq? (request-method request) 'HEAD)
;; Responses to HEAD requests must not include bodies.
;; We could raise an error here, but it seems more
;; appropriate to just do something sensible.
#f
(raise-exception
(make-exception-with-irritants
(list (make-exception-with-message
"unexpected body type")
body)))
body)))))
(define (with-stack-and-prompt thunk)
@ -143,7 +155,16 @@ on the procedure being called at any particular time."
((0) (memq 'keep-alive (response-connection response)))))
(else #f)))))
(define (handle-request handler client)
(define (default-write-response-exception-handler exn)
(simple-format
(current-error-port)
"knots web server: exception replying to client: ~A\n" exn)
;; Close the client port
#f)
(define (handle-request handler client
write-response-exception-handler)
(let ((request
(catch #t
(lambda ()
@ -161,33 +182,99 @@ on the procedure being called at any particular time."
#:headers '((content-length . 0)))
#vu8()))
(else
(call-with-error-handling
(lambda ()
(call-with-values (lambda ()
(with-stack-and-prompt
(lambda ()
(handler request))))
(lambda (response body)
(sanitize-response request response body))))
#:on-error 'backtrace
#:post-error (lambda _
(values (build-response #:code 500) #f)))))))
(write-response response client)
(when body
(if (procedure? body)
(if (response-content-length response)
(body client)
(let ((chunked-port
(make-chunked-output-port client
#:keep-alive? #t)))
(body chunked-port)
(close-port chunked-port)))
(put-bytevector client body)))
(force-output client)
(with-exception-handler
(lambda (exn)
(values (build-response #:code 500)
;; TODO Make this configurable
(string->utf8
"internal server error")))
(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)))))))
(lambda (response body)
(sanitize-response request response body))))
#:unwind? #t)))))
(with-exception-handler
write-response-exception-handler
(lambda ()
(write-response response client)
(keep-alive? response))))
(let ((body-written?
(if (procedure? body)
(if (response-content-length response)
(with-exception-handler
(lambda (exn)
#f)
(lambda ()
(with-stack-and-prompt
(lambda ()
(with-throw-handler #t
(lambda ()
(body client))
(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))))))
#t)
#:unwind? #t)
(let ((chunked-port
(make-chunked-output-port client
#:keep-alive? #t)))
(with-exception-handler
(lambda (exn)
#f)
(lambda ()
(with-throw-handler #t
(lambda ()
(body chunked-port)
(close-port chunked-port))
(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))))
#t)
#:unwind? #t)))
(begin
(put-bytevector client body)
#t))))
(if body-written?
(begin
(force-output client)
(keep-alive? response))
#f)))
#:unwind? #t))))
(define (client-loop client handler)
(define (client-loop client handler
write-response-exception-handler)
;; Always disable Nagle's algorithm, as we handle buffering
;; ourselves; when we force-output, we really want the data to go
;; out.
@ -202,7 +289,8 @@ on the procedure being called at any particular time."
(lambda _ #t))
(close-port client))
(else
(let ((keep-alive? (handle-request handler client)))
(let ((keep-alive? (handle-request handler client
write-response-exception-handler)))
(if keep-alive?
(loop)
(close-port client)))))))
@ -222,7 +310,9 @@ on the procedure being called at any particular time."
(inet-pton family host)
INADDR_LOOPBACK))
(port 8080)
(socket (make-default-socket family addr port)))
(socket (make-default-socket family addr port))
(write-response-exception-handler
default-write-response-exception-handler))
"Run the fibers web server.
HANDLER should be a procedure that takes one argument, the HTTP
@ -254,7 +344,8 @@ before sending back to the client."
(match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC))
((client . sockaddr)
(spawn-fiber (lambda ()
(client-loop client handler))
(client-loop client handler
write-response-exception-handler))
#:parallel? #t)
(loop))))))