From 9323ab550f3bcb75fcaefbb20847595974702d5b Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 29 Aug 2019 16:01:32 +0200
Subject: tests: 'with-http-server' accepts multiple responses.

* guix/tests/http.scm (call-with-http-server): Replace 'code' and 'data'
parameters with 'responses+data'.  Compute RESPONSES as a function of
that.  Remove #:headers parameter.
[http-write]: Quit only when RESPONSES is empty.
[server-body]: Get the response and data from RESPONSES, and set it to
point to the rest.
(with-http-server): Adjust accordingly.
* tests/derivations.scm ("'download' built-in builder")
("'download' built-in builder, invalid hash")
("'download' built-in builder, not found")
("'download' built-in builder, check mode"): Adjust to new
'with-http-server' interface.
* tests/lint.scm ("home-page: 200")
("home-page: 200 but short length")
("home-page: 404", "home-page: 301, invalid"):
("home-page: 301 -> 200", "home-page: 301 -> 404")
("source: 200", "source: 200 but short length")
("source: 404", "source: 404 and 200")
("source: 301 -> 200", "source: 301 -> 404"):
("github-url", github-url): Likewise.
* tests/swh.scm (with-json-result)
("lookup-origin, not found"): Likewise.
---
 guix/tests/http.scm | 39 ++++++++++++++++++++++++---------------
 1 file changed, 24 insertions(+), 15 deletions(-)

(limited to 'guix/tests/http.scm')

diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index a56d6f213d..05ce39bca2 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,6 +22,7 @@
   #:use-module (web server http)
   #:use-module (web response)
   #:use-module (srfi srfi-39)
+  #:use-module (ice-9 match)
   #:export (with-http-server
             call-with-http-server
             %http-server-port
@@ -69,10 +70,20 @@ needed."
   (string-append "http://localhost:" (number->string (%http-server-port))
                  "/foo/bar"))
 
-(define* (call-with-http-server code data thunk
-                                #:key (headers '()))
-  "Call THUNK with an HTTP server running and returning CODE and DATA (a
-string) on HTTP requests."
+(define* (call-with-http-server responses+data thunk)
+  "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
+requests.  Each elements of RESPONSES+DATA must be a tuple containing a
+response and a string, or an HTTP response code and a string."
+  (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 (http-write server client response body)
     "Write RESPONSE."
     (let* ((response (write-response response client))
@@ -82,7 +93,8 @@ string) on HTTP requests."
        (else
         (write-response-body response body)))
       (close-port port)
-      (quit #t)                                   ;exit the server thread
+      (when (null? responses)
+        (quit #t))                                ;exit the server thread
       (values)))
 
   ;; Mutex and condition variable to synchronize with the HTTP server.
@@ -105,10 +117,10 @@ string) on HTTP requests."
 
   (define (server-body)
     (define (handle request body)
-      (values (build-response #:code code
-                              #:reason-phrase "Such is life"
-                              #:headers headers)
-              data))
+      (match responses
+        (((response data) rest ...)
+         (set! responses rest)
+         (values response data))))
 
     (let ((socket (open-http-server-socket)))
       (catch 'quit
@@ -126,10 +138,7 @@ string) on HTTP requests."
 
 (define-syntax with-http-server
   (syntax-rules ()
-    ((_ (code headers) data body ...)
-     (call-with-http-server code data (lambda () body ...)
-                            #:headers headers))
-    ((_ code data body ...)
-     (call-with-http-server code data (lambda () body ...)))))
+    ((_ responses+data body ...)
+     (call-with-http-server responses+data (lambda () body ...)))))
 
 ;;; http.scm ends here
-- 
cgit v1.2.3