Merge branch 'master' into python-build-system

5 files changed, 192 insertions, 125 deletions

diff --git a/tests/derivations.scm b/tests/derivations.scm
index d8553b223e..2b5aa796d4 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -16,6 +16,8 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
+(unsetenv "http_proxy")
+
 (define-module (test-derivations)
   #:use-module (guix derivations)
   #:use-module (guix grafts)
@@ -24,6 +26,7 @@
   #:use-module (guix hash)
   #:use-module (guix base32)
   #:use-module (guix tests)
+  #:use-module (guix tests http)
   #:use-module ((guix packages) #:select (package-derivation base32))
   #:use-module ((guix build utils) #:select (executable-file?))
   #:use-module ((gnu packages) #:select (search-bootstrap-binary))
@@ -75,6 +78,9 @@
         (lambda (e1 e2)
           (string<? (car e1) (car e2)))))
 
+;; Avoid collisions with other tests.
+(%http-server-port 10500)
+
 
 (test-begin "derivations")
 
@@ -205,6 +211,74 @@
                 (= (stat:ino (lstat file1))
                    (stat:ino (lstat file2))))))))
 
+(test-equal "built-in-builders"
+  '("download")
+  (built-in-builders %store))
+
+(test-assert "unknown built-in builder"
+  (let ((drv (derivation %store "ohoh" "builtin:does-not-exist" '())))
+    (guard (c ((nix-protocol-error? c)
+               (string-contains (nix-protocol-error-message c) "failed")))
+      (build-derivations %store (list drv))
+      #f)))
+
+(unless (force %http-server-socket)
+  (test-skip 1))
+(test-assert "'download' built-in builder"
+  (let ((text (random-text)))
+    (with-http-server 200 text
+      (let* ((drv (derivation %store "world"
+                              "builtin:download" '()
+                              #:env-vars `(("url"
+                                            . ,(object->string (%local-url))))
+                              #:hash-algo 'sha256
+                              #:hash (sha256 (string->utf8 text)))))
+        (and (build-derivations %store (list drv))
+             (string=? (call-with-input-file (derivation->output-path drv)
+                         get-string-all)
+                       text))))))
+
+(unless (force %http-server-socket)
+  (test-skip 1))
+(test-assert "'download' built-in builder, invalid hash"
+  (with-http-server 200 "hello, world!"
+    (let* ((drv (derivation %store "world"
+                            "builtin:download" '()
+                            #:env-vars `(("url"
+                                          . ,(object->string (%local-url))))
+                            #:hash-algo 'sha256
+                            #:hash (sha256 (random-bytevector 100))))) ;wrong
+      (guard (c ((nix-protocol-error? c)
+                 (string-contains (nix-protocol-error-message c) "failed")))
+        (build-derivations %store (list drv))
+        #f))))
+
+(unless (force %http-server-socket)
+  (test-skip 1))
+(test-assert "'download' built-in builder, not found"
+  (with-http-server 404 "not found"
+    (let* ((drv (derivation %store "will-never-be-found"
+                            "builtin:download" '()
+                            #:env-vars `(("url"
+                                          . ,(object->string (%local-url))))
+                            #:hash-algo 'sha256
+                            #:hash (sha256 (random-bytevector 100)))))
+      (guard (c ((nix-protocol-error? c)
+                 (string-contains (nix-protocol-error-message (pk c)) "failed")))
+        (build-derivations %store (list drv))
+        #f))))
+
+(test-assert "'download' built-in builder, not fixed-output"
+  (let* ((source (add-text-to-store %store "hello" "hi!"))
+         (url    (string-append "file://" source))
+         (drv    (derivation %store "world"
+                             "builtin:download" '()
+                             #:env-vars `(("url" . ,(object->string url))))))
+    (guard (c ((nix-protocol-error? c)
+               (string-contains (nix-protocol-error-message c) "failed")))
+      (build-derivations %store (list drv))
+      #f)))
+
 (test-equal "derivation-name"
   "foo-0.0"
   (let ((drv (derivation %store "foo-0.0" %bash '())))
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 214e7a5302..354d28f014 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -375,7 +375,7 @@
                        (drv    (gexp->file "foo" exp))
                        (out -> (derivation->output-path drv))
                        (done   (built-derivations (list drv)))
-                       (refs   ((store-lift references) out)))
+                       (refs   (references* out)))
     (return (and (equal? sexp (call-with-input-file out read))
                  (equal? (list guile) refs)))))
 
@@ -386,7 +386,7 @@
                        (drv    (gexp->file "foo" exp))
                        (out -> (derivation->output-path drv))
                        (done   (built-derivations (list drv)))
-                       (refs   ((store-lift references) out)))
+                       (refs   (references* out)))
     (return (and (equal? (string-append guile "/bin/guile")
                          (call-with-input-file out read))
                  (equal? (list guile) refs)))))
@@ -407,8 +407,8 @@
                        (out ->  (derivation->output-path drv))
                        (out2 -> (derivation->output-path drv "2nd"))
                        (done    (built-derivations (list drv)))
-                       (refs    ((store-lift references) out))
-                       (refs2   ((store-lift references) out2))
+                       (refs    (references* out))
+                       (refs2   (references* out2))
                        (guile   (package-file %bootstrap-guile "bin/guile")))
     (return (and (string=? (readlink (string-append out "/foo")) guile)
                  (string=? (readlink out2) file)
@@ -481,7 +481,7 @@
                                               (ungexp output))))
                        (xdrv      (gexp->derivation "foo" exp
                                                     #:target target))
-                       (refs      ((store-lift references)
+                       (refs      (references*
                                    (derivation-file-name xdrv)))
                        (xcu       (package->cross-derivation coreutils
                                                              target))
@@ -506,7 +506,7 @@
                                               (ungexp output))))
                        (xdrv      (gexp->derivation "foo" exp
                                                     #:target target))
-                       (refs      ((store-lift references)
+                       (refs      (references*
                                    (derivation-file-name xdrv)))
                        (xglibc    (package->cross-derivation glibc target))
                        (cu        (package->derivation coreutils)))
@@ -808,34 +808,33 @@
                          (out -> (derivation->output-path drv)))
       (mbegin %store-monad
         (built-derivations (list drv))
-        (mlet %store-monad ((refs ((store-lift references) out)))
+        (mlet %store-monad ((refs (references* out)))
           (return (and (equal? refs (list text))
                        (equal? `(list "foo" ,text)
                                (call-with-input-file out read)))))))))
 
 (test-assert "text-file*"
-  (let ((references (store-lift references)))
-    (run-with-store %store
-      (mlet* %store-monad
-          ((drv  (package->derivation %bootstrap-guile))
-           (guile -> (derivation->output-path drv))
-           (file (text-file "bar" "This is bar."))
-           (text (text-file* "foo"
-                             %bootstrap-guile "/bin/guile "
-                             (gexp-input %bootstrap-guile "out") "/bin/guile "
-                             drv "/bin/guile "
-                             file))
-           (done (built-derivations (list text)))
-           (out -> (derivation->output-path text))
-           (refs (references out)))
-        ;; Make sure we get the right references and the right content.
-        (return (and (lset= string=? refs (list guile file))
-                     (equal? (call-with-input-file out get-string-all)
-                             (string-append guile "/bin/guile "
-                                            guile "/bin/guile "
-                                            guile "/bin/guile "
-                                            file)))))
-      #:guile-for-build (package-derivation %store %bootstrap-guile))))
+  (run-with-store %store
+    (mlet* %store-monad
+        ((drv  (package->derivation %bootstrap-guile))
+         (guile -> (derivation->output-path drv))
+         (file (text-file "bar" "This is bar."))
+         (text (text-file* "foo"
+                           %bootstrap-guile "/bin/guile "
+                           (gexp-input %bootstrap-guile "out") "/bin/guile "
+                           drv "/bin/guile "
+                           file))
+         (done (built-derivations (list text)))
+         (out -> (derivation->output-path text))
+         (refs (references* out)))
+      ;; Make sure we get the right references and the right content.
+      (return (and (lset= string=? refs (list guile file))
+                   (equal? (call-with-input-file out get-string-all)
+                           (string-append guile "/bin/guile "
+                                          guile "/bin/guile "
+                                          guile "/bin/guile "
+                                          file)))))
+    #:guile-for-build (package-derivation %store %bootstrap-guile)))
 
 (test-assertm "mixed-text-file"
   (mlet* %store-monad ((file ->   (mixed-text-file "mixed"
@@ -847,7 +846,7 @@
                        (guile ->  (derivation->output-path guile-drv)))
     (mbegin %store-monad
       (built-derivations (list drv))
-      (mlet %store-monad ((refs ((store-lift references) out)))
+      (mlet %store-monad ((refs (references* out)))
         (return (and (string=? (string-append "export PATH=" guile "/bin")
                                (call-with-input-file out get-string-all))
                      (equal? refs (list guile))))))))
diff --git a/tests/guix-download.sh b/tests/guix-download.sh
index 6283772c48..ebc853c7fa 100644
--- a/tests/guix-download.sh
+++ b/tests/guix-download.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2015 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2012, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -35,6 +35,13 @@ then false; else true; fi
 # This one should succeed.
 guix download "file://$abs_top_srcdir/README"
 
+# This one too, even if it cannot talk to the daemon.
+output="t-download-$$"
+trap 'rm -f "$output"' EXIT
+GUIX_DAEMON_SOCKET="/nowhere" guix download -o "$output" \
+		  "file://$abs_top_srcdir/README"
+cmp "$output" "$abs_top_srcdir/README"
+
 # This one should fail.
 if guix download "file:///does-not-exist" "file://$abs_top_srcdir/README"
 then false; else true; fi
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?
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 9eb19f9c80..e4ef32c522 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -326,6 +326,27 @@
         ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
         (memv (system-error-errno args) (list EPERM EACCES))))))
 
+(test-equal "network-interface-netmask lo"
+  (make-socket-address AF_INET (inet-pton AF_INET "255.0.0.0") 0)
+  (let* ((sock (socket AF_INET SOCK_STREAM 0))
+         (addr (network-interface-netmask sock "lo")))
+    (close-port sock)
+    addr))
+
+(test-skip (if (zero? (getuid)) 1 0))
+(test-assert "set-network-interface-netmask"
+  (let ((sock (socket AF_INET SOCK_STREAM 0)))
+    (catch 'system-error
+      (lambda ()
+        (set-network-interface-netmask sock "nonexistent"
+                                       (make-socket-address
+                                        AF_INET
+                                        (inet-pton AF_INET "255.0.0.0")
+                                        0)))
+      (lambda args
+        (close-port sock)
+        (memv (system-error-errno args) (list EPERM EACCES))))))
+
 (test-equal "network-interfaces returns one or more interfaces"
   '(#t #t #t)
   (match (network-interfaces)
@@ -353,6 +374,30 @@
              (#f #f)
              (lo (interface-address lo)))))))
 
+(test-skip (if (zero? (getuid)) 1 0))
+(test-assert "add-network-route/gateway"
+  (let ((sock    (socket AF_INET SOCK_STREAM 0))
+        (gateway (make-socket-address AF_INET
+                                      (inet-pton AF_INET "192.168.0.1")
+                                      0)))
+    (catch 'system-error
+      (lambda ()
+        (add-network-route/gateway sock gateway))
+      (lambda args
+        (close-port sock)
+        (memv (system-error-errno args) (list EPERM EACCES))))))
+
+(test-skip (if (zero? (getuid)) 1 0))
+(test-assert "delete-network-route"
+  (let ((sock        (socket AF_INET SOCK_STREAM 0))
+        (destination (make-socket-address AF_INET INADDR_ANY 0)))
+    (catch 'system-error
+      (lambda ()
+        (delete-network-route sock destination))
+      (lambda args
+        (close-port sock)
+        (memv (system-error-errno args) (list EPERM EACCES))))))
+
 (test-equal "tcgetattr ENOTTY"
   ENOTTY
   (catch 'system-error