* [bug#46668] [PATCH]: tests: do not hard code HTTP ports
@ 2021-02-20 22:00 Maxime Devos
2021-03-01 15:46 ` Ludovic Courtès
0 siblings, 1 reply; 8+ messages in thread
From: Maxime Devos @ 2021-02-20 22:00 UTC (permalink / raw)
To: 46668
[-- Attachment #1.1: Type: text/plain, Size: 383 bytes --]
Hi Guix,
I encountered a ‘Cannot listen to port: is bound’ error
or something like that when testing some changes to the
substituter. I'm not sure yet what the cause is, but this
patch should eliminate some potential trouble, by not
hard-coding ports in tests that require a temporary http
server, and instead automatically assigning a free port.
Greetings,
Maxime
[-- Attachment #1.2: 0001-tests-do-not-hard-code-HTTP-ports.patch --]
[-- Type: text/x-patch, Size: 24455 bytes --]
From 6a5ea1f1a9155e23e46a38577adf74527ba50b2c Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Sat, 20 Feb 2021 22:04:59 +0100
Subject: [PATCH] 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.
---
guix/tests/http.scm | 39 +++++----
tests/derivations.scm | 41 ++++------
tests/elpa.scm | 3 -
tests/lint.scm | 179 +++++++++++++++++++-----------------------
tests/texlive.scm | 3 -
5 files changed, 119 insertions(+), 146 deletions(-)
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index 4119e9ce01..4ee60e8864 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.
;;;
@@ -23,10 +24,10 @@
#:use-module (web response)
#:use-module (srfi srfi-39)
#:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
#: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,9 @@ response and a string, or an HTTP response code and a string."
(set! responses rest)
(values response data))))
- (let ((socket (open-http-server-socket)))
+ (receive (socket port)
+ (open-http-server-socket)
+ (set! %http-real-server-port port)
(catch 'quit
(lambda ()
(run-server handle stub-http-server
@@ -134,7 +138,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)
-
\f
(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))
--
2.30.0
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply related [flat|nested] 8+ messages in thread* [bug#46668] [PATCH]: tests: do not hard code HTTP ports
2021-02-20 22:00 [bug#46668] [PATCH]: tests: do not hard code HTTP ports Maxime Devos
@ 2021-03-01 15:46 ` Ludovic Courtès
2021-03-01 17:23 ` Maxime Devos
0 siblings, 1 reply; 8+ messages in thread
From: Ludovic Courtès @ 2021-03-01 15:46 UTC (permalink / raw)
To: Maxime Devos; +Cc: 46668
Hi Maxime,
Maxime Devos <maximedevos@telenet.be> skribis:
> From 6a5ea1f1a9155e23e46a38577adf74527ba50b2c Mon Sep 17 00:00:00 2001
> From: Maxime Devos <maximedevos@telenet.be>
> Date: Sat, 20 Feb 2021 22:04:59 +0100
> Subject: [PATCH] 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.
Nice!
Some comments below.
> + #:use-module (ice-9 receive)
Please use (srfi srfi-71) instead, or (srfi srfi-11).
> -(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))))))
This hunk shouldn’t be here.
> -(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)))))
Likewise.
> -(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))
Likewise.
> -(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))
Likewise.
> -(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))
Likewise.
> -(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))))))
Likewise.
> -(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!"))
Likewise.
> -(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))
Likewise.
> -(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))
Likewise.
> -(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))
Likewise.
> -(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))
Likewise.
> -(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!"))
Likewise.
Could you send an updated patch?
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 8+ messages in thread* [bug#46668] [PATCH]: tests: do not hard code HTTP ports
2021-03-01 15:46 ` Ludovic Courtès
@ 2021-03-01 17:23 ` Maxime Devos
2021-03-01 21:40 ` Ludovic Courtès
0 siblings, 1 reply; 8+ messages in thread
From: Maxime Devos @ 2021-03-01 17:23 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 46668
[-- Attachment #1: Type: text/plain, Size: 11270 bytes --]
On Mon, 2021-03-01 at 16:46 +0100, Ludovic Courtès wrote:
> [...]
> Maxime Devos <maximedevos@telenet.be> skribis:
> > [...]
>
> Nice!
>
> Some comments below.
>
> > + #:use-module (ice-9 receive)
> Please use (srfi srfi-71) instead, or (srfi srfi-11).
Sure, will do.
You made some comments about ‘Hunks that shouldn't be here’ below.
I disagree. As my explanation is exactly the same for almost all hunks,
I've numbered them and the explanations.
Explanations:
A. (Hunk 2--12, i.e. all hunks except the first)
In some tests, the port number is hardcoded.
E.g., you'll see (test-equal "Some string http://localhost:9999" expression).
Removing the hard-coding is the whole point of this patch.
B. See later (hunk #1).
C. See later (hunk #2).
Hunk #1.
> > -(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))))))
>
> This hunk shouldn’t be here.
Explanation #B: If the hunk wasn't applied, then the first %local-url won't
work, as no web server is running yet (so we cannot yet know the port to
include in %local-url). I've added a check to %local-url to throw an
exception when %http-server-port is 0 to prevent silently returning
"http://localhost:0/foo/bar", which is rather meaningless.
The "let" and "with-http-server" forms needed to be restructured,
and the %local-url of the first server needed to be saved with a "let",
to use the URL of the correct HTTP server. There are two HTTP servers
in this test ...
Hunk #2.
> > -(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)))))
>
> Likewise.
Explanation #A. Also, explanation #C:
The "(parameterize ((%http-server-port 9999)) ...)"
form is required I think, as otherwise this test will try to connect to port 0,
which doesn't make much sense IMHO. However, a quick test in Guile on Linux
shows:
> (socket AF_INET SOCK_STREAM 0)
$1 = #<input-output: socket 13>
> (connect $1 AF_INET INADDR_LOOPBACK 0)
ice-9/boot-9.scm:1669:16: In procedure raise-exception:
In procedure connect: Connection refused
It seems like connecting to port 0 results in ‘Connection refused’, but this
connecting to port 0 seems a rather obscure to me, so I would rather not rely
on this, though your opinion could vary. (If we drop the parameterize,
then (%local-url) would need to be replaced with "http://localhost:0".)
-- And why hardcode the port in the first case? Well, there isn't exactly
a procedure for asking the OS to reserve a port, but not bind to it. Perhaps
something to figure out in a future patch ...
Hunk #3.
> > -(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))
>
> Likewise.
Explanation #A.
Hunk #4.
> > -(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))
>
> Likewise.
Explanation #A.
Hunk #5.
> > -(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))
>
> Likewise.
Explanation #A.
Hunk #6.
> > -(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))))))
>
> Likewise.
Explanation #A.
Hunk #7.
> > -(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!"))
>
> Likewise.
Explanation #A.
Hunk #8.
> > -(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))
>
> Likewise.
Explanation #A.
Hunk #9.
> > -(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))
>
> Likewise.
Explanation #A.
Hunk #10.
> > -(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))
>
> Likewise.
Explanation #A.
Hunk #11.
> > -(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))
>
> Likewise.
Explanation #A.
Hunk #12.
> > -(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!"))
>
> Likewise.
Explanation #A.
> Could you send an updated patch?
Is explanation #A clear, and does explanation #B make sense to you?
What do you think of explanation #C?
If you remove these hunks, you should see that the tests will fail
(make check TESTS=$tests).
Thanks,
Maxime.
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply [flat|nested] 8+ messages in thread* [bug#46668] [PATCH]: tests: do not hard code HTTP ports
2021-03-01 17:23 ` Maxime Devos
@ 2021-03-01 21:40 ` Ludovic Courtès
2021-03-02 8:15 ` Maxime Devos
0 siblings, 1 reply; 8+ messages in thread
From: Ludovic Courtès @ 2021-03-01 21:40 UTC (permalink / raw)
To: Maxime Devos; +Cc: 46668
Hi,
Maxime Devos <maximedevos@telenet.be> skribis:
> You made some comments about ‘Hunks that shouldn't be here’ below.
> I disagree. As my explanation is exactly the same for almost all hunks,
> I've numbered them and the explanations.
>
> Explanations:
>
> A. (Hunk 2--12, i.e. all hunks except the first)
> In some tests, the port number is hardcoded.
> E.g., you'll see (test-equal "Some string http://localhost:9999" expression).
> Removing the hard-coding is the whole point of this patch.
> B. See later (hunk #1).
> C. See later (hunk #2).
Oooh I see, my bad! I thought ‘test-equal’ & co. were vanishing, when
in fact they were just moved down. Your explanations make perfect
sense.
IWBN to keep the (test-xyz …) forms at the top level as much as possible
(it’s more convenient, especially when working from Geiser); when it’s
not possible, changes like you did are the right thing.
Thank you, and apologies for the confusion!
Ludo’.
^ permalink raw reply [flat|nested] 8+ messages in thread
* [bug#46668] [PATCH]: tests: do not hard code HTTP ports
2021-03-01 21:40 ` Ludovic Courtès
@ 2021-03-02 8:15 ` Maxime Devos
2021-03-02 21:29 ` Ludovic Courtès
0 siblings, 1 reply; 8+ messages in thread
From: Maxime Devos @ 2021-03-02 8:15 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 46668
[-- Attachment #1.1: Type: text/plain, Size: 235 bytes --]
On Mon, 2021-03-01 at 22:40 +0100, Ludovic Courtès wrote:
> [...]
> Thank you, and apologies for the confusion!
>
> Ludo’.
No problem! The revised patch that uses "let-values" instead of "receive"
is attached.
Maxime.
[-- Attachment #1.2: 0001-tests-do-not-hard-code-HTTP-ports.patch --]
[-- Type: text/x-patch, Size: 24515 bytes --]
From 933cb85de0f50c54190e7c60420bef5245a3f2ed Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Sat, 20 Feb 2021 22:04:59 +0100
Subject: [PATCH] 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.
---
guix/tests/http.scm | 38 +++++----
tests/derivations.scm | 41 ++++------
tests/elpa.scm | 3 -
tests/lint.scm | 179 +++++++++++++++++++-----------------------
tests/texlive.scm | 3 -
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)
-
\f
(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))
--
2.30.0
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply related [flat|nested] 8+ messages in thread* [bug#46668] [PATCH]: tests: do not hard code HTTP ports
2021-03-02 8:15 ` Maxime Devos
@ 2021-03-02 21:29 ` Ludovic Courtès
2021-03-02 21:49 ` Maxime Devos
0 siblings, 1 reply; 8+ messages in thread
From: Ludovic Courtès @ 2021-03-02 21:29 UTC (permalink / raw)
To: Maxime Devos; +Cc: 46668
Hi,
Maxime Devos <maximedevos@telenet.be> skribis:
> From 933cb85de0f50c54190e7c60420bef5245a3f2ed Mon Sep 17 00:00:00 2001
> From: Maxime Devos <maximedevos@telenet.be>
> Date: Sat, 20 Feb 2021 22:04:59 +0100
> Subject: [PATCH] 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.
Minor comment but nothing blocking:
> + (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))))))
It’s a tad confusing that the second ‘with-http-server’ is now nested;
it shouldn’t change the semantics though, so it’s okay.
Anyway, you’re welcome to push to ‘master’ if “make check” agrees. :-)
Thanks again!
Ludo’.
^ permalink raw reply [flat|nested] 8+ messages in thread* [bug#46668] [PATCH]: tests: do not hard code HTTP ports
2021-03-02 21:29 ` Ludovic Courtès
@ 2021-03-02 21:49 ` Maxime Devos
2021-03-06 10:23 ` bug#46668: " Ludovic Courtès
0 siblings, 1 reply; 8+ messages in thread
From: Maxime Devos @ 2021-03-02 21:49 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 46668
[-- Attachment #1: Type: text/plain, Size: 540 bytes --]
On Tue, 2021-03-02 at 22:29 +0100, Ludovic Courtès wrote:
>
> [...]
> It’s a tad confusing that the second ‘with-http-server’ is now nested;
> it shouldn’t change the semantics though, so it’s okay.
>
> Anyway, you’re welcome to push to ‘master’ if “make check” agrees. :-)
I do not have commit access, and I haven't applied for commit access either,
so you will have to push it yourself. "make check" agreed when I wrote the
patch, though perhaps check it yourself just in case.
Greetings,
Maxime.
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply [flat|nested] 8+ messages in thread
* bug#46668: [PATCH]: tests: do not hard code HTTP ports
2021-03-02 21:49 ` Maxime Devos
@ 2021-03-06 10:23 ` Ludovic Courtès
0 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2021-03-06 10:23 UTC (permalink / raw)
To: Maxime Devos; +Cc: 46668-done
Hi Maxime,
Maxime Devos <maximedevos@telenet.be> skribis:
> On Tue, 2021-03-02 at 22:29 +0100, Ludovic Courtès wrote:
>>
>> [...]
>> It’s a tad confusing that the second ‘with-http-server’ is now nested;
>> it shouldn’t change the semantics though, so it’s okay.
>>
>> Anyway, you’re welcome to push to ‘master’ if “make check” agrees. :-)
>
> I do not have commit access, and I haven't applied for commit access either,
> so you will have to push it yourself.
Oops, my bad; applied now, thanks!
Ludo’.
^ permalink raw reply [flat|nested] 8+ messages in thread
end of thread, other threads:[~2021-03-06 10:25 UTC | newest]
Thread overview: 8+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2021-02-20 22:00 [bug#46668] [PATCH]: tests: do not hard code HTTP ports Maxime Devos
2021-03-01 15:46 ` Ludovic Courtès
2021-03-01 17:23 ` Maxime Devos
2021-03-01 21:40 ` Ludovic Courtès
2021-03-02 8:15 ` Maxime Devos
2021-03-02 21:29 ` Ludovic Courtès
2021-03-02 21:49 ` Maxime Devos
2021-03-06 10:23 ` bug#46668: " Ludovic Courtès
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).