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.

3 files changed, 67 insertions, 48 deletions

diff --git a/tests/derivations.scm b/tests/derivations.scm
index db73d19b3a..00cedef32c 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -210,7 +210,7 @@
   (test-skip 1))
 (test-assert "'download' built-in builder"
   (let ((text (random-text)))
-    (with-http-server 200 text
+    (with-http-server `((200 ,text))
       (let* ((drv (derivation %store "world"
                               "builtin:download" '()
                               #:env-vars `(("url"
@@ -225,7 +225,7 @@
 (unless (http-server-can-listen?)
   (test-skip 1))
 (test-assert "'download' built-in builder, invalid hash"
-  (with-http-server 200 "hello, world!"
+  (with-http-server `((200 "hello, world!"))
     (let* ((drv (derivation %store "world"
                             "builtin:download" '()
                             #:env-vars `(("url"
@@ -240,7 +240,7 @@
 (unless (http-server-can-listen?)
   (test-skip 1))
 (test-assert "'download' built-in builder, not found"
-  (with-http-server 404 "not found"
+  (with-http-server '((404 "not found"))
     (let* ((drv (derivation %store "will-never-be-found"
                             "builtin:download" '()
                             #:env-vars `(("url"
@@ -275,9 +275,9 @@
                                         . ,(object->string (%local-url))))
                           #:hash-algo 'sha256
                           #:hash (sha256 (string->utf8 text)))))
-    (and (with-http-server 200 text
+    (and (with-http-server `((200 ,text))
            (build-derivations %store (list drv)))
-         (with-http-server 200 text
+         (with-http-server `((200 ,text))
            (build-derivations %store (list drv)
                               (build-mode check)))
          (string=? (call-with-input-file (derivation->output-path drv)
@@ -1264,5 +1264,5 @@
 (test-end)
 
 ;; Local Variables:
-;; eval: (put 'with-http-server 'scheme-indent-function 2)
+;; eval: (put 'with-http-server 'scheme-indent-function 1)
 ;; End:
diff --git a/tests/lint.scm b/tests/lint.scm
index db6dd6dbe1..c8b88136f4 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -390,7 +390,7 @@
 (test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "home-page: 200"
   '()
-  (with-http-server 200 %long-string
+  (with-http-server `((200 ,%long-string))
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (home-page (%local-url)))))
@@ -399,7 +399,7 @@
 (test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "home-page: 200 but short length"
   "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)"
-  (with-http-server 200 "This is too small."
+  (with-http-server `((200 "This is too small."))
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (home-page (%local-url)))))
@@ -410,7 +410,7 @@
 (test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "home-page: 404"
   "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")"
-  (with-http-server 404 %long-string
+  (with-http-server `((404 ,%long-string))
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (home-page (%local-url)))))
@@ -420,7 +420,7 @@
 (test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "home-page: 301, invalid"
   "invalid permanent redirect from http://localhost:9999/foo/bar"
-  (with-http-server 301 %long-string
+  (with-http-server `((301 ,%long-string))
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (home-page (%local-url)))))
@@ -430,12 +430,14 @@
 (test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "home-page: 301 -> 200"
   "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
-  (with-http-server 200 %long-string
-    (let ((initial-url (%local-url)))
+  (with-http-server `((200 ,%long-string))
+    (let* ((initial-url (%local-url))
+           (redirect    (build-response #:code 301
+                                        #:headers
+                                        `((location
+                                           . ,(string->uri initial-url))))))
       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
-        (with-http-server (301 `((location
-                                  . ,(string->uri initial-url))))
-            ""
+        (with-http-server `((,redirect ""))
           (let ((pkg (package
                        (inherit (dummy-package "x"))
                        (home-page (%local-url)))))
@@ -445,12 +447,14 @@
 (test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "home-page: 301 -> 404"
   "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
-  (with-http-server 404 "booh!"
-    (let ((initial-url (%local-url)))
+  (with-http-server '((404 "booh!"))
+    (let* ((initial-url (%local-url))
+           (redirect    (build-response #:code 301
+                                        #:headers
+                                        `((location
+                                           . ,(string->uri initial-url))))))
       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
-        (with-http-server (301 `((location
-                                  . ,(string->uri initial-url))))
-            ""
+        (with-http-server `((,redirect ""))
           (let ((pkg (package
                        (inherit (dummy-package "x"))
                        (home-page (%local-url)))))
@@ -583,7 +587,7 @@
 (test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "source: 200"
   '()
-  (with-http-server 200 %long-string
+  (with-http-server `((200 ,%long-string))
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (source (origin
@@ -595,7 +599,7 @@
 (test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "source: 200 but short length"
   "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)"
-  (with-http-server 200 "This is too small."
+  (with-http-server '((200 "This is too small."))
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (source (origin
@@ -610,7 +614,7 @@
 (test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "source: 404"
   "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")"
-  (with-http-server 404 %long-string
+  (with-http-server `((404 ,%long-string))
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (source (origin
@@ -625,10 +629,10 @@
 (test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "source: 404 and 200"
   '()
-  (with-http-server 404 %long-string
+  (with-http-server `((404 ,%long-string))
     (let ((bad-url (%local-url)))
       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
-        (with-http-server 200 %long-string
+        (with-http-server `((200 ,%long-string))
           (let ((pkg (package
                        (inherit (dummy-package "x"))
                        (source (origin
@@ -642,11 +646,14 @@
 (test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "source: 301 -> 200"
   "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
-  (with-http-server 200 %long-string
-    (let ((initial-url (%local-url)))
+  (with-http-server `((200 ,%long-string))
+    (let* ((initial-url (%local-url))
+           (redirect    (build-response #:code 301
+                                        #:headers
+                                        `((location
+                                           . ,(string->uri initial-url))))))
       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
-        (with-http-server (301 `((location . ,(string->uri initial-url))))
-            ""
+        (with-http-server `((,redirect ""))
           (let ((pkg (package
                        (inherit (dummy-package "x"))
                        (source (origin
@@ -661,11 +668,14 @@
 (test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "source: 301 -> 404"
   "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
-  (with-http-server 404 "booh!"
-    (let ((initial-url (%local-url)))
+  (with-http-server '((404 "booh!"))
+    (let* ((initial-url (%local-url))
+           (redirect    (build-response #:code 301
+                                        #:headers
+                                        `((location
+                                           . ,(string->uri initial-url))))))
       (parameterize ((%http-server-port (+ 1 (%http-server-port))))
-        (with-http-server (301 `((location . ,(string->uri initial-url))))
-            ""
+        (with-http-server `((,redirect ""))
           (let ((pkg (package
                        (inherit (dummy-package "x"))
                        (source (origin
@@ -697,7 +707,7 @@
 
 (test-equal "github-url"
   '()
-  (with-http-server 200 %long-string
+  (with-http-server `((200 ,%long-string))
     (check-github-url
      (dummy-package "x" (source
                          (origin
@@ -709,17 +719,25 @@
   (test-equal "github-url: one suggestion"
     (string-append
      "URL should be '" github-url "'")
-    (with-http-server (301 `((location . ,(string->uri github-url)))) ""
-      (let ((initial-uri (%local-url)))
-        (parameterize ((%http-server-port (+ 1 (%http-server-port))))
-          (with-http-server (302 `((location . ,(string->uri initial-uri)))) ""
-            (single-lint-warning-message
-             (check-github-url
-              (dummy-package "x" (source
-                                  (origin
-                                    (method url-fetch)
-                                    (uri (%local-url))
-                                    (sha256 %null-sha256)))))))))))
+    (let ((redirect (build-response #:code 301
+                                    #:headers
+                                    `((location
+                                       . ,(string->uri github-url))))))
+      (with-http-server `((,redirect ""))
+        (let* ((initial-url (%local-url))
+               (redirect    (build-response #:code 302
+                                            #:headers
+                                            `((location
+                                               . ,(string->uri initial-url))))))
+          (parameterize ((%http-server-port (+ 1 (%http-server-port))))
+            (with-http-server `((,redirect ""))
+              (single-lint-warning-message
+               (check-github-url
+                (dummy-package "x" (source
+                                    (origin
+                                      (method url-fetch)
+                                      (uri (%local-url))
+                                      (sha256 %null-sha256))))))))))))
   (test-equal "github-url: already the correct github url"
     '()
     (check-github-url
@@ -844,6 +862,6 @@
 (test-end "lint")
 
 ;; Local Variables:
-;; eval: (put 'with-http-server 'scheme-indent-function 2)
+;; eval: (put 'with-http-server 'scheme-indent-function 1)
 ;; eval: (put 'with-warnings 'scheme-indent-function 0)
 ;; End:
diff --git a/tests/swh.scm b/tests/swh.scm
index 07f0fda37b..9a0da07ae1 100644
--- a/tests/swh.scm
+++ b/tests/swh.scm
@@ -40,7 +40,7 @@
        \"dir_id\": 2 } ]")
 
 (define-syntax-rule (with-json-result str exp ...)
-  (with-http-server 200 str
+  (with-http-server `((200 ,str))
     (parameterize ((%swh-base-url (%local-url)))
       exp ...)))
 
@@ -56,7 +56,7 @@
 
 (test-equal "lookup-origin, not found"
   #f
-  (with-http-server 404 "Nope."
+  (with-http-server `((404 "Nope."))
     (parameterize ((%swh-base-url (%local-url)))
       (lookup-origin "http://example.org/whatever"))))
 
@@ -72,5 +72,6 @@
 
 ;; Local Variables:
 ;; eval: (put 'with-json-result 'scheme-indent-function 1)
+;; eval: (put 'with-http-server 'scheme-indent-function 1)
 ;; End: