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
(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)