Merge branch 'master' into python-build-system

1 files changed, 36 insertions, 94 deletions

diff --git a/tests/lint.scm b/tests/lint.scm
index b66cd29312..3a9b89fe95 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -25,6 +25,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)
@@ -39,97 +40,19 @@
   #: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))
 
@@ -457,28 +380,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
@@ -486,11 +409,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
@@ -498,7 +421,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")))
 
@@ -579,7 +502,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
@@ -588,11 +511,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
@@ -602,12 +525,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
@@ -617,11 +540,30 @@ 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")))
 
+(test-assert "mirror-url"
+  (string-null?
+   (with-warnings
+     (let ((source (origin
+                     (method url-fetch)
+                     (uri "http://example.org/foo/bar.tar.gz")
+                     (sha256 %null-sha256))))
+       (check-mirror-url (dummy-package "x" (source source)))))))
+
+(test-assert "mirror-url: one suggestion"
+  (string-contains
+   (with-warnings
+     (let ((source (origin
+                     (method url-fetch)
+                     (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
+                     (sha256 %null-sha256))))
+       (check-mirror-url (dummy-package "x" (source source)))))
+   "mirror://gnu/foo/foo.tar.gz"))
+
 (test-assert "cve"
   (mock ((guix scripts lint) package-vulnerabilities (const '()))
         (string-null?