summaryrefslogtreecommitdiff
path: root/module/web/server.scm
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2013-09-13 00:24:04 -0400
committerMark H Weaver <mhw@netris.org>2013-09-13 00:24:04 -0400
commitc04bf4337b88ea45641065b7fe70dd0973b8ce94 (patch)
tree53e2d02477e40bd1da5a45cc3240ea1420691777 /module/web/server.scm
parent6871327742d3e1a0966aa8fed04c911311c12c2a (diff)
parent803c087e6b72f59ed9e529c1e1ca4fbe34e8eda5 (diff)
downloadguile-c04bf4337b88ea45641065b7fe70dd0973b8ce94.tar.gz
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: module/srfi/srfi-9.scm module/web/server.scm
Diffstat (limited to 'module/web/server.scm')
-rw-r--r--module/web/server.scm10
1 files changed, 4 insertions, 6 deletions
diff --git a/module/web/server.scm b/module/web/server.scm
index affc2e6b6..471bb98de 100644
--- a/module/web/server.scm
+++ b/module/web/server.scm
@@ -74,6 +74,7 @@
(define-module (web server)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module (web request)
@@ -167,11 +168,8 @@ values."
(define (extend-alist alist k v)
(let ((pair (assq k alist)))
(acons k v (if pair (delq pair alist) alist))))
- (let ((r (build-response #:version (response-version r)
- #:code (response-code r)
- #:headers
- (extend-alist (response-headers r) k v)
- #:port (response-port r))))
+ (let ((r (set-field r (response-headers)
+ (extend-alist (response-headers r) k v))))
(if (null? additional)
r
(apply extend-response r additional))))
@@ -234,6 +232,7 @@ on the procedure being called at any particular time."
(error "unexpected body type"))
((and (response-must-not-include-body? response)
body
+ ;; FIXME make this stricter: even an empty body should be prohibited.
(not (zero? (bytevector-length body))))
(error "response with this status code must not include body" response))
(else
@@ -244,7 +243,6 @@ on the procedure being called at any particular time."
(rlen (if (= rlen blen)
response
(error "bad content-length" rlen blen)))
- ((zero? blen) response)
(else (extend-response response 'content-length blen))))
(if (eq? (request-method request) 'HEAD)
;; Responses to HEAD requests must not include bodies.