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.

3 files changed, 31 insertions, 6 deletions

diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index 81c77dd0b..8bb99e21f 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.
-@c Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+@c 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
 
+@deffn {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.
+@end 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 f49a602f0..07e124539 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 b9bdef20c..5fc081c16 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)