From 239cb88f93cee37aefd88f30041f5d13a0edc99f Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Thu, 20 Feb 2025 13:42:12 +0000
Subject: [PATCH] Rework handling connection persistance in the web server

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.
---
 knots/web-server.scm | 64 +++++++++++++++++++++++++++-----------------
 1 file changed, 40 insertions(+), 24 deletions(-)

diff --git a/knots/web-server.scm b/knots/web-server.scm
index ea53ba2..123763d 100644
--- a/knots/web-server.scm
+++ b/knots/web-server.scm
@@ -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