aboutsummaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorMathieu Othacehe <othacehe@gnu.org>2021-04-18 09:47:44 +0200
committerMathieu Othacehe <othacehe@gnu.org>2021-04-18 09:52:18 +0200
commit3b5c4e6fb285e29a6d348732852e0407c28e30f4 (patch)
tree79165a92e33e930584201bc34b63f687c5301fdd /gnu
parentda28f04a5fa2dba2e153c3af0908ab76c98b6811 (diff)
downloadguix-3b5c4e6fb285e29a6d348732852e0407c28e30f4.tar
guix-3b5c4e6fb285e29a6d348732852e0407c28e30f4.tar.gz
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.
Diffstat (limited to 'gnu')
-rw-r--r--gnu/tests/web.scm58
1 files changed, 32 insertions, 26 deletions
diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm
index 7f4518acd2..2a6dedc637 100644
--- a/gnu/tests/web.scm
+++ b/gnu/tests/web.scm
@@ -65,6 +65,26 @@
(lambda (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))
"Run tests in %NGINX-OS, which has nginx running and listening on
HTTP-PORT."
@@ -472,28 +492,9 @@ HTTP-PORT."
(start-service 'tailon))
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"
200
- (retry-on-error
+ (#$retry-on-error
(lambda ()
(let-values (((response text)
(http-get #$(format
@@ -613,6 +614,7 @@ HTTP-PORT."
(with-imported-modules '((gnu build marionette))
#~(begin
(use-modules (srfi srfi-11) (srfi srfi-64)
+ (ice-9 match)
(gnu build marionette)
(web uri)
(web client)
@@ -647,12 +649,16 @@ HTTP-PORT."
(test-equal "http-get"
200
- (let-values
- (((response text)
- (http-get #$(simple-format
- #f "http://localhost:~A/" forwarded-port)
- #:decode-body? #t)))
- (response-code response)))
+ (#$retry-on-error
+ (lambda ()
+ (let-values
+ (((response text)
+ (http-get #$(simple-format
+ #f "http://localhost:~A/" forwarded-port)
+ #:decode-body? #t)))
+ (response-code response)))
+ #:times 10
+ #:delay 5))
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))