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

135
knots/web-server.scm
View file

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

41
tests/web-server.scm
View file

@ -1,8 +1,11 @@
(use-modules (tests) (use-modules (srfi srfi-71)
(tests)
(fibers) (fibers)
(fibers channels)
(unit-test) (unit-test)
(web uri) (web uri)
(web client) (web client)
(web request)
(web response) (web response)
(knots web-server) (knots web-server)
(knots non-blocking)) (knots non-blocking))
@ -27,4 +30,40 @@
uri uri
#:port (non-blocking-open-socket-for-uri uri))))))) #:port (non-blocking-open-socket-for-uri uri)))))))
(run-fibers-for-tests
(lambda ()
(let* ((exception-handled-sucecssfully-channel
(make-channel))
(port-closed-channel (make-channel))
(web-server
(run-knots-web-server
(lambda (request)
;; TODO Not sure why buffering makes a difference here
(setvbuf (request-port request) 'none)
(get-message port-closed-channel)
(values '((content-type . (text/plain)))
"Hello, World!"))
#:write-response-exception-handler
(lambda (exn)
(spawn-fiber
(lambda ()
(put-message exception-handled-sucecssfully-channel
#t)))
#f)
#:port 0)) ;; Bind to any port
(port
(web-server-port web-server))
(uri
(build-uri 'http #:host "127.0.0.1" #:port port)))
(let ((request-port (non-blocking-open-socket-for-uri uri)))
(write-request
(build-request uri)
request-port)
(close-port request-port))
(put-message port-closed-channel #t)
(assert-equal (get-message exception-handled-sucecssfully-channel)
#t))))
(display "web-server test finished successfully\n") (display "web-server test finished successfully\n")