tests: do not hard code HTTP ports

Previously, test cases could fail if some process was listening
at a hard-coded port.  This patch eliminates most of these potential
failures, by automatically assigning an unbound port.  This should
allow for building multiple guix trees in parallel outside a build
container, though this is currently untested.

The test "home-page: Connection refused" in tests/lint.scm still
hardcodes port 9999, however.

* guix/tests/http.scm
  (http-server-can-listen?): remove now unused procedure.
  (%http-server-port): default to port 0, meaning the OS
  will automatically choose a port.
  (open-http-server-socket): remove the false statement claiming
  this procedure is exported and also return the allocated port
  number.
  (%local-url): raise an error if the port is obviously unbound.
  (call-with-http-server): set %http-server-port to the allocated
  port while the thunk is called.
* tests/derivations.scm: adjust test cases to use automatically
  assign a port.  As there is no risk of a port conflict now,
  do not make any tests conditional upon 'http-server-can-listen?'
  anymore.
* tests/elpa.scm: likewise.
* tests/lint.scm: likewise, and add a TODO comment about a port
  that is still hard-coded.
* tests/texlive.scm: likewise.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

5 files changed, 118 insertions, 146 deletions

diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index 4119e9ce01..8f50eaefca 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,12 +22,12 @@
   #:use-module (web server)
   #:use-module (web server http)
   #:use-module (web response)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-39)
   #:use-module (ice-9 match)
   #:export (with-http-server
             call-with-http-server
             %http-server-port
-            http-server-can-listen?
             %local-url))
 
 ;;; Commentary:
@@ -37,12 +38,13 @@
 
 (define %http-server-port
   ;; TCP port to use for the stub HTTP server.
-  (make-parameter 9999))
+  ;; If 0, the OS will automatically choose
+  ;; a port.
+  (make-parameter 0))
 
 (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."
+  "Return a listening socket for the web server and the port
+actually listened at (in case %http-server-port was 0)."
   (catch 'system-error
     (lambda ()
       (let ((sock (socket PF_INET SOCK_STREAM 0)))
@@ -50,22 +52,18 @@ needed."
         (bind sock
               (make-socket-address AF_INET INADDR_LOOPBACK
                                    (%http-server-port)))
-        sock))
+        (values sock
+                (sockaddr:port (getsockname 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)))
+        (values #f #f)))))
 
 (define* (%local-url #:optional (port (%http-server-port)))
+  (when (= port 0)
+    (error "no web server is running!"))
   ;; URL to use for 'home-page' tests.
   (string-append "http://localhost:" (number->string port)
                  "/foo/bar"))
@@ -73,7 +71,10 @@ needed."
 (define* (call-with-http-server responses+data thunk)
   "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
 requests.  Each element of RESPONSES+DATA must be a tuple containing a
-response and a string, or an HTTP response code and a string."
+response and a string, or an HTTP response code and a string.
+
+%http-server-port will be set to the port listened at
+The port listened at will be set for the dynamic extent of THUNK."
   (define responses
     (map (match-lambda
            (((? response? response) data)
@@ -100,6 +101,7 @@ response and a string, or an HTTP response code and a string."
   ;; 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-real-server-port #f)
 
   (define (http-open . args)
     "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
@@ -122,7 +124,8 @@ response and a string, or an HTTP response code and a string."
          (set! responses rest)
          (values response data))))
 
-    (let ((socket (open-http-server-socket)))
+    (let-values (((socket port) (open-http-server-socket)))
+      (set! %http-real-server-port port)
       (catch 'quit
         (lambda ()
           (run-server handle stub-http-server
@@ -134,7 +137,8 @@ response and a string, or an HTTP response code and a string."
     (let ((server (make-thread server-body)))
       (wait-condition-variable %http-server-ready %http-server-lock)
       ;; Normally SERVER exits automatically once it has received a request.
-      (thunk))))
+      (parameterize ((%http-server-port %http-real-server-port))
+        (thunk)))))
 
 (define-syntax with-http-server
   (syntax-rules ()
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 9f1104a887..cd165d1be6 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -77,9 +77,6 @@
         (lambda (e1 e2)
           (string<? (car e1) (car e2)))))
 
-;; Avoid collisions with other tests.
-(%http-server-port 10500)
-
 
 (test-begin "derivations")
 
@@ -205,8 +202,6 @@
       (build-derivations %store (list drv))
       #f)))
 
-(unless (http-server-can-listen?)
-  (test-skip 1))
 (test-assert "'download' built-in builder"
   (let ((text (random-text)))
     (with-http-server `((200 ,text))
@@ -221,8 +216,6 @@
                          get-string-all)
                        text))))))
 
-(unless (http-server-can-listen?)
-  (test-skip 1))
 (test-assert "'download' built-in builder, invalid hash"
   (with-http-server `((200 "hello, world!"))
     (let* ((drv (derivation %store "world"
@@ -236,8 +229,6 @@
         (build-derivations %store (list drv))
         #f))))
 
-(unless (http-server-can-listen?)
-  (test-skip 1))
 (test-assert "'download' built-in builder, not found"
   (with-http-server '((404 "not found"))
     (let* ((drv (derivation %store "will-never-be-found"
@@ -262,26 +253,24 @@
       (build-derivations %store (list drv))
       #f)))
 
-(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
   ;; works.  See <http://bugs.gnu.org/25089>.
-  (let* ((text (random-text))
-         (drv (derivation %store "world"
-                          "builtin:download" '()
-                          #:env-vars `(("url"
-                                        . ,(object->string (%local-url))))
-                          #:hash-algo 'sha256
-                          #:hash (gcrypt:sha256 (string->utf8 text)))))
-    (and (with-http-server `((200 ,text))
-           (build-derivations %store (list drv)))
-         (with-http-server `((200 ,text))
-           (build-derivations %store (list drv)
-                              (build-mode check)))
-         (string=? (call-with-input-file (derivation->output-path drv)
-                     get-string-all)
-                   text))))
+  (let* ((text (random-text)))
+    (with-http-server `((200 ,text))
+      (let ((drv (derivation %store "world"
+                             "builtin:download" '()
+                             #:env-vars `(("url"
+                                           . ,(object->string (%local-url))))
+                             #:hash-algo 'sha256
+                             #:hash (gcrypt:sha256 (string->utf8 text)))))
+        (and drv (build-derivations %store (list drv))
+             (with-http-server `((200 ,text))
+               (build-derivations %store (list drv)
+                                  (build-mode check)))
+             (string=? (call-with-input-file (derivation->output-path drv)
+                         get-string-all)
+                       text))))))
 
 (test-equal "derivation-name"
   "foo-0.0"
diff --git a/tests/elpa.scm b/tests/elpa.scm
index a008cf993c..01ef948b2e 100644
--- a/tests/elpa.scm
+++ b/tests/elpa.scm
@@ -40,9 +40,6 @@
              nil "Integrated environment for *TeX*" tar
              ((:url . "http://www.gnu.org/software/auctex/"))])))
 
-;; Avoid collisions with other tests.
-(%http-server-port 10300)
-
 (test-begin "elpa")
 
 (define (eval-test-with-elpa pkg)
diff --git a/tests/lint.scm b/tests/lint.scm
index 7c24611934..b92053fd5f 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -62,7 +62,6 @@
 ;; Test the linter.
 
 ;; Avoid collisions with other tests.
-(%http-server-port 9999)
 
 (define %null-sha256
   ;; SHA256 of the empty string.
@@ -500,16 +499,16 @@
                (home-page "http://does-not-exist"))))
     (warning-contains? "domain not found" (check-home-page pkg))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
-(test-equal "home-page: Connection refused"
-  "URI http://localhost:9999/foo/bar unreachable: Connection refused"
-  (let ((pkg (package
-               (inherit (dummy-package "x"))
-               (home-page (%local-url)))))
-    (single-lint-warning-message
-     (check-home-page pkg))))
+(parameterize ((%http-server-port 9999))
+  ;; TODO skip this test if some process is currently listening at 9999
+  (test-equal "home-page: Connection refused"
+    "URI http://localhost:9999/foo/bar unreachable: Connection refused"
+    (let ((pkg (package
+                 (inherit (dummy-package "x"))
+                 (home-page (%local-url)))))
+      (single-lint-warning-message
+       (check-home-page pkg)))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "home-page: 200"
   '()
   (with-http-server `((200 ,%long-string))
@@ -518,10 +517,10 @@
                  (home-page (%local-url)))))
       (check-home-page pkg))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
-(test-equal "home-page: 200 but short length"
-  "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)"
-  (with-http-server `((200 "This is too small."))
+(with-http-server `((200 "This is too small."))
+  (test-equal "home-page: 200 but short length"
+    (format #f "URI ~a returned suspiciously small file (18 bytes)"
+            (%local-url))
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (home-page (%local-url)))))
@@ -529,54 +528,51 @@
       (single-lint-warning-message
        (check-home-page pkg)))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
-(test-equal "home-page: 404"
-  "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")"
-  (with-http-server `((404 ,%long-string))
+(with-http-server `((404 ,%long-string))
+  (test-equal "home-page: 404"
+    (format #f "URI ~a not reachable: 404 (\"Such is life\")" (%local-url))
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (home-page (%local-url)))))
       (single-lint-warning-message
        (check-home-page pkg)))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
-(test-equal "home-page: 301, invalid"
-  "invalid permanent redirect from http://localhost:9999/foo/bar"
-  (with-http-server `((301 ,%long-string))
+(with-http-server `((301 ,%long-string))
+  (test-equal "home-page: 301, invalid"
+    (format #f "invalid permanent redirect from ~a" (%local-url))
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (home-page (%local-url)))))
       (single-lint-warning-message
        (check-home-page pkg)))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
-(test-equal "home-page: 301 -> 200"
-  "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
-  (with-http-server `((200 ,%long-string))
-    (let* ((initial-url (%local-url))
-           (redirect    (build-response #:code 301
-                                        #:headers
-                                        `((location
-                                           . ,(string->uri initial-url))))))
-      (parameterize ((%http-server-port (+ 1 (%http-server-port))))
-        (with-http-server `((,redirect ""))
+(with-http-server `((200 ,%long-string))
+  (let* ((initial-url (%local-url))
+         (redirect (build-response #:code 301
+                                   #:headers
+                                   `((location
+                                      . ,(string->uri initial-url))))))
+    (parameterize ((%http-server-port 0))
+      (with-http-server `((,redirect ""))
+        (test-equal "home-page: 301 -> 200"
+          (format #f "permanent redirect from ~a to ~a"
+                  (%local-url) initial-url)
           (let ((pkg (package
                        (inherit (dummy-package "x"))
                        (home-page (%local-url)))))
             (single-lint-warning-message
              (check-home-page pkg))))))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
-(test-equal "home-page: 301 -> 404"
-  "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
-  (with-http-server '((404 "booh!"))
-    (let* ((initial-url (%local-url))
-           (redirect    (build-response #:code 301
-                                        #:headers
-                                        `((location
-                                           . ,(string->uri initial-url))))))
-      (parameterize ((%http-server-port (+ 1 (%http-server-port))))
-        (with-http-server `((,redirect ""))
+(with-http-server `((404 "booh!"))
+  (let* ((initial-url (%local-url))
+         (redirect    (build-response #:code 301
+                                      #:headers
+                                      `((location
+                                         . ,(string->uri initial-url))))))
+    (parameterize ((%http-server-port 0))
+      (with-http-server `((,redirect ""))
+        (test-equal "home-page: 301 -> 404"
+          (format #f "URI ~a not reachable: 404 (\"Such is life\")" (%local-url))
           (let ((pkg (package
                        (inherit (dummy-package "x"))
                        (home-page (%local-url)))))
@@ -706,7 +702,6 @@
                                (sha256 %null-sha256))))))
     (check-source-unstable-tarball pkg)))
 
-(test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "source: 200"
   '()
   (with-http-server `((200 ,%long-string))
@@ -718,10 +713,10 @@
                            (sha256 %null-sha256))))))
       (check-source pkg))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
-(test-equal "source: 200 but short length"
-  "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)"
-  (with-http-server '((200 "This is too small."))
+(with-http-server '((200 "This is too small."))
+  (test-equal "source: 200 but short length"
+    (format #f "URI ~a returned suspiciously small file (18 bytes)"
+            (%local-url))
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (source (origin
@@ -733,10 +728,10 @@
           (and (? lint-warning?) second-warning))
          (lint-warning-message second-warning))))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
-(test-equal "source: 404"
-  "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")"
-  (with-http-server `((404 ,%long-string))
+(with-http-server `((404 ,%long-string))
+  (test-equal "source: 404"
+    (format #f "URI ~a not reachable: 404 (\"Such is life\")"
+            (%local-url))
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (source (origin
@@ -748,7 +743,6 @@
           (and (? lint-warning?) second-warning))
          (lint-warning-message second-warning))))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "source: 404 and 200"
   '()
   (with-http-server `((404 ,%long-string))
@@ -765,17 +759,17 @@
             ;; list.
             (check-source pkg)))))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
-(test-equal "source: 301 -> 200"
-  "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
-  (with-http-server `((200 ,%long-string))
-    (let* ((initial-url (%local-url))
-           (redirect    (build-response #:code 301
-                                        #:headers
-                                        `((location
-                                           . ,(string->uri initial-url))))))
-      (parameterize ((%http-server-port (+ 1 (%http-server-port))))
-        (with-http-server `((,redirect ""))
+(with-http-server `((200 ,%long-string))
+  (let* ((initial-url (%local-url))
+         (redirect    (build-response #:code 301
+                                      #:headers
+                                      `((location
+                                         . ,(string->uri initial-url))))))
+    (parameterize ((%http-server-port 0))
+      (with-http-server `((,redirect ""))
+        (test-equal "source: 301 -> 200"
+          (format #f "permanent redirect from ~a to ~a"
+                  (%local-url) initial-url)
           (let ((pkg (package
                        (inherit (dummy-package "x"))
                        (source (origin
@@ -787,17 +781,17 @@
                 (and (? lint-warning?) second-warning))
                (lint-warning-message second-warning)))))))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
-(test-equal "source, git-reference: 301 -> 200"
-  "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
-  (with-http-server `((200 ,%long-string))
-    (let* ((initial-url (%local-url))
-           (redirect    (build-response #:code 301
-                                        #:headers
-                                        `((location
-                                           . ,(string->uri initial-url))))))
-      (parameterize ((%http-server-port (+ 1 (%http-server-port))))
-        (with-http-server `((,redirect ""))
+(with-http-server `((200 ,%long-string))
+  (let* ((initial-url (%local-url))
+         (redirect    (build-response #:code 301
+                                      #:headers
+                                      `((location
+                                         . ,(string->uri initial-url))))))
+    (parameterize ((%http-server-port 0))
+      (with-http-server `((,redirect ""))
+        (test-equal "source, git-reference: 301 -> 200"
+          (format #f "permanent redirect from ~a to ~a"
+                  (%local-url) initial-url)
           (let ((pkg (dummy-package
                       "x"
                       (source (origin
@@ -807,17 +801,17 @@
                                 (sha256 %null-sha256))))))
             (single-lint-warning-message (check-source pkg))))))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
-(test-equal "source: 301 -> 404"
-  "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
-  (with-http-server '((404 "booh!"))
-    (let* ((initial-url (%local-url))
-           (redirect    (build-response #:code 301
-                                        #:headers
-                                        `((location
-                                           . ,(string->uri initial-url))))))
-      (parameterize ((%http-server-port (+ 1 (%http-server-port))))
-        (with-http-server `((,redirect ""))
+(with-http-server '((404 "booh!"))
+  (let* ((initial-url (%local-url))
+         (redirect    (build-response #:code 301
+                                      #:headers
+                                      `((location
+                                         . ,(string->uri initial-url))))))
+    (parameterize ((%http-server-port 0))
+      (with-http-server `((,redirect ""))
+        (test-equal "source: 301 -> 404"
+          (format #f "URI ~a not reachable: 404 (\"Such is life\")"
+                  (%local-url))
           (let ((pkg (package
                        (inherit (dummy-package "x"))
                        (source (origin
@@ -847,7 +841,6 @@
     (single-lint-warning-message
      (check-mirror-url (dummy-package "x" (source source))))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "github-url"
   '()
   (with-http-server `((200 ,%long-string))
@@ -859,7 +852,6 @@
                            (sha256 %null-sha256)))))))
 
 (let ((github-url "https://github.com/foo/bar/bar-1.0.tar.gz"))
-  (test-skip (if (http-server-can-listen?) 0 1))
   (test-equal "github-url: one suggestion"
     (string-append
      "URL should be '" github-url "'")
@@ -873,7 +865,7 @@
                                             #:headers
                                             `((location
                                                . ,(string->uri initial-url))))))
-          (parameterize ((%http-server-port (+ 1 (%http-server-port))))
+          (parameterize ((%http-server-port 0))
             (with-http-server `((,redirect ""))
               (single-lint-warning-message
                (check-github-url
@@ -883,7 +875,6 @@
                                       (uri (%local-url))
                                       (sha256 %null-sha256))))))))))))
 
-  (test-skip (if (http-server-can-listen?) 0 1))
   (test-equal "github-url: already the correct github url"
     '()
     (check-github-url
@@ -1007,7 +998,6 @@
   '()
   (check-formatting (dummy-package "x")))
 
-(test-skip (if (http-server-can-listen?) 0 1))
 (test-assert "archival: missing content"
   (let* ((origin   (origin
                      (method url-fetch)
@@ -1019,7 +1009,6 @@
                                                       (source origin)))))))
     (warning-contains? "not archived" warnings)))
 
-(test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "archival: content available"
   '()
   (let* ((origin   (origin
@@ -1033,7 +1022,6 @@
       (parameterize ((%swh-base-url (%local-url)))
         (check-archival (dummy-package "x" (source origin)))))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
 (test-assert "archival: missing revision"
   (let* ((origin   (origin
                      (method git-fetch)
@@ -1053,7 +1041,6 @@
                        (check-archival (dummy-package "x" (source origin)))))))
     (warning-contains? "scheduled" warnings)))
 
-(test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "archival: revision available"
   '()
   (let* ((origin   (origin
@@ -1069,7 +1056,6 @@
       (parameterize ((%swh-base-url (%local-url)))
         (check-archival (dummy-package "x" (source origin)))))))
 
-(test-skip (if (http-server-can-listen?) 0 1))
 (test-assert "archival: rate limit reached"
   ;; We should get a single warning stating that the rate limit was reached,
   ;; and nothing more, in particular no other HTTP requests.
@@ -1091,7 +1077,6 @@
     (string-contains (single-lint-warning-message warnings)
                      "rate limit reached")))
 
-(test-skip (if (http-server-can-listen?) 0 1))
 (test-assert "haskell-stackage"
   (let* ((stackage (string-append "{ \"packages\": [{"
                                   "    \"name\":\"x\","
diff --git a/tests/texlive.scm b/tests/texlive.scm
index f7e5515c4c..a6f08046a8 100644
--- a/tests/texlive.scm
+++ b/tests/texlive.scm
@@ -69,9 +69,6 @@
                  (keyval (@ (value "tests") (key "topic")))
                  "\n  null\n")))
 
-;; Avoid collisions with other tests.
-(%http-server-port 10200)
-
 (test-equal "fetch-sxml: returns SXML for valid XML"
   sxml
   (with-http-server `((200 ,xml))