diff --git a/knots/web-server.scm b/knots/web-server.scm index 4d7240b..d0b13ce 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -228,8 +228,6 @@ on the procedure being called at any particular time." (adapt-response-version response (request-version request)) body)) - ((not body) - (values response #vu8())) ((string? body) (let* ((type (response-content-type response '(text/plain))) @@ -243,16 +241,15 @@ on the procedure being called at any particular time." `(,@type (charset . ,charset)))) (string->bytevector body charset)))) ((not (or (bytevector? body) - (procedure? body))) + (procedure? body) + (eq? #f body))) (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)))) + body) (raise-exception (make-exception-with-irritants (list (make-exception-with-message @@ -262,25 +259,24 @@ on the procedure being called at any particular time." ;; check length; assert type; add other required fields? (values (response-maybe-add-connection-header-value request - (if (procedure? body) - (if (response-content-length response) - response - (extend-response response - 'transfer-encoding - '((chunked)))) - (let ((rlen (response-content-length response)) - (blen (bytevector-length body))) - (cond - (rlen (if (= rlen blen) - response - (error "bad content-length" rlen blen))) - (else (extend-response response 'content-length blen)))))) + (cond + ((procedure? body) + (if (response-content-length response) + response + (extend-response response + 'transfer-encoding + '((chunked))))) + ((bytevector? body) + (let ((rlen (response-content-length response)) + (blen (bytevector-length body))) + (cond + (rlen (if (= rlen blen) + response + (error "bad content-length" rlen blen))) + (else (extend-response response 'content-length blen))))) + (else response))) (if (eq? (request-method request) 'HEAD) - (raise-exception - (make-exception-with-irritants - (list (make-exception-with-message - "unexpected body type") - body))) + #f body))))) (define (with-stack-and-prompt thunk) @@ -405,41 +401,48 @@ on the procedure being called at any particular time." (let ((response-start-time (get-internal-real-time)) (body-written? - (if (procedure? body) - (let* ((type (response-content-type response - '(text/plain))) - (declared-charset (assq-ref (cdr type) 'charset)) - (charset (or declared-charset "ISO-8859-1")) - (body-port - (if (response-content-length response) - client - (make-chunked-output-port/knots - client - #:keep-alive? #t - #:buffering - (- buffer-size - (chunked-output-port-overhead-bytes - buffer-size)))))) - (set-port-encoding! body-port charset) - (let ((body-written? - (with-exception-handler - (lambda (exn) - #f) - (lambda () - (with-exception-handler - (lambda (exn) - (print-backtrace-and-exception/knots exn) - (raise-exception exn)) - (lambda () - (body body-port))) - #t) - #:unwind? #t))) - (unless (response-content-length response) - (close-port body-port)) - body-written?)) - (begin - (put-bytevector client body) - #t)))) + (cond + ((and (procedure? body) + (not + (eq? (request-method request) + 'HEAD))) + (let* ((type (response-content-type response + '(text/plain))) + (declared-charset (assq-ref (cdr type) 'charset)) + (charset (or declared-charset "ISO-8859-1")) + (body-port + (if (response-content-length response) + client + (make-chunked-output-port/knots + client + #:keep-alive? #t + #:buffering + (- buffer-size + (chunked-output-port-overhead-bytes + buffer-size)))))) + (set-port-encoding! body-port charset) + (let ((body-written? + (with-exception-handler + (lambda (exn) + #f) + (lambda () + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (body body-port))) + #t) + #:unwind? #t))) + (unless (response-content-length response) + (close-port body-port)) + body-written?))) + ((bytevector? body) + (put-bytevector client body) + #t) + (else + ;; No body to write + #t)))) (if body-written? (begin (force-output client) diff --git a/tests/web-server.scm b/tests/web-server.scm index e456bf3..67c6423 100644 --- a/tests/web-server.scm +++ b/tests/web-server.scm @@ -1,5 +1,6 @@ (use-modules (srfi srfi-71) (rnrs bytevectors) + (ice-9 match) (ice-9 binary-ports) (ice-9 textual-ports) (tests) @@ -233,4 +234,68 @@ (assert-equal (get-message exception-handled-sucecssfully-channel) #t)))) +(run-fibers-for-tests + (lambda () + (let* ((web-server + (run-knots-web-server + (lambda (request) + (match (split-and-decode-uri-path + (uri-path (request-uri request))) + (("head-no-body") + (values '((content-type . (text/plain))) + #f)) + (("head-empty-body") + (values '((content-type . (text/plain))) + "")) + (("head-no-body-with-content-length") + (values '((content-type . (text/plain)) + (content-length . 10)) + #f)) + (("head-with-body") + (values '((content-type . (text/plain))) + "foo")) + (("head-procedure-body") + (values '((content-type . (text/plain))) + (lambda _ + (error "should not be run")))) + (("head-procedure-body-with-content-length") + (values '((content-type . (text/plain)) + (content-length . 10)) + (lambda _ + (error "should not be run")))))) + #:port 0)) ;; Bind to any port + (port + (web-server-port web-server))) + + (define* (head path) + (let ((uri + (build-uri 'http #:host "127.0.0.1" #:port port + #:path path))) + (http-head + uri + #:port (non-blocking-open-socket-for-uri uri)))) + + (let ((response + (head "/head-no-body"))) + (assert-equal 200 (response-code response))) + (let ((response + (head "/head-empty-body"))) + (assert-equal 200 (response-code response)) + (assert-equal 0 (response-content-length response))) + (let ((response + (head "/head-no-body-with-content-length"))) + (assert-equal 200 (response-code response)) + (assert-equal 10 (response-content-length response))) + (let ((response + (head "/head-with-body"))) + (assert-equal 200 (response-code response)) + (assert-equal 3 (response-content-length response))) + (let ((response + (head "/head-procedure-body"))) + (assert-equal 200 (response-code response))) + (let ((response + (head "/head-procedure-body-with-content-length"))) + (assert-equal 200 (response-code response)) + (assert-equal 10 (response-content-length response)))))) + (display "web-server test finished successfully\n")