tests: Move HTTP server to (guix tests http).

* tests/lint.scm (%http-server-port, %local-url)
(%http-server-socket, http-write, %http-server-lock)
(%http-server-ready, http-open, stub-http-server)
(call-with-http-server, with-http-server): Move to (guix tests http).
Adjust tests for %HTTP-SERVER-SOCKET as a promise and %LOCAL-URL as a
parameter.
* guix/tests/http.scm: New file.
* Makefile.am (dist_noinst_DATA): Add it.
(GOBJECTS): Add .go files for all of $(dist_noinst_DATA).
(make-go): Depend on $(dist_noinst_DATA).

3 files changed, 141 insertions, 101 deletions

diff --git a/Makefile.am b/Makefile.am
index 908eaf6ec0..5d3639747f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -171,8 +171,8 @@ MODULES +=					\
 
 endif BUILD_DAEMON_OFFLOAD
 
-# Internal module with test suite support.
-dist_noinst_DATA = guix/tests.scm
+# Internal modules with test suite support.
+dist_noinst_DATA = guix/tests.scm guix/tests/http.scm
 
 # Linux-Libre configurations.
 KCONFIGS =					\
@@ -189,7 +189,7 @@ EXAMPLES =					\
   gnu/system/examples/desktop.tmpl		\
   gnu/system/examples/lightweight-desktop.tmpl
 
-GOBJECTS = $(MODULES:%.scm=%.go) guix/config.go guix/tests.go
+GOBJECTS = $(MODULES:%.scm=%.go) guix/config.go $(dist_noinst_DATA:%.scm=%.go)
 
 nobase_dist_guilemodule_DATA =                  \
   $(MODULES) $(KCONFIGS) $(EXAMPLES)            \
@@ -407,7 +407,7 @@ CLEANFILES =					\
 # the whole thing.  Likewise, set 'XDG_CACHE_HOME' to avoid loading possibly
 # stale files from ~/.cache/guile/ccache.
 %.go: make-go ; @:
-make-go: $(MODULES) guix/config.scm guix/tests.scm
+make-go: $(MODULES) guix/config.scm $(dist_noinst_DATA)
 	$(AM_V_at)echo "Compiling Scheme modules..." ;			\
 	unset GUILE_LOAD_COMPILED_PATH ;				\
 	XDG_CACHE_HOME=/nowhere						\
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
new file mode 100644
index 0000000000..fe1e120c5d
--- /dev/null
+++ b/guix/tests/http.scm
@@ -0,0 +1,120 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix tests http)
+  #:use-module (ice-9 threads)
+  #:use-module (web server)
+  #:use-module (web server http)
+  #:use-module (web response)
+  #:use-module (srfi srfi-39)
+  #:export (with-http-server
+            call-with-http-server
+            %http-server-port
+            %http-server-socket
+            %local-url))
+
+;;; Commentary:
+;;;
+;;; Code to spawn a Web server for testing purposes.
+;;;
+;;; Code:
+
+(define %http-server-port
+  ;; TCP port to use for the stub HTTP server.
+  (make-parameter 9999))
+
+(define (%local-url)
+  ;; URL to use for 'home-page' tests.
+  (string-append "http://localhost:" (number->string (%http-server-port))
+                 "/foo/bar"))
+
+(define %http-server-socket
+  ;; Listening socket for the web server.  It is useful to export it so that
+  ;; tests can check whether we succeeded opening the socket and tests skip if
+  ;; needed.
+  (delay
+    (catch 'system-error
+      (lambda ()
+        (let ((sock (socket PF_INET SOCK_STREAM 0)))
+          (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+          (bind sock
+                (make-socket-address AF_INET INADDR_LOOPBACK
+                                     (%http-server-port)))
+          sock))
+      (lambda args
+        (let ((err (system-error-errno args)))
+          (format (current-error-port)
+                  "warning: cannot run Web server for tests: ~a~%"
+                  (strerror err))
+          #f)))))
+
+(define (http-write server client response body)
+  "Write RESPONSE."
+  (let* ((response (write-response response client))
+         (port     (response-port response)))
+    (cond
+     ((not body))                                 ;pass
+     (else
+      (write-response-body response body)))
+    (close-port port)
+    (quit #t)                                     ;exit the server thread
+    (values)))
+
+;; Mutex and condition variable to synchronize with the HTTP server.
+(define %http-server-lock (make-mutex))
+(define %http-server-ready (make-condition-variable))
+
+(define (http-open . args)
+  "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
+  (with-mutex %http-server-lock
+    (let ((result (apply (@@ (web server http) http-open) args)))
+      (signal-condition-variable %http-server-ready)
+      result)))
+
+(define-server-impl stub-http-server
+  ;; Stripped-down version of Guile's built-in HTTP server.
+  http-open
+  (@@ (web server http) http-read)
+  http-write
+  (@@ (web server http) http-close))
+
+(define (call-with-http-server code data thunk)
+  "Call THUNK with an HTTP server running and returning CODE and DATA (a
+string) on HTTP requests."
+  (define (server-body)
+    (define (handle request body)
+      (values (build-response #:code code
+                              #:reason-phrase "Such is life")
+              data))
+
+    (catch 'quit
+      (lambda ()
+        (run-server handle stub-http-server
+                    `(#:socket ,(force %http-server-socket))))
+      (const #t)))
+
+  (with-mutex %http-server-lock
+    (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.
+      (thunk))))
+
+(define-syntax-rule (with-http-server code data body ...)
+  (call-with-http-server code data (lambda () body ...)))
+
+;;; http.scm ends here
diff --git a/tests/lint.scm b/tests/lint.scm
index fa2d19b2a6..cf1b95ee69 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -24,6 +24,7 @@
 
 (define-module (test-lint)
   #:use-module (guix tests)
+  #:use-module (guix tests http)
   #:use-module (guix download)
   #:use-module (guix git-download)
   #:use-module (guix build-system gnu)
@@ -33,101 +34,20 @@
   #:use-module (gnu packages)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages pkg-config)
-  #:use-module (web server)
-  #:use-module (web server http)
-  #:use-module (web response)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 threads)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-64))
 
 ;; Test the linter.
 
-(define %http-server-port
-  ;; TCP port to use for the stub HTTP server.
-  9999)
-
-(define %local-url
-  ;; URL to use for 'home-page' tests.
-  (string-append "http://localhost:" (number->string %http-server-port)
-                 "/foo/bar"))
+;; Avoid collisions with other tests.
+(%http-server-port 9999)
 
 (define %null-sha256
   ;; SHA256 of the empty string.
   (base32
    "0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73"))
 
-(define %http-server-socket
-  ;; Socket used by the Web server.
-  (catch 'system-error
-    (lambda ()
-      (let ((sock (socket PF_INET SOCK_STREAM 0)))
-        (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
-        (bind sock
-              (make-socket-address AF_INET INADDR_LOOPBACK
-                                   %http-server-port))
-        sock))
-    (lambda args
-      (let ((err (system-error-errno args)))
-        (format (current-error-port)
-                "warning: cannot run Web server for tests: ~a~%"
-                (strerror err))
-        #f))))
-
-(define (http-write server client response body)
-  "Write RESPONSE."
-  (let* ((response (write-response response client))
-         (port     (response-port response)))
-    (cond
-     ((not body))                                 ;pass
-     (else
-      (write-response-body response body)))
-    (close-port port)
-    (quit #t)                                     ;exit the server thread
-    (values)))
-
-;; Mutex and condition variable to synchronize with the HTTP server.
-(define %http-server-lock (make-mutex))
-(define %http-server-ready (make-condition-variable))
-
-(define (http-open . args)
-  "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
-  (with-mutex %http-server-lock
-    (let ((result (apply (@@ (web server http) http-open) args)))
-      (signal-condition-variable %http-server-ready)
-      result)))
-
-(define-server-impl stub-http-server
-  ;; Stripped-down version of Guile's built-in HTTP server.
-  http-open
-  (@@ (web server http) http-read)
-  http-write
-  (@@ (web server http) http-close))
-
-(define (call-with-http-server code data thunk)
-  "Call THUNK with an HTTP server running and returning CODE and DATA (a
-string) on HTTP requests."
-  (define (server-body)
-    (define (handle request body)
-      (values (build-response #:code code
-                              #:reason-phrase "Such is life")
-              data))
-
-    (catch 'quit
-      (lambda ()
-        (run-server handle stub-http-server
-                    `(#:socket ,%http-server-socket)))
-      (const #t)))
-
-  (with-mutex %http-server-lock
-    (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.
-      (thunk))))
-
-(define-syntax-rule (with-http-server code data body ...)
-  (call-with-http-server code data (lambda () body ...)))
-
 (define %long-string
   (make-string 2000 #\a))
 
@@ -423,28 +343,28 @@ string) on HTTP requests."
         (check-home-page pkg)))
     "domain not found")))
 
-(test-skip (if %http-server-socket 0 1))
+(test-skip (if (force %http-server-socket) 0 1))
 (test-assert "home-page: Connection refused"
   (->bool
    (string-contains
     (with-warnings
       (let ((pkg (package
                    (inherit (dummy-package "x"))
-                   (home-page %local-url))))
+                   (home-page (%local-url)))))
         (check-home-page pkg)))
     "Connection refused")))
 
-(test-skip (if %http-server-socket 0 1))
+(test-skip (if (force %http-server-socket) 0 1))
 (test-equal "home-page: 200"
   ""
   (with-warnings
    (with-http-server 200 %long-string
      (let ((pkg (package
                   (inherit (dummy-package "x"))
-                  (home-page %local-url))))
+                  (home-page (%local-url)))))
        (check-home-page pkg)))))
 
-(test-skip (if %http-server-socket 0 1))
+(test-skip (if (force %http-server-socket) 0 1))
 (test-assert "home-page: 200 but short length"
   (->bool
    (string-contains
@@ -452,11 +372,11 @@ string) on HTTP requests."
       (with-http-server 200 "This is too small."
         (let ((pkg (package
                      (inherit (dummy-package "x"))
-                     (home-page %local-url))))
+                     (home-page (%local-url)))))
           (check-home-page pkg))))
     "suspiciously small")))
 
-(test-skip (if %http-server-socket 0 1))
+(test-skip (if (force %http-server-socket) 0 1))
 (test-assert "home-page: 404"
   (->bool
    (string-contains
@@ -464,7 +384,7 @@ string) on HTTP requests."
       (with-http-server 404 %long-string
         (let ((pkg (package
                      (inherit (dummy-package "x"))
-                     (home-page %local-url))))
+                     (home-page (%local-url)))))
           (check-home-page pkg))))
     "not reachable: 404")))
 
@@ -545,7 +465,7 @@ string) on HTTP requests."
          (check-source-file-name pkg)))
      "file name should contain the package name"))))
 
-(test-skip (if %http-server-socket 0 1))
+(test-skip (if (force %http-server-socket) 0 1))
 (test-equal "source: 200"
   ""
   (with-warnings
@@ -554,11 +474,11 @@ string) on HTTP requests."
                   (inherit (dummy-package "x"))
                   (source (origin
                             (method url-fetch)
-                            (uri %local-url)
+                            (uri (%local-url))
                             (sha256 %null-sha256))))))
        (check-source pkg)))))
 
-(test-skip (if %http-server-socket 0 1))
+(test-skip (if (force %http-server-socket) 0 1))
 (test-assert "source: 200 but short length"
   (->bool
    (string-contains
@@ -568,12 +488,12 @@ string) on HTTP requests."
                      (inherit (dummy-package "x"))
                      (source (origin
                                (method url-fetch)
-                               (uri %local-url)
+                               (uri (%local-url))
                                (sha256 %null-sha256))))))
           (check-source pkg))))
     "suspiciously small")))
 
-(test-skip (if %http-server-socket 0 1))
+(test-skip (if (force %http-server-socket) 0 1))
 (test-assert "source: 404"
   (->bool
    (string-contains
@@ -583,7 +503,7 @@ string) on HTTP requests."
                      (inherit (dummy-package "x"))
                      (source (origin
                                (method url-fetch)
-                               (uri %local-url)
+                               (uri (%local-url))
                                (sha256 %null-sha256))))))
           (check-source pkg))))
     "not reachable: 404")))