summaryrefslogtreecommitdiff
path: root/module/web/request.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-07-25 18:26:37 +0200
committerAndy Wingo <wingo@pobox.com>2011-07-25 18:26:37 +0200
commitab4bc85398a14b62b58694bab83c63be286b2fd5 (patch)
tree84bfe7b0b6064016bcfadb76ec95d07410654fe8 /module/web/request.scm
parentf29c300507da21a667f5b82e75300f8009eab9cc (diff)
parentf4b7d918eff9770f09893b023fd834f5c0bc33d1 (diff)
downloadguile-ab4bc85398a14b62b58694bab83c63be286b2fd5.tar.gz
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: GUILE-VERSION test-suite/tests/srfi-4.test
Diffstat (limited to 'module/web/request.scm')
-rw-r--r--module/web/request.scm40
1 files changed, 25 insertions, 15 deletions
diff --git a/module/web/request.scm b/module/web/request.scm
index 84119205f..c9204a4bf 100644
--- a/module/web/request.scm
+++ b/module/web/request.scm
@@ -151,21 +151,31 @@
(validate-headers? #t))
"Construct an HTTP request object. If @var{validate-headers?} is true,
the headers are each run through their respective validators."
- (cond
- ((not (and (pair? version)
- (non-negative-integer? (car version))
- (non-negative-integer? (cdr version))))
- (bad-request "Bad version: ~a" version))
- ((not (uri? uri))
- (bad-request "Bad uri: ~a" uri))
- ((and (not port) (memq method '(POST PUT)))
- (bad-request "Missing port for message ~a" method))
- ((not (list? meta))
- (bad-request "Bad metadata alist" meta))
- (else
- (if validate-headers?
- (validate-headers headers))))
- (make-request method uri version headers meta port))
+ (let ((needs-host? (and (equal? version '(1 . 1))
+ (not (assq-ref headers 'host)))))
+ (cond
+ ((not (and (pair? version)
+ (non-negative-integer? (car version))
+ (non-negative-integer? (cdr version))))
+ (bad-request "Bad version: ~a" version))
+ ((not (uri? uri))
+ (bad-request "Bad uri: ~a" uri))
+ ((and (not port) (memq method '(POST PUT)))
+ (bad-request "Missing port for message ~a" method))
+ ((not (list? meta))
+ (bad-request "Bad metadata alist" meta))
+ ((and needs-host? (not (uri-host uri)))
+ (bad-request "HTTP/1.1 request without Host header and no host in URI: ~a"
+ uri))
+ (else
+ (if validate-headers?
+ (validate-headers headers))))
+ (make-request method uri version
+ (if needs-host?
+ (acons 'host (cons (uri-host uri) (uri-port uri))
+ headers)
+ headers)
+ meta port)))
(define* (read-request port #:optional (meta '()))
"Read an HTTP request from @var{port}, optionally attaching the given