tests: Support multiple HTTP server instances.

* guix/tests/http.scm (%http-server-socket): Turn into...
(open-http-server-socket): ... this procedure.
(http-server-can-listen?): New procedure.
(http-write, %http-server-lock, %http-server-ready)
(http-open, stub-http-server): Move to 'call-with-http-server' body.
(call-with-http-server): Add #:headers parameter.
(with-http-server): Add an additional pattern with headers.
* tests/derivations.scm: Use (http-server-can-listen?) instead
of (force %http-server-socket).
* tests/lint.scm: Likewise.

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,16 +38,10 @@
   ;; TCP port to use for the stub HTTP server.
   (make-parameter 9999))
 
-(define (%local-url)
+(define (open-http-server-socket)
-  ;; URL to use for 'home-page' tests.
+  "Return a listening socket for the web server.  It is useful to export it so
-  (string-append "http://localhost:" (number->string (%http-server-port))
+that tests can check whether we succeeded opening the socket and tests skip if
-                 "/foo/bar"))
+needed."
-
-(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)))
@@ -61,9 +55,25 @@
         (format (current-error-port)
                 "warning: cannot run Web server for tests: ~a~%"
                 (strerror err))
-          #f)))))
+        #f))))
 
-(define (http-write server client response body)
+(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* (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)))
@@ -75,38 +85,38 @@
       (quit #t)                                   ;exit the server thread
       (values)))
 
-;; Mutex and condition variable to synchronize with the HTTP server.
+  ;; Mutex and condition variable to synchronize with the HTTP server.
-(define %http-server-lock (make-mutex))
+  (define %http-server-lock (make-mutex))
-(define %http-server-ready (make-condition-variable))
+  (define %http-server-ready (make-condition-variable))
 
-(define (http-open . args)
+  (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
+  (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))
 
+    (let ((socket (open-http-server-socket)))
       (catch 'quit
         (lambda ()
           (run-server handle stub-http-server
-                    `(#:socket ,(force %http-server-socket))))
+                      `(#:socket ,socket)))
-      (const #t)))
+        (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 ...)
+(define-syntax with-http-server
-  (call-with-http-server code data (lambda () body ...)))
+  (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

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

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