tests: patchwork: Fix it.

The "http-get" test is sometimes failing because the Web server is not yet
initialized and returns the 500 error code.

Use the retry-or-error procedure, like in the tailon test to do a few retries.

* gnu/tests/web.scm (run-tailon-test): Move "retry-or-error" procedure to the
top level and adapt its call.
(run-patchwork-test): Use it.
This commit is contained in:
Mathieu Othacehe 2021-04-18 09:47:44 +02:00
parent da28f04a5f
commit 3b5c4e6fb2
No known key found for this signature in database
GPG key ID: 8354763531769CA6

View file

@ -65,6 +65,26 @@ (define %make-http-root
(lambda (port) (lambda (port)
(display #$%index.html-contents port))))) (display #$%index.html-contents port)))))
(define retry-on-error
#~(lambda* (f #:key times delay)
(let loop ((attempt 1))
(match (catch
#t
(lambda ()
(cons #t
(f)))
(lambda args
(cons #f
args)))
((#t . return-value)
return-value)
((#f . error-args)
(if (>= attempt times)
error-args
(begin
(sleep delay)
(loop (+ 1 attempt)))))))))
(define* (run-webserver-test name test-os #:key (log-file #f) (http-port 8080)) (define* (run-webserver-test name test-os #:key (log-file #f) (http-port 8080))
"Run tests in %NGINX-OS, which has nginx running and listening on "Run tests in %NGINX-OS, which has nginx running and listening on
HTTP-PORT." HTTP-PORT."
@ -472,28 +492,9 @@ (define marionette
(start-service 'tailon)) (start-service 'tailon))
marionette)) marionette))
(define* (retry-on-error f #:key times delay)
(let loop ((attempt 1))
(match (catch
#t
(lambda ()
(cons #t
(f)))
(lambda args
(cons #f
args)))
((#t . return-value)
return-value)
((#f . error-args)
(if (>= attempt times)
error-args
(begin
(sleep delay)
(loop (+ 1 attempt))))))))
(test-equal "http-get" (test-equal "http-get"
200 200
(retry-on-error (#$retry-on-error
(lambda () (lambda ()
(let-values (((response text) (let-values (((response text)
(http-get #$(format (http-get #$(format
@ -613,6 +614,7 @@ (define test
(with-imported-modules '((gnu build marionette)) (with-imported-modules '((gnu build marionette))
#~(begin #~(begin
(use-modules (srfi srfi-11) (srfi srfi-64) (use-modules (srfi srfi-11) (srfi srfi-64)
(ice-9 match)
(gnu build marionette) (gnu build marionette)
(web uri) (web uri)
(web client) (web client)
@ -647,12 +649,16 @@ (define marionette
(test-equal "http-get" (test-equal "http-get"
200 200
(let-values (#$retry-on-error
(((response text) (lambda ()
(http-get #$(simple-format (let-values
#f "http://localhost:~A/" forwarded-port) (((response text)
#:decode-body? #t))) (http-get #$(simple-format
(response-code response))) #f "http://localhost:~A/" forwarded-port)
#:decode-body? #t)))
(response-code response)))
#:times 10
#:delay 5))
(test-end) (test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))) (exit (= (test-runner-fail-count (test-runner-current)) 0)))))