[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-107-ga0ad8ad

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=a0ad8ad16c14adbf13e0ead3dafd833fb3c8f0d3

The branch, master has been updated
       via  a0ad8ad16c14adbf13e0ead3dafd833fb3c8f0d3 (commit)
       via  c6371902036f68c96c2bdb22d2ff9f57846ea652 (commit)
      from  c0f6c1638bb920d5cf5ec3210d91bc9fb0c70319 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit a0ad8ad16c14adbf13e0ead3dafd833fb3c8f0d3
Author: Andy Wingo <address@hidden>
Date:   Mon Nov 29 13:00:43 2010 +0100

    http web server impl ignores SIGPIPE
    
    * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the
      server from dying in some circumstances.

commit c6371902036f68c96c2bdb22d2ff9f57846ea652
Author: Andy Wingo <address@hidden>
Date:   Mon Nov 29 12:05:57 2010 +0100

    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.

-----------------------------------------------------------------------

Summary of changes:
 module/web/response.scm    |    7 +++++
 module/web/server.scm      |   61 ++++++++++++++++++++++++++------------------
 module/web/server/http.scm |    9 ++++++-
 3 files changed, 51 insertions(+), 26 deletions(-)

diff --git a/module/web/response.scm b/module/web/response.scm
index 1c0ba3d..ef222f7 100644
--- 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
--- 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..5632fdc 100644
--- a/module/web/server/http.scm
+++ b/module/web/server/http.scm
@@ -44,6 +44,7 @@
                       (port 8080)
                       (socket (make-default-socket family addr port)))
   (listen socket 5)
+  (sigaction SIGPIPE SIG_IGN)
   socket)
 
 ;; -> (keep-alive client request body | keep-alive #f #f #f)
@@ -91,7 +92,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)


hooks/post-receive
-- 
GNU Guile