mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
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:
parent
da28f04a5f
commit
3b5c4e6fb2
1 changed files with 32 additions and 26 deletions
|
@ -65,6 +65,26 @@ (define %make-http-root
|
|||
(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 @@ (define marionette
|
|||
(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 @@ (define test
|
|||
(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 @@ (define marionette
|
|||
|
||||
(test-equal "http-get"
|
||||
200
|
||||
(#$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)))))
|
||||
|
|
Loading…
Reference in a new issue