[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-41-g164a78b

[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=164a78b355908d2149ef1ef266bec26d56b73365

The branch, stable-2.0 has been updated
       via  164a78b355908d2149ef1ef266bec26d56b73365 (commit)
      from  2263ccb53e6017cc89ccb69556a69d3ae7c2ff3b (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 164a78b355908d2149ef1ef266bec26d56b73365
Author: Andy Wingo <address@hidden>
Date:   Sun Feb 12 13:17:11 2012 +0100

    web server: do not provide a response body where it is not permitted
    
    * module/web/response.scm (response-must-not-include-body?): New
      function.
    
    * doc/ref/web.texi: Doc the function.
    
    * module/web/server.scm (sanitize-response): Error if we have a body,
      but the response type does not permit a body.  If we are responding to
      a HEAD request, silently drop the body.

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

Summary of changes:
 doc/ref/web.texi        |   10 +++++++++-
 module/web/response.scm |   12 +++++++++++-
 module/web/server.scm   |   15 +++++++++++----
 3 files changed, 31 insertions(+), 6 deletions(-)

diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index 81c77dd..8bb99e2 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2010, 2011 Free Software Foundation, Inc.
address@hidden Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
 @node Web
@@ -1235,6 +1235,14 @@ Return a new response, whose @code{response-port} will 
continue writing
 on @var{port}, perhaps using some transfer encoding.
 @end deffn
 
address@hidden {Scheme Procedure} response-must-not-include-body? r
+Some responses, like those with status code 304, are specified as never
+having bodies.  This predicate returns @code{#t} for those responses.
+
+Note also, though, that responses to @code{HEAD} requests must also not
+have a body.
address@hidden deffn
+
 @deffn {Scheme Procedure} read-response-body r
 Read the response body from @var{r}, as a bytevector.  Returns @code{#f}
 if there was no response body.
diff --git a/module/web/response.scm b/module/web/response.scm
index f49a602..07e1245 100644
--- a/module/web/response.scm
+++ b/module/web/response.scm
@@ -1,6 +1,6 @@
 ;;; HTTP response objects
 
-;; Copyright (C)  2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C)  2010, 2011, 2012 Free Software Foundation, Inc.
 
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -36,6 +36,7 @@
             adapt-response-version
             write-response
 
+            response-must-not-include-body?
             read-response-body
             write-response-body
 
@@ -214,6 +215,15 @@ on @var{port}, perhaps using some transfer encoding."
       (make-response (response-version r) (response-code r)
                      (response-reason-phrase r) (response-headers r) port)))
 
+(define (response-must-not-include-body? r)
+  "Returns @code{#t} if the response @var{r} is not permitted to have a body.
+
+This is true for some response types, like those with code 304."
+  ;; RFC 2616, section 4.3.
+  (or (<= 100 (response-code r) 199)
+      (= (response-code r) 204)
+      (= (response-code r) 304)))
+
 (define (read-response-body r)
   "Reads the response body from @var{r}, as a bytevector.  Returns
 @code{#f} if there was no response body."
diff --git a/module/web/server.scm b/module/web/server.scm
index b9bdef2..5fc081c 100644
--- a/module/web/server.scm
+++ b/module/web/server.scm
@@ -262,7 +262,11 @@ on the procedure being called at any particular time."
            (extend-response response 'content-type
                             `(,@type (charset . ,charset))))
        (call-with-encoded-output-string charset body))))
-   ((bytevector? body)
+   ((not (bytevector? body))
+    (error "unexpected body type"))
+   ((response-must-not-include-body? response)
+    (error "response with this status code must not include body" response))
+   (else
     ;; check length; assert type; add other required fields?
     (values (let ((rlen (response-content-length response))
                   (blen (bytevector-length body)))
@@ -272,9 +276,12 @@ on the procedure being called at any particular time."
                          (error "bad content-length" rlen blen)))
                ((zero? blen) response)
                (else (extend-response response 'content-length blen))))
-            body))
-   (else
-    (error "unexpected body type"))))
+            (if (eq? (request-method request) 'HEAD)
+                ;; Responses to HEAD requests must not include bodies.
+                ;; We could raise an error here, but it seems more
+                ;; appropriate to just do something sensible.
+                #f
+                body)))))
 
 ;; -> response body state
 (define (handle-request handler request body state)


hooks/post-receive
-- 
GNU Guile