cbaines/guile-knots
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Rework handling connection persistance in the web server

Browse source 
Change to setting the connection header in the response based on the
request, and then closing the connection in the server based on the
response headers.

Stop closing the response based on the response code, as I don't know
why this is necessary.
This commit is contained in:
Christopher Baines 2025-02-20 13:42:12 +00:00
parent 1fbd1f334a
commit 239cb88f93
1 changed files with 40 additions and 24 deletions
Download patch file Download diff file Expand all files Collapse all files

64
knots/web-server.scm
View file

@ -95,6 +95,25 @@ KEEP-ALIVE? is true."
r r
(apply extend-response r additional)))) (apply extend-response r additional))))
(define (response-maybe-add-connection-header-value request response)
(if (memq 'close (response-connection response))
;; Nothing to do
response
(let* ((v (request-version request))
(add-close-header?
(case (car v)
((1)
(case (cdr v)
((1) (memq 'close (request-connection request)))
((0) (not (memq 'keep-alive (request-connection request))))))
(else #t))))
(if add-close-header?
(extend-response response 'connection '(close))
(if (and (= 1 (car v))
(= 0 (cdr v)))
(extend-response response 'connection '(keep-alive))
response)))))
;; -> response body ;; -> response body
(define (sanitize-response request response body) (define (sanitize-response request response body)
"\"Sanitize\" the given response and body, making them appropriate for "\"Sanitize\" the given response and body, making them appropriate for
@ -155,19 +174,21 @@ on the procedure being called at any particular time."
response)))) response))))
(else (else
;; check length; assert type; add other required fields? ;; check length; assert type; add other required fields?
(values (if (procedure? body) (values (response-maybe-add-connection-header-value
(if (response-content-length response) request
response (if (procedure? body)
(extend-response response (if (response-content-length response)
'transfer-encoding response
'((chunked)))) (extend-response response
(let ((rlen (response-content-length response)) 'transfer-encoding
(blen (bytevector-length body))) '((chunked))))
(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))))))
(if (eq? (request-method request) 'HEAD) (if (eq? (request-method request) 'HEAD)
(raise-exception (raise-exception
(make-exception-with-irritants (make-exception-with-irritants
@ -183,15 +204,7 @@ on the procedure being called at any particular time."
(with-stack-and-prompt (lambda () (proc k)))))) (with-stack-and-prompt (lambda () (proc k))))))
(define (keep-alive? response) (define (keep-alive? response)
(let ((v (response-version response))) (not (memq 'close (response-connection response))))
(and (or (< (response-code response) 400)
(= (response-code response) 404))
(case (car v)
((1)
(case (cdr v)
((1) (not (memq 'close (response-connection response))))
((0) (memq 'keep-alive (response-connection response)))))
(else #f)))))
(define (default-read-request-exception-handler exn) (define (default-read-request-exception-handler exn)
(display "While reading request:\n" (current-error-port)) (display "While reading request:\n" (current-error-port))
@ -246,8 +259,11 @@ on the procedure being called at any particular time."
(cond (cond
((not request) ((not request)
;; Bad request. ;; Bad request.
(values (build-response #:version '(1 . 0) #:code 400 (values (build-response
#:headers '((content-length . 0))) #:version '(1 . 0)
#:code 400
#:headers '((content-length . 0)
(connection . (close))))
#vu8())) #vu8()))
(else (else
(call-with-escape-continuation (call-with-escape-continuation