[bug#53389] [PATCH 7/9] tests: Allow checking the URI of a HTTP request.

[Maxime Devos <maximedevos@telenet.be>]

* guix/tests/http.scm (call-with-http-server): Thunk RESPONSES+DATA.
  [maybe-uri?]: New procedure.
  [sanitize-response+data]: New procedure extracted from the definition of
  'responses', support triples containing a URI.
  [responses]: Thunk.
  [handle]: Verify the URI.  Adjust for thunking.
  (with-http-server): Adjust for thunking.
---
 guix/tests/http.scm | 35 +++++++++++++++++++++++++----------
 1 file changed, 25 insertions(+), 10 deletions(-)

diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index 2f65df4029..6af1948211 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -21,7 +21,9 @@
   #:use-module (ice-9 threads)
   #:use-module (web server)
   #:use-module (web server http)
+  #:use-module (web request)
   #:use-module (web response)
+  #:use-module (web uri)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-39)
   #:use-module (ice-9 match)
@@ -144,7 +146,10 @@ It will also quit if LAST-RESPONSE? returns true."
 (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.
+response and a string, or an HTTP response code and a string.  Alternatively,
+the elements can triples with the URI path (including the query, if any)
+as the first part of the triple.  In that case, the request URI is verified
+against the URI in RESPONSES+DATA.
 
 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.
@@ -152,18 +157,28 @@ 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 (maybe-uri? object)
+    (or (string? object) (eq? object 'any)))
+  (define (sanitize-response+data response+data)
+    (match response+data
+      ((response data)
+       (sanitize-response+data (list 'any response data)))
+      (((? maybe-uri? uri) (? response? response) data)
+       (list uri response data))
+      (((? maybe-uri? uri) (? integer? code) data)
+       (list uri
+             (build-response #:code code
+                             #:reason-phrase "Such is life")
+             data))))
   (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)))
+    (map sanitize-response+data (responses+data)))
   (define (handle request body)
     (match (responses)
-      (((response data) rest ...)
+      (((uri response data) rest ...)
+       (unless (or (eq? uri 'any)
+                   (string=? uri (uri->string (request-uri request))))
+         (error "this URI should not be contacted!"
+                (request-uri request)))
        (set! responses (const rest))
        (values response data))))
   (call-with-http-server* handle thunk #:keep-lingering? keep-lingering?
-- 
2.30.2