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
(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
(define (sanitize-response request response body)
"\"Sanitize\" the given response and body, making them appropriate for
@ -155,19 +174,21 @@ on the procedure being called at any particular time."
response))))
(else
;; check length; assert type; add other required fields?
(values (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)))))
(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))))))
(if (eq? (request-method request) 'HEAD)
(raise-exception
(make-exception-with-irritants
@ -183,15 +204,7 @@ on the procedure being called at any particular time."
(with-stack-and-prompt (lambda () (proc k))))))
(define (keep-alive? response)
(let ((v (response-version 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)))))
(not (memq 'close (response-connection response))))
(define (default-read-request-exception-handler exn)
(display "While reading request:\n" (current-error-port))
@ -246,8 +259,11 @@ on the procedure being called at any particular time."
(cond
((not request)
;; Bad request.
(values (build-response #:version '(1 . 0) #:code 400
#:headers '((content-length . 0)))
(values (build-response
#:version '(1 . 0)
#:code 400
#:headers '((content-length . 0)
(connection . (close))))
#vu8()))
(else
(call-with-escape-continuation