stub fixes to http 1.0 support in the web server

* module/web/server.scm (read-client): Fix number of returned values in
  the case in which there is an error reading the client.
  (sanitize-response): Add a case to adapt the reponse to the request
  version.
  (handle-request): Sanitize the response within an error-handling
  block.
  (serve-one-client): Move sanitation out of here.

* module/web/server/http.scm (keep-alive?): A more proper detection on
  whether we should support persistent connections.

* module/web/response.scm (adapt-response-version): New routine, to
  adapt a response to a given version. Currently a stub.

diff --git a/module/web/response.scm b/module/web/response.scm
index 1c0ba3d..ef222f7 100644 (file)
--- a/module/web/response.scm
+++ b/module/web/response.scm
@@ -34,6 +34,7 @@
             read-response
             build-response
             extend-response
+            adapt-response-version
             write-response
 
             read-response-body/latin-1
@@ -164,6 +165,12 @@
     (lambda (version code reason-phrase)
       (make-response version code reason-phrase (read-headers port) port))))
 
+(define (adapt-response-version response version)
+  (build-response #:code (response-code response)
+                  #:version version
+                  #:headers (response-headers response)
+                  #:port (response-port response)))
+
 (define (write-response r port)
   (write-response-line (response-version r) (response-code r)
                        (response-reason-phrase r) port)

diff --git a/module/web/server.scm b/module/web/server.scm
index f8ebf18..bb7ce4d 100644 (file)
--- a/module/web/server.scm
+++ b/module/web/server.scm
@@ -140,21 +140,7 @@
    #:post-error
    (lambda (k . args)
      (warn "Error while accepting client" k args)
-     (values keep-alive #f #f #f #f))))
-
-;; -> response body state ...
-(define (handle-request handler request body . state)
-  (call-with-error-handling
-   (lambda ()
-     (with-stack-and-prompt
-      (lambda ()
-        (apply handler request body state))))
-   #:pass-keys '(quit interrupt)
-   #:on-error (if (batch-mode?) 'pass 'debug)
-   #:post-error
-   (lambda (k . args)
-     (warn "Error handling request" k args)
-     (apply values (build-response #:code 500) #f state))))
+     (values keep-alive #f #f #f))))
 
 (define (encode-string str charset)
   (case charset
@@ -165,7 +151,15 @@
 (define (sanitize-response request response body)
   (cond
    ((list? response)
-    (sanitize-response request (build-response #:headers response) body))
+    (sanitize-response request
+                       (build-response #:version (request-version request)
+                                       #:headers response)
+                       body))
+   ((not (equal? (request-version request) (response-version response)))
+    (sanitize-response request
+                       (adapt-response-version response
+                                               (request-version request))
+                       body))
    ((not body)
     (values response #vu8()))
    ((string? body)
@@ -199,6 +193,26 @@
    (else
     (error "unexpected body type"))))
 
+;; -> response body state
+(define (handle-request handler request body state)
+  (call-with-error-handling
+   (lambda ()
+     (call-with-values (lambda ()
+                         (with-stack-and-prompt
+                          (lambda ()
+                            (apply handler request body state))))
+       (lambda (response body . state)
+         (call-with-values (lambda ()
+                             (sanitize-response request response body))
+           (lambda (response body)
+             (values response body state))))))
+   #:pass-keys '(quit interrupt)
+   #:on-error (if (batch-mode?) 'pass 'debug)
+   #:post-error
+   (lambda (k . args)
+     (warn "Error handling request" k args)
+     (values (build-response #:code 500) #f state))))
+
 ;; -> (#f | client)
 (define (write-client impl server client response body)
   (call-with-error-handling
@@ -253,15 +267,12 @@
       (if client
           (call-with-values
               (lambda ()
-                (apply handle-request handler request body state))
-            (lambda (response body . state)
-              (call-with-values (lambda ()
-                                  (sanitize-response request response body))
-                (lambda (response body)
-                  (values
-                   (and-cons (write-client impl server client response body)
-                             keep-alive)
-                   state)))))
+                (handle-request handler request body state))
+            (lambda (response body state)
+              (values
+               (and-cons (write-client impl server client response body)
+                         keep-alive)
+               state)))
           (values keep-alive state)))))
 
 (define* (run-server handler #:optional (impl 'http) (open-params '())

diff --git a/module/web/server/http.scm b/module/web/server/http.scm
index 373017e..867e91c 100644 (file)
--- a/module/web/server/http.scm
+++ b/module/web/server/http.scm
@@ -91,7 +91,13 @@
         (values keep-alive #f #f #f))))))
 
 (define (keep-alive? response)
-  #t)
+  (let ((v (response-version response)))
+    (case (car v)
+      ((1)
+       (case (cdr v)
+         ((1) #t)
+         ((0) (memq 'keep-alive (response-connection response)))))
+      (else #f))))
 
 ;; -> (#f | client)
 (define (http-write server client response body)