From 42d885c5539840ce63421771f8d4bb612d4446a5 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Thu, 23 Jan 2025 09:34:54 +0100 Subject: [PATCH] Try to better handle exceptions in the web server --- knots/web-server.scm | 161 +++++++++++++++++++++++++++++++++---------- tests/web-server.scm | 41 ++++++++++- 2 files changed, 166 insertions(+), 36 deletions(-) diff --git a/knots/web-server.scm b/knots/web-server.scm index b94106f..58c1883 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -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)))))) diff --git a/tests/web-server.scm b/tests/web-server.scm index 0254795..00cd8c3 100644 --- a/tests/web-server.scm +++ b/tests/web-server.scm @@ -1,8 +1,11 @@ -(use-modules (tests) +(use-modules (srfi srfi-71) + (tests) (fibers) + (fibers channels) (unit-test) (web uri) (web client) + (web request) (web response) (knots web-server) (knots non-blocking)) @@ -27,4 +30,40 @@ 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")