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.

1 files changed, 36 insertions, 25 deletions

diff --git a/module/web/server.scm b/module/web/server.scm
index f8ebf1833..bb7ce4dea 100644
--- 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 '())