[bug#53389] [PATCH 1/9] tests: Support arbitrary HTTP request handlers.

[Maxime Devos]

An incompatible change to with-http-server has been made: it now
also exits when the thunk exits.  This change allows implementing
with-http-server*.  It also keeps threads from lingering if the
thunk doesn't access all of RESPONSES+DATA.

Usually, this change is fine, but it does not interact nicely with
monads in tests/challenge, so a variant with-http-server/lingering
preserving the old behaviour has been defined.

* guix/tests/http.scm
  (call-with-http-server): Extract most functionality to ...
  (call-with-http-server*): ... this new procedure.  Also stop the
  server thread after 'thunk' returns instead of when the last response
  has been sent unless requested not to.
  (with-http-server/keep-lingering): New macro.
* tests/challenge.scm (call-mismatch-test): Use the 'keep-lingering'
  variant of 'with-http-server'.
---
 guix/tests/http.scm | 96 +++++++++++++++++++++++++++++++--------------
 tests/challenge.scm | 24 ++++++------
 2 files changed, 80 insertions(+), 40 deletions(-)

diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index 8f50eaefca..c42b4b8176 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -1,6 +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>
+;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,7 +26,10 @@
   #:use-module (srfi srfi-39)
   #:use-module (ice-9 match)
   #:export (with-http-server
+            with-http-server/keep-lingering
+            with-http-server*
             call-with-http-server
+            call-with-http-server*
             %http-server-port
             %local-url))
 
@@ -68,23 +71,15 @@ actually listened at (in case %http-server-port was 0)."
   (string-append "http://localhost:"; (number->string port)
                  "/foo/bar"))
 
-(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.
+(define* (call-with-http-server* handle thunk #:key (keep-lingering? #false)
+                                 (last-response? (const #false)))
+  "Call THUNK with an HTTP server running and responding to HTTP requests
+with HANDLE (see (guile)Web Server).
 
 %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)
-            (list response data))
-           (((? integer? code) data)
-            (list (build-response #:code code
-                                  #:reason-phrase "Such is life")
-                  data)))
-         responses+data))
-
+The port listened at will be set for the dynamic extent of THUNK.
+The server will quit after THUNK returns, unless KEEP-LINGERING? is true.
+It will also quit if LAST-RESPONSE? returns true."
   (define (http-write server client response body)
     "Write RESPONSE."
     (let* ((response (write-response response client))
@@ -94,8 +89,8 @@ The port listened at will be set for the dynamic extent of 
THUNK."
        (else
         (write-response-body response body)))
       (close-port port)
-      (when (null? responses)
-        (quit #t))                                ;exit the server thread
+      (when (last-response?)
+        (throw 'quit))
       (values)))
 
   ;; Mutex and condition variable to synchronize with the HTTP server.
@@ -118,18 +113,15 @@ The port listened at will be set for the dynamic extent 
of THUNK."
     (@@ (web server http) http-close))
 
   (define (server-body)
-    (define (handle request body)
-      (match responses
-        (((response data) rest ...)
-         (set! responses rest)
-         (values response data))))
-
     (let-values (((socket port) (open-http-server-socket)))
       (set! %http-real-server-port port)
       (catch 'quit
         (lambda ()
-          (run-server handle stub-http-server
-                      `(#:socket ,socket)))
+          ;; HANDLE might want to include the port in its responses,
+          ;; so set %http-server-port here as well.
+          (parameterize ((%http-server-port port))
+            (run-server handle stub-http-server
+                        `(#:socket ,socket))))
         (lambda _
           (close-port socket)))))
 
@@ -137,12 +129,58 @@ The port listened at will be set for the dynamic extent 
of THUNK."
     (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.
-      (parameterize ((%http-server-port %http-real-server-port))
-        (thunk)))))
+      (let-values ((results
+                    (parameterize ((%http-server-port %http-real-server-port))
+                      (thunk))))
+        (unless keep-lingering?
+          ;; exit the server thread
+          (system-async-mark (lambda () (throw 'quit)) server))
+        (apply values results)))))
+
+
+(define* (call-with-http-server responses+data thunk #:key (keep-lingering? 
#false))
+  "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.
+
+The argument RESPONSES+DATA is thunked.  As such, RESPONSES+DATA can use
+%http-server-port.  %http-server-port will be set to the port listened at.
+It will be set for the dynamic extent of THUNK and RESPONSES+DATA.
+
+The server will exit after the last response.  When KEEP-LINGERING? is false,
+the server will also exit after THUNK returns."
+  (define (responses)
+    (map (match-lambda
+           (((? response? response) data)
+            (list response data))
+           (((? integer? code) data)
+            (list (build-response #:code code
+                                  #:reason-phrase "Such is life")
+                  data)))
+         (responses+data)))
+  (define (handle request body)
+    (match (responses)
+      (((response data) rest ...)
+       (set! responses (const rest))
+       (values response data))))
+  (call-with-http-server* handle thunk #:keep-lingering? keep-lingering?
+                          #:last-response?
+                          (lambda () (null? (responses)))))
 
 (define-syntax with-http-server
   (syntax-rules ()
     ((_ responses+data body ...)
-     (call-with-http-server responses+data (lambda () body ...)))))
+     (call-with-http-server (lambda () responses+data) (lambda () body ...)))))
+
+(define-syntax with-http-server/keep-lingering
+  (syntax-rules ()
+    ((_ responses+data body ...)
+     (call-with-http-server (lambda () responses+data) (lambda () body ...)
+                            #:keep-lingering? #true))))
+
+(define-syntax with-http-server*
+  (syntax-rules ()
+    ((_ handle body ...)
+     (call-with-http-server* handle (lambda () body ...)))))
 
 ;;; http.scm ends here
diff --git a/tests/challenge.scm b/tests/challenge.scm
index fdd5fd238e..c9de33ed34 100644
--- a/tests/challenge.scm
+++ b/tests/challenge.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -198,17 +199,18 @@ value."
                                      (lambda (port)
                                        (write-file out2 port)))))
         (parameterize ((%http-server-port 9000))
-          (with-http-server `((200 ,(make-narinfo item size1 hash1))
-                              (200 ,nar1))
-            (parameterize ((%http-server-port 9001))
-              (with-http-server `((200 ,(make-narinfo item size2 hash2))
-                                  (200 ,nar2))
-                (mlet* %store-monad ((urls -> (list (%local-url 9000)
-                                                    (%local-url 9001)))
-                                     (reports (compare-contents (list item)
-                                                                urls)))
-                  (pk 'report reports)
-                  (return (proc (car reports))))))))))))
+          (with-http-server/keep-lingering
+           `((200 ,(make-narinfo item size1 hash1))
+             (200 ,nar1))
+           (parameterize ((%http-server-port 9001))
+             (with-http-server/keep-lingering
+              `((200 ,(make-narinfo item size2 hash2))
+                (200 ,nar2))
+              (mlet* %store-monad ((urls -> (list (%local-url 9000)
+                                                  (%local-url 9001)))
+                                   (reports (compare-contents (list item)
+                                                              urls)))
+                (return (proc (car reports))))))))))))
 
 (test-assertm "differing-files"
   (call-mismatch-test

base-commit: 1bd250783d7118c3101dd2a6e090f3d6904b24a0
-- 
2.30.2