[Guile-commits] GNU Guile branch, master, updated. v2.1.0-16-g1208793

[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=12087939ed06cafa3c6467ff1462d80880f4d86b

The branch, master has been updated
       via  12087939ed06cafa3c6467ff1462d80880f4d86b (commit)
       via  164a78b355908d2149ef1ef266bec26d56b73365 (commit)
      from  e4c785f5df307d7119af8ec28160faf479ffcda0 (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 12087939ed06cafa3c6467ff1462d80880f4d86b
Merge: e4c785f 164a78b
Author: Andy Wingo <address@hidden>
Date:   Sun Feb 12 13:32:56 2012 +0100

    Merge remote-tracking branch 'origin/stable-2.0'

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

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