mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
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>
This commit is contained in:
parent
3182539875
commit
c05ceaf2b6
5 changed files with 118 additions and 146 deletions
|
@ -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 @@ (define-module (guix tests http)
|
|||
#: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-module (guix tests http)
|
|||
|
||||
(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 @@ (define (open-http-server-socket)
|
|||
(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 @@ (define* (%local-url #:optional (port (%http-server-port)))
|
|||
(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 @@ (define (http-write server client response body)
|
|||
;; 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 @@ (define (handle request body)
|
|||
(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 @@ (define (handle request body)
|
|||
(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 ()
|
||||
|
|
|
@ -77,9 +77,6 @@ (define prefix-len (string-length dir))
|
|||
(lambda (e1 e2)
|
||||
(string<? (car e1) (car e2)))))
|
||||
|
||||
;; Avoid collisions with other tests.
|
||||
(%http-server-port 10500)
|
||||
|
||||
|
||||
(test-begin "derivations")
|
||||
|
||||
|
@ -205,8 +202,6 @@ (define prefix-len (string-length dir))
|
|||
(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 @@ (define prefix-len (string-length dir))
|
|||
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 @@ (define prefix-len (string-length dir))
|
|||
(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 @@ (define prefix-len (string-length dir))
|
|||
(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"
|
||||
|
|
|
@ -40,9 +40,6 @@ (define elpa-mock-archive
|
|||
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)
|
||||
|
|
179
tests/lint.scm
179
tests/lint.scm
|
@ -62,7 +62,6 @@ (define-module (test-lint)
|
|||
;; Test the linter.
|
||||
|
||||
;; Avoid collisions with other tests.
|
||||
(%http-server-port 9999)
|
||||
|
||||
(define %null-sha256
|
||||
;; SHA256 of the empty string.
|
||||
|
@ -500,16 +499,16 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
;; 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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
#: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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
'()
|
||||
(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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
(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 @@ (define (warning-contains? str warnings)
|
|||
(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\","
|
||||
|
|
|
@ -69,9 +69,6 @@ (define sxml
|
|||
(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))
|
||||
|
|
Loading…
Reference in a new issue