summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorMaxime Devos <maximedevos@telenet.be>2021-02-20 22:04:59 +0100
committerLudovic Courtès <ludo@gnu.org>2021-03-06 11:41:48 +0100
commitc05ceaf2b650d090cf39a048193505cb4e6bd257 (patch)
treee1468c7cd89392e1239a75ef057bbc3373f09646 /tests
parent3182539875a67f5989c73c3c654fe3138bbc275c (diff)
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>
Diffstat (limited to 'tests')
-rw-r--r--tests/derivations.scm41
-rw-r--r--tests/elpa.scm3
-rw-r--r--tests/lint.scm179
-rw-r--r--tests/texlive.scm3
4 files changed, 97 insertions, 129 deletions
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))