ensure presence of Host header in HTTP/1.1 requests

* module/web/request.scm (build-request): Make sure that HTTP/1.1
  requests have the Host header set, per RFC 2616 section 9.

* test-suite/tests/web-request.test ("example-1"): Add test.

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

test-suite/tests/web-request.test

@@ -47,6 +47,10 @@ Accept-Language: en-gb, en;q=0.9\r
         (set! r (read-request (open-input-string example-1)))
         (request? r)))
     
+    (pass-if (equal?
+              (request-host (build-request (string->uri "http://www.gnu.org/")))
+              "www.gnu.org"))
+    
     (pass-if (equal? (request-method r) 'GET))
     
     (pass-if (equal? (request-uri r) (build-uri 'http #:path "/qux")))