Merge remote-tracking branch 'origin/master' into core-updates

7 files changed, 347 insertions, 44 deletions

diff --git a/tests/cpan.scm b/tests/cpan.scm
index de865b22be..8900716cb0 100644
--- a/tests/cpan.scm
+++ b/tests/cpan.scm
@@ -100,7 +100,7 @@
                    ('home-page "http://search.cpan.org/dist/Foo-Bar")
                    ('synopsis "Fizzle Fuzz")
                    ('description 'fill-in-yourself!)
-                   ('license (package-license perl)))
+                   ('license 'perl-license))
                  (string=? (bytevector->nix-base32-string
                             (call-with-input-string test-source port-sha256))
                            hash))
diff --git a/tests/file-systems.scm b/tests/file-systems.scm
index 12f4f09c57..4c28d0ebc5 100644
--- a/tests/file-systems.scm
+++ b/tests/file-systems.scm
@@ -22,38 +22,12 @@
   #:use-module (gnu system file-systems)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64)
-  #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match))
 
 ;; Test the (gnu system file-systems) module.
 
 (test-begin "file-systems")
 
-(test-equal "uuid->string"
-  "c5307e6b-d1ba-499d-89c5-cb0b143577c4"
-  (uuid->string
-   #vu8(197 48 126 107 209 186 73 157 137 197 203 11 20 53 119 196)))
-
-(test-equal "string->uuid"
-  '(16 "4dab5feb-d176-45de-b287-9b0a6e4c01cb")
-  (let ((uuid (string->uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb")))
-    (list (bytevector-length uuid) (uuid->string uuid))))
-
-(test-assert "uuid"
-  (let ((str "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))
-    (bytevector=? (uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb")
-                  (string->uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))))
-
-(test-assert "uuid, syntax error"
-  (catch 'syntax-error
-    (lambda ()
-      (eval '(uuid "foobar") (current-module))
-      #f)
-    (lambda (key proc message location form . args)
-      (and (eq? proc 'uuid)
-           (string-contains message "invalid UUID")
-           (equal? form '(uuid "foobar"))))))
-
 (test-assert "file-system-needed-for-boot?"
   (let-syntax ((dummy-fs (syntax-rules ()
                            ((_ directory)
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index de6db0928c..d575795ea0 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -215,3 +215,7 @@ EOF
 # In both cases 'my-torrc' should be properly resolved.
 guix system build "$tmpdir/config.scm" -n
 (cd "$tmpdir"; guix system build "config.scm" -n)
+
+# Searching.
+guix system search tor | grep "^name: tor"
+guix system search anonym network | grep "^name: tor"
diff --git a/tests/import-utils.scm b/tests/import-utils.scm
index 8d44b9e0e2..3d8d2c698d 100644
--- a/tests/import-utils.scm
+++ b/tests/import-utils.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -21,6 +21,8 @@
   #:use-module (guix tests)
   #:use-module (guix import utils)
   #:use-module ((guix licenses) #:prefix license:)
+  #:use-module (guix packages)
+  #:use-module (guix build-system)
   #:use-module (srfi srfi-64))
 
 (test-begin "import-utils")
@@ -38,4 +40,40 @@
   'license:lgpl2.0
   (license->symbol license:lgpl2.0))
 
+(test-assert "alist->package with simple source"
+  (let* ((meta '(("name" . "hello")
+                 ("version" . "2.10")
+                 ("source" . "mirror://gnu/hello/hello-2.10.tar.gz")
+                 ("build-system" . "gnu")
+                 ("home-page" . "https://gnu.org")
+                 ("synopsis" . "Say hi")
+                 ("description" . "This package says hi.")
+                 ("license" . "GPL-3.0+")))
+         (pkg (alist->package meta)))
+    (and (package? pkg)
+         (license:license? (package-license pkg))
+         (build-system? (package-build-system pkg))
+         (origin? (package-source pkg)))))
+
+(test-assert "alist->package with explicit source"
+  (let* ((meta '(("name" . "hello")
+                 ("version" . "2.10")
+                 ("source" . (("method" . "url-fetch")
+                              ("uri"    . "mirror://gnu/hello/hello-2.10.tar.gz")
+                              ("sha256" .
+                               (("base32" .
+                                 "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))))
+                 ("build-system" . "gnu")
+                 ("home-page" . "https://gnu.org")
+                 ("synopsis" . "Say hi")
+                 ("description" . "This package says hi.")
+                 ("license" . "GPL-3.0+")))
+         (pkg (alist->package meta)))
+    (and (package? pkg)
+         (license:license? (package-license pkg))
+         (build-system? (package-build-system pkg))
+         (origin? (package-source pkg))
+         (equal? (origin-sha256 (package-source pkg))
+                 (base32 "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))))
+
 (test-end "import-utils")
diff --git a/tests/print.scm b/tests/print.scm
new file mode 100644
index 0000000000..305807c1d1
--- /dev/null
+++ b/tests/print.scm
@@ -0,0 +1,64 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; 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 (test-print)
+  #:use-module (guix import print)
+  #:use-module (guix build-system gnu)
+  #:use-module (guix download)
+  #:use-module (guix packages)
+  #:use-module (guix licenses)
+  #:use-module (srfi srfi-64))
+
+(test-begin "print")
+
+(define pkg
+  (package
+    (name "test")
+    (version "1.2.3")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append "file:///tmp/test-"
+                                  version ".tar.gz"))
+              (sha256
+               (base32
+                "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah"))))
+    (build-system gnu-build-system)
+    (home-page "http://gnu.org")
+    (synopsis "Dummy")
+    (description "This is a dummy package.")
+    (license gpl3+)))
+
+(test-equal "simple package"
+  (package->code pkg)
+  '(package
+     (name "test")
+     (version "1.2.3")
+     (source (origin
+               (method url-fetch)
+               (uri (string-append "file:///tmp/test-"
+                                   version ".tar.gz"))
+               (sha256
+                (base32
+                 "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah"))))
+     (build-system gnu-build-system)
+     (home-page "http://gnu.org")
+     (synopsis "Dummy")
+     (description "This is a dummy package.")
+     (license gpl3+)))
+
+(test-end "print")
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 69b272f2bb..0ad6247954 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
-;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,7 +28,9 @@
   #:use-module (guix base32)
   #:use-module ((guix store) #:select (%store-prefix))
   #:use-module ((guix ui) #:select (guix-warning-port))
-  #:use-module ((guix build utils) #:select (delete-file-recursively))
+  #:use-module ((guix build utils)
+                #:select (mkdir-p delete-file-recursively))
+  #:use-module (guix tests http)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module (web uri)
@@ -112,6 +114,15 @@ version identifier.."
 
 
 
+(define %main-substitute-directory
+  ;; The place where 'call-with-narinfo' stores its data by default.
+  (uri-path (string->uri (getenv "GUIX_BINARY_SUBSTITUTE_URL"))))
+
+(define %alternate-substitute-directory
+  ;; Another place.
+  (string-append (dirname %main-substitute-directory)
+                 "/substituter-alt-data"))
+
 (define %narinfo
   ;; Skeleton of the narinfo used below.
   (string-append "StorePath: " (%store-prefix)
@@ -125,14 +136,14 @@ References: bar baz
 Deriver: " (%store-prefix) "/foo.drv
 System: mips64el-linux\n"))
 
-(define (call-with-narinfo narinfo thunk)
-  "Call THUNK in a context where $GUIX_BINARY_SUBSTITUTE_URL is populated with
+(define* (call-with-narinfo narinfo thunk
+                            #:optional
+                            (narinfo-directory %main-substitute-directory))
+  "Call THUNK in a context where the directory at URL is populated with
 a file for NARINFO."
-  (let ((narinfo-directory (and=> (string->uri (getenv
-                                                "GUIX_BINARY_SUBSTITUTE_URL"))
-                                  uri-path))
-        (cache-directory   (string-append (getenv "XDG_CACHE_HOME")
-                                          "/guix/substitute/")))
+  (mkdir-p narinfo-directory)
+  (let ((cache-directory (string-append (getenv "XDG_CACHE_HOME")
+                                        "/guix/substitute/")))
     (dynamic-wind
       (lambda ()
         (when (file-exists? cache-directory)
@@ -161,14 +172,17 @@ a file for NARINFO."
               #f))
       thunk
       (lambda ()
-        (delete-file-recursively cache-directory)))))
+        (when (file-exists? cache-directory)
+          (delete-file-recursively cache-directory))))))
 
 (define-syntax-rule (with-narinfo narinfo body ...)
   (call-with-narinfo narinfo (lambda () body ...)))
 
+(define-syntax-rule (with-narinfo* narinfo directory body ...)
+  (call-with-narinfo narinfo (lambda () body ...) directory))
+
 ;; Transmit these options to 'guix substitute'.
-(set! (@@ (guix scripts substitute) %cache-urls)
-  (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
+(substitute-urls (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
 
 (test-equal "query narinfo without signature"
   ""                                              ; not substitutable
@@ -228,7 +242,7 @@ a file for NARINFO."
              (guix-substitute "--query"))))))))
 
 (test-quit "substitute, no signature"
-    "lacks a signature"
+    "no valid substitute"
   (with-narinfo %narinfo
     (guix-substitute "--substitute"
                      (string-append (%store-prefix)
@@ -236,7 +250,7 @@ a file for NARINFO."
                      "foo")))
 
 (test-quit "substitute, invalid hash"
-    "hash"
+    "no valid substitute"
   ;; The hash in the signature differs from the hash of %NARINFO.
   (with-narinfo (string-append %narinfo "Signature: "
                                (signature-field "different body")
@@ -247,7 +261,7 @@ a file for NARINFO."
                      "foo")))
 
 (test-quit "substitute, unauthorized key"
-    "unauthorized"
+    "no valid substitute"
   (with-narinfo (string-append %narinfo "Signature: "
                                (signature-field
                                 %narinfo
@@ -273,9 +287,158 @@ a file for NARINFO."
       (lambda ()
         (false-if-exception (delete-file "substitute-retrieved"))))))
 
+(test-equal "substitute, unauthorized narinfo comes first"
+  "Substitutable data."
+  (with-narinfo*
+      (string-append %narinfo "Signature: "
+                     (signature-field
+                      %narinfo
+                      #:public-key %wrong-public-key))
+      %alternate-substitute-directory
+
+    (with-narinfo* (string-append %narinfo "Signature: "
+                                  (signature-field %narinfo))
+        %main-substitute-directory
+
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          ;; Remove this file so that the substitute can only be retrieved
+          ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
+          (delete-file (string-append %main-substitute-directory
+                                      "/example.nar"))
+
+          (parameterize ((substitute-urls
+                          (map (cut string-append "file://" <>)
+                               (list %alternate-substitute-directory
+                                     %main-substitute-directory))))
+            (guix-substitute "--substitute"
+                             (string-append (%store-prefix)
+                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+                             "substitute-retrieved"))
+          (call-with-input-file "substitute-retrieved" get-string-all))
+        (lambda ()
+          (false-if-exception (delete-file "substitute-retrieved")))))))
+
+(test-equal "substitute, unsigned narinfo comes first"
+  "Substitutable data."
+  (with-narinfo* %narinfo                         ;not signed!
+      %alternate-substitute-directory
+
+    (with-narinfo* (string-append %narinfo "Signature: "
+                                  (signature-field %narinfo))
+        %main-substitute-directory
+
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          ;; Remove this file so that the substitute can only be retrieved
+          ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
+          (delete-file (string-append %main-substitute-directory
+                                      "/example.nar"))
+
+          (parameterize ((substitute-urls
+                          (map (cut string-append "file://" <>)
+                               (list %alternate-substitute-directory
+                                     %main-substitute-directory))))
+            (guix-substitute "--substitute"
+                             (string-append (%store-prefix)
+                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+                             "substitute-retrieved"))
+          (call-with-input-file "substitute-retrieved" get-string-all))
+        (lambda ()
+          (false-if-exception (delete-file "substitute-retrieved")))))))
+
+(test-equal "substitute, first narinfo is unsigned and has wrong hash"
+  "Substitutable data."
+  (with-narinfo* (regexp-substitute #f
+                                    (string-match "NarHash: [[:graph:]]+"
+                                                  %narinfo)
+                                    'pre
+                                    "NarHash: sha256:"
+                                    (bytevector->nix-base32-string
+                                     (make-bytevector 32))
+                                    'post)
+      %alternate-substitute-directory
+
+    (with-narinfo* (string-append %narinfo "Signature: "
+                                  (signature-field %narinfo))
+        %main-substitute-directory
+
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          ;; This time remove the file so that the substitute can only be
+          ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
+          (delete-file (string-append %alternate-substitute-directory
+                                      "/example.nar"))
+
+          (parameterize ((substitute-urls
+                          (map (cut string-append "file://" <>)
+                               (list %alternate-substitute-directory
+                                     %main-substitute-directory))))
+            (guix-substitute "--substitute"
+                             (string-append (%store-prefix)
+                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+                             "substitute-retrieved"))
+          (call-with-input-file "substitute-retrieved" get-string-all))
+        (lambda ()
+          (false-if-exception (delete-file "substitute-retrieved")))))))
+
+(test-equal "substitute, first narinfo is unsigned and has wrong refs"
+  "Substitutable data."
+  (with-narinfo* (regexp-substitute #f
+                                    (string-match "References: ([^\n]+)\n"
+                                                  %narinfo)
+                                    'pre "References: " 1
+                                    " wrong set of references\n"
+                                    'post)
+      %alternate-substitute-directory
+
+    (with-narinfo* (string-append %narinfo "Signature: "
+                                  (signature-field %narinfo))
+        %main-substitute-directory
+
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          ;; This time remove the file so that the substitute can only be
+          ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
+          (delete-file (string-append %alternate-substitute-directory
+                                      "/example.nar"))
+
+          (parameterize ((substitute-urls
+                          (map (cut string-append "file://" <>)
+                               (list %alternate-substitute-directory
+                                     %main-substitute-directory))))
+            (guix-substitute "--substitute"
+                             (string-append (%store-prefix)
+                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+                             "substitute-retrieved"))
+          (call-with-input-file "substitute-retrieved" get-string-all))
+        (lambda ()
+          (false-if-exception (delete-file "substitute-retrieved")))))))
+
+(test-quit "substitute, two invalid narinfos"
+    "no valid substitute"
+  (with-narinfo* %narinfo                         ;not signed
+      %alternate-substitute-directory
+
+    (with-narinfo* (string-append %narinfo "Signature: " ;unauthorized
+                                  (signature-field
+                                   %narinfo
+                                   #:public-key %wrong-public-key))
+        %main-substitute-directory
+
+      (guix-substitute "--substitute"
+                       (string-append (%store-prefix)
+                                      "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+                       "substitute-retrieved"))))
+
 (test-end "substitute")
 
 ;;; Local Variables:
 ;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
+;;; eval: (put 'with-narinfo* 'scheme-indent-function 2)
 ;;; eval: (put 'test-quit 'scheme-indent-function 2)
 ;;; End:
diff --git a/tests/uuid.scm b/tests/uuid.scm
new file mode 100644
index 0000000000..aacce77233
--- /dev/null
+++ b/tests/uuid.scm
@@ -0,0 +1,60 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015, 2017 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 (test-uuid)
+  #:use-module (gnu system uuid)
+  #:use-module (srfi srfi-64)
+  #:use-module (rnrs bytevectors))
+
+(test-begin "uuid")
+
+(test-equal "uuid->string"
+  "c5307e6b-d1ba-499d-89c5-cb0b143577c4"
+  (uuid->string
+   #vu8(197 48 126 107 209 186 73 157 137 197 203 11 20 53 119 196)))
+
+(test-equal "string->uuid"
+  '(16 "4dab5feb-d176-45de-b287-9b0a6e4c01cb")
+  (let ((uuid (string->uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb")))
+    (list (bytevector-length uuid) (uuid->string uuid))))
+
+(test-assert "uuid"
+  (let ((str "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))
+    (bytevector=? (uuid-bytevector
+                   (uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))
+                  (string->uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))))
+
+(test-assert "uuid, syntax error"
+  (catch 'syntax-error
+    (lambda ()
+      (eval '(uuid "foobar") (current-module))
+      #f)
+    (lambda (key proc message location form . args)
+      (and (eq? proc 'uuid)
+           (string-contains message "invalid UUID")
+           (equal? form '(uuid "foobar" 'dce))))))
+
+(test-equal "uuid, ISO-9660, format preserved"
+  "1970-01-01-17-14-42-99"
+  (uuid->string (uuid "1970-01-01-17-14-42-99" 'iso9660)))
+
+(test-equal "uuid, FAT32, format preserved"
+  "1234-ABCD"
+  (uuid->string (uuid "1234-abcd" 'fat32)))
+
+(test-end)