3 files changed, 85 insertions, 70 deletions

diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index fe1e120c5d2..a56d6f213d6 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,7 +25,7 @@
   #:export (with-http-server
             call-with-http-server
             %http-server-port
-            %http-server-socket
+            http-server-can-listen?
             %local-url))
 
 ;;; Commentary:
@@ -38,75 +38,85 @@
   ;; TCP port to use for the stub HTTP server.
   (make-parameter 9999))
 
+(define (open-http-server-socket)
+  "Return a listening socket for the web server.  It is useful to export it so
+that tests can check whether we succeeded opening the socket and tests skip if
+needed."
+  (catch 'system-error
+    (lambda ()
+      (let ((sock (socket PF_INET SOCK_STREAM 0)))
+        (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+        (bind sock
+              (make-socket-address AF_INET INADDR_LOOPBACK
+                                   (%http-server-port)))
+        sock))
+    (lambda args
+      (let ((err (system-error-errno args)))
+        (format (current-error-port)
+                "warning: cannot run Web server for tests: ~a~%"
+                (strerror err))
+        #f))))
+
+(define (http-server-can-listen?)
+  "Return #t if we managed to open a listening socket."
+  (and=> (open-http-server-socket)
+         (lambda (socket)
+           (close-port socket)
+           #t)))
+
 (define (%local-url)
   ;; URL to use for 'home-page' tests.
   (string-append "http://localhost:" (number->string (%http-server-port))
                  "/foo/bar"))
 
-(define %http-server-socket
-  ;; Listening socket for the web server.  It is useful to export it so that
-  ;; tests can check whether we succeeded opening the socket and tests skip if
-  ;; needed.
-  (delay
-    (catch 'system-error
-      (lambda ()
-        (let ((sock (socket PF_INET SOCK_STREAM 0)))
-          (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
-          (bind sock
-                (make-socket-address AF_INET INADDR_LOOPBACK
-                                     (%http-server-port)))
-          sock))
-      (lambda args
-        (let ((err (system-error-errno args)))
-          (format (current-error-port)
-                  "warning: cannot run Web server for tests: ~a~%"
-                  (strerror err))
-          #f)))))
-
-(define (http-write server client response body)
-  "Write RESPONSE."
-  (let* ((response (write-response response client))
-         (port     (response-port response)))
-    (cond
-     ((not body))                                 ;pass
-     (else
-      (write-response-body response body)))
-    (close-port port)
-    (quit #t)                                     ;exit the server thread
-    (values)))
+(define* (call-with-http-server code data thunk
+                                #:key (headers '()))
+  "Call THUNK with an HTTP server running and returning CODE and DATA (a
+string) on HTTP requests."
+  (define (http-write server client response body)
+    "Write RESPONSE."
+    (let* ((response (write-response response client))
+           (port     (response-port response)))
+      (cond
+       ((not body))                               ;pass
+       (else
+        (write-response-body response body)))
+      (close-port port)
+      (quit #t)                                   ;exit the server thread
+      (values)))
 
-;; Mutex and condition variable to synchronize with the HTTP server.
-(define %http-server-lock (make-mutex))
-(define %http-server-ready (make-condition-variable))
+  ;; Mutex and condition variable to synchronize with the HTTP server.
+  (define %http-server-lock (make-mutex))
+  (define %http-server-ready (make-condition-variable))
 
-(define (http-open . args)
-  "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
-  (with-mutex %http-server-lock
-    (let ((result (apply (@@ (web server http) http-open) args)))
-      (signal-condition-variable %http-server-ready)
-      result)))
+  (define (http-open . args)
+    "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
+    (with-mutex %http-server-lock
+      (let ((result (apply (@@ (web server http) http-open) args)))
+        (signal-condition-variable %http-server-ready)
+        result)))
 
-(define-server-impl stub-http-server
-  ;; Stripped-down version of Guile's built-in HTTP server.
-  http-open
-  (@@ (web server http) http-read)
-  http-write
-  (@@ (web server http) http-close))
+  (define-server-impl stub-http-server
+    ;; Stripped-down version of Guile's built-in HTTP server.
+    http-open
+    (@@ (web server http) http-read)
+    http-write
+    (@@ (web server http) http-close))
 
-(define (call-with-http-server code data thunk)
-  "Call THUNK with an HTTP server running and returning CODE and DATA (a
-string) on HTTP requests."
   (define (server-body)
     (define (handle request body)
       (values (build-response #:code code
-                              #:reason-phrase "Such is life")
+                              #:reason-phrase "Such is life"
+                              #:headers headers)
               data))
 
-    (catch 'quit
-      (lambda ()
-        (run-server handle stub-http-server
-                    `(#:socket ,(force %http-server-socket))))
-      (const #t)))
+    (let ((socket (open-http-server-socket)))
+      (catch 'quit
+        (lambda ()
+          (run-server handle stub-http-server
+                      `(#:socket ,socket)))
+        (lambda _
+          (close-port socket)))))
 
   (with-mutex %http-server-lock
     (let ((server (make-thread server-body)))
@@ -114,7 +124,12 @@ string) on HTTP requests."
       ;; Normally SERVER exits automatically once it has received a request.
       (thunk))))
 
-(define-syntax-rule (with-http-server code data body ...)
-  (call-with-http-server code data (lambda () body ...)))
+(define-syntax with-http-server
+  (syntax-rules ()
+    ((_ (code headers) data body ...)
+     (call-with-http-server code data (lambda () body ...)
+                            #:headers headers))
+    ((_ code data body ...)
+     (call-with-http-server code data (lambda () body ...)))))
 
 ;;; http.scm ends here
diff --git a/tests/derivations.scm b/tests/derivations.scm
index f3aad1b9067..36afd42d05c 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -222,7 +222,7 @@
       (build-derivations %store (list drv))
       #f)))
 
-(unless (force %http-server-socket)
+(unless (http-server-can-listen?)
   (test-skip 1))
 (test-assert "'download' built-in builder"
   (let ((text (random-text)))
@@ -238,7 +238,7 @@
                          get-string-all)
                        text))))))
 
-(unless (force %http-server-socket)
+(unless (http-server-can-listen?)
   (test-skip 1))
 (test-assert "'download' built-in builder, invalid hash"
   (with-http-server 200 "hello, world!"
@@ -253,7 +253,7 @@
         (build-derivations %store (list drv))
         #f))))
 
-(unless (force %http-server-socket)
+(unless (http-server-can-listen?)
   (test-skip 1))
 (test-assert "'download' built-in builder, not found"
   (with-http-server 404 "not found"
@@ -279,7 +279,7 @@
       (build-derivations %store (list drv))
       #f)))
 
-(unless (force %http-server-socket)
+(unless (http-server-can-listen?)
   (test-skip 1))
 (test-assert "'download' built-in builder, check mode"
   ;; Make sure rebuilding the 'builtin:download' derivation in check mode
diff --git a/tests/lint.scm b/tests/lint.scm
index 7610a91fd3b..d7254bc070d 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -388,7 +388,7 @@
         (check-home-page pkg)))
     "domain not found")))
 
-(test-skip (if (force %http-server-socket) 0 1))
+(test-skip (if (http-server-can-listen?) 0 1))
 (test-assert "home-page: Connection refused"
   (->bool
    (string-contains
@@ -399,7 +399,7 @@
         (check-home-page pkg)))
     "Connection refused")))
 
-(test-skip (if (force %http-server-socket) 0 1))
+(test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "home-page: 200"
   ""
   (with-warnings
@@ -409,7 +409,7 @@
                   (home-page (%local-url)))))
        (check-home-page pkg)))))
 
-(test-skip (if (force %http-server-socket) 0 1))
+(test-skip (if (http-server-can-listen?) 0 1))
 (test-assert "home-page: 200 but short length"
   (->bool
    (string-contains
@@ -421,7 +421,7 @@
           (check-home-page pkg))))
     "suspiciously small")))
 
-(test-skip (if (force %http-server-socket) 0 1))
+(test-skip (if (http-server-can-listen?) 0 1))
 (test-assert "home-page: 404"
   (->bool
    (string-contains
@@ -510,7 +510,7 @@
          (check-source-file-name pkg)))
      "file name should contain the package name"))))
 
-(test-skip (if (force %http-server-socket) 0 1))
+(test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "source: 200"
   ""
   (with-warnings
@@ -523,7 +523,7 @@
                             (sha256 %null-sha256))))))
        (check-source pkg)))))
 
-(test-skip (if (force %http-server-socket) 0 1))
+(test-skip (if (http-server-can-listen?) 0 1))
 (test-assert "source: 200 but short length"
   (->bool
    (string-contains
@@ -538,7 +538,7 @@
           (check-source pkg))))
     "suspiciously small")))
 
-(test-skip (if (force %http-server-socket) 0 1))
+(test-skip (if (http-server-can-listen?) 0 1))
 (test-assert "source: 404"
   (->bool
    (string-contains