cbaines/guile-knots
1
Fork 0
Code Issues 1 Pull requests Activity Actions

Fix some issues handling head requests

Browse source 
Rather than raising an exception when there's a body provided, use the
body as normal to inform the headers, as this is useful, and just
don't write the body to the client.
This commit is contained in:
Christopher Baines 2026-01-09 15:14:47 +00:00
parent 338d08081e
commit 4642f7c7d2
2 changed files with 127 additions and 59 deletions
Download patch file Download diff file Expand all files Collapse all files

121
knots/web-server.scm
View file

@ -228,8 +228,6 @@ on the procedure being called at any particular time."
(adapt-response-version response (adapt-response-version response
(request-version request)) (request-version request))
body)) body))
((not body)
(values response #vu8()))
((string? body) ((string? body)
(let* ((type (response-content-type response (let* ((type (response-content-type response
'(text/plain))) '(text/plain)))
@ -243,16 +241,15 @@ on the procedure being called at any particular time."
`(,@type (charset . ,charset)))) `(,@type (charset . ,charset))))
(string->bytevector body charset)))) (string->bytevector body charset))))
((not (or (bytevector? body) ((not (or (bytevector? body)
(procedure? body))) (procedure? body)
(eq? #f body)))
(raise-exception (raise-exception
(make-exception-with-irritants (make-exception-with-irritants
(list (make-exception-with-message (list (make-exception-with-message
"unexpected body type") "unexpected body type")
body)))) 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.
(not (zero? (bytevector-length body))))
(raise-exception (raise-exception
(make-exception-with-irritants (make-exception-with-irritants
(list (make-exception-with-message (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? ;; check length; assert type; add other required fields?
(values (response-maybe-add-connection-header-value (values (response-maybe-add-connection-header-value
request request
(if (procedure? body) (cond
(if (response-content-length response) ((procedure? body)
response (if (response-content-length response)
(extend-response response response
'transfer-encoding (extend-response response
'((chunked)))) 'transfer-encoding
(let ((rlen (response-content-length response)) '((chunked)))))
(blen (bytevector-length body))) ((bytevector? body)
(cond (let ((rlen (response-content-length response))
(rlen (if (= rlen blen) (blen (bytevector-length body)))
response (cond
(error "bad content-length" rlen blen))) (rlen (if (= rlen blen)
(else (extend-response response 'content-length blen)))))) response
(error "bad content-length" rlen blen)))
(else (extend-response response 'content-length blen)))))
(else response)))
(if (eq? (request-method request) 'HEAD) (if (eq? (request-method request) 'HEAD)
(raise-exception #f
(make-exception-with-irritants
(list (make-exception-with-message
"unexpected body type")
body)))
body))))) body)))))
(define (with-stack-and-prompt thunk) (define (with-stack-and-prompt thunk)
@ -405,41 +401,48 @@ on the procedure being called at any particular time."
(let ((response-start-time (let ((response-start-time
(get-internal-real-time)) (get-internal-real-time))
(body-written? (body-written?
(if (procedure? body) (cond
(let* ((type (response-content-type response ((and (procedure? body)
'(text/plain))) (not
(declared-charset (assq-ref (cdr type) 'charset)) (eq? (request-method request)
(charset (or declared-charset "ISO-8859-1")) 'HEAD)))
(body-port (let* ((type (response-content-type response
(if (response-content-length response) '(text/plain)))
client (declared-charset (assq-ref (cdr type) 'charset))
(make-chunked-output-port/knots (charset (or declared-charset "ISO-8859-1"))
client (body-port
#:keep-alive? #t (if (response-content-length response)
#:buffering client
(- buffer-size (make-chunked-output-port/knots
(chunked-output-port-overhead-bytes client
buffer-size)))))) #:keep-alive? #t
(set-port-encoding! body-port charset) #:buffering
(let ((body-written? (- buffer-size
(with-exception-handler (chunked-output-port-overhead-bytes
(lambda (exn) buffer-size))))))
#f) (set-port-encoding! body-port charset)
(lambda () (let ((body-written?
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(print-backtrace-and-exception/knots exn) #f)
(raise-exception exn)) (lambda ()
(lambda () (with-exception-handler
(body body-port))) (lambda (exn)
#t) (print-backtrace-and-exception/knots exn)
#:unwind? #t))) (raise-exception exn))
(unless (response-content-length response) (lambda ()
(close-port body-port)) (body body-port)))
body-written?)) #t)
(begin #:unwind? #t)))
(put-bytevector client body) (unless (response-content-length response)
#t)))) (close-port body-port))
body-written?)))
((bytevector? body)
(put-bytevector client body)
#t)
(else
;; No body to write
#t))))
(if body-written? (if body-written?
(begin (begin
(force-output client) (force-output client)

65
tests/web-server.scm
View file

@ -1,5 +1,6 @@
(use-modules (srfi srfi-71) (use-modules (srfi srfi-71)
(rnrs bytevectors) (rnrs bytevectors)
(ice-9 match)
(ice-9 binary-ports) (ice-9 binary-ports)
(ice-9 textual-ports) (ice-9 textual-ports)
(tests) (tests)
@ -233,4 +234,68 @@
(assert-equal (get-message exception-handled-sucecssfully-channel) (assert-equal (get-message exception-handled-sucecssfully-channel)
#t)))) #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") (display "web-server test finished successfully\n")