01/02: tests: patchwork: Fix it.

[guix-commits]

mothacehe pushed a commit to branch master
in repository guix.

commit 3b5c4e6fb285e29a6d348732852e0407c28e30f4
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Sun Apr 18 09:47:44 2021 +0200

    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.
---
 gnu/tests/web.scm | 58 ++++++++++++++++++++++++++++++-------------------------
 1 file changed, 32 insertions(+), 26 deletions(-)

diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm
index 7f4518a..2a6dedc 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)))))