Merge branch 'master' into staging

8 files changed, 261 insertions, 8 deletions

diff --git a/tests/gexp.scm b/tests/gexp.scm
index 5873abdd41..3c8b4624da 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,6 +25,7 @@
   #:use-module (guix packages)
   #:use-module (guix tests)
   #:use-module ((guix build utils) #:select (with-directory-excursion))
+  #:use-module ((guix utils) #:select (call-with-temporary-directory))
   #:use-module (gnu packages)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bootstrap)
@@ -418,6 +419,24 @@
                          (call-with-input-file out read))
                  (equal? (list guile) refs)))))
 
+(test-assertm "gexp->file + #:splice?"
+  (mlet* %store-monad ((exp -> (list
+                                #~(define foo 'bar)
+                                #~(define guile #$%bootstrap-guile)))
+                       (guile  (package-file %bootstrap-guile))
+                       (drv    (gexp->file "splice" exp #:splice? #t))
+                       (out -> (derivation->output-path drv))
+                       (done   (built-derivations (list drv)))
+                       (refs   (references* out)))
+    (pk 'splice out)
+    (return (and (equal? `((define foo 'bar)
+                           (define guile ,guile)
+                           ,(call-with-input-string "" read))
+                         (call-with-input-file out
+                           (lambda (port)
+                             (list (read port) (read port) (read port)))))
+                 (equal? (list guile) refs)))))
+
 (test-assertm "gexp->derivation"
   (mlet* %store-monad ((file    (text-file "foo" "Hello, world!"))
                        (exp ->  (gexp
@@ -699,11 +718,12 @@
 
 (test-assertm "gexp->derivation & with-imported-module & computed module"
   (mlet* %store-monad
-      ((module -> (scheme-file "x" #~(begin
+      ((module -> (scheme-file "x" #~(;; splice!
                                        (define-module (foo bar)
                                          #:export (the-answer))
 
-                                       (define the-answer 42))))
+                                       (define the-answer 42))
+                               #:splice? #t))
        (build -> (with-imported-modules `(((foo bar) => ,module)
                                           (guix build utils))
                    #~(begin
@@ -853,6 +873,37 @@
       (return (and (zero? (close-pipe pipe))
                    (= (expt n 2) (string->number str)))))))
 
+(test-assertm "gexp->script #:module-path"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (define str
+       "Fake (guix base32) module!")
+
+     (mkdir (string-append directory "/guix"))
+     (call-with-output-file (string-append directory "/guix/base32.scm")
+       (lambda (port)
+         (write `(begin (define-module (guix base32))
+                        (define-public %fake! ,str))
+                port)))
+
+     (mlet* %store-monad ((exp -> (with-imported-modules '((guix base32))
+                                    (gexp (begin
+                                            (use-modules (guix base32))
+                                            (write (list %load-path
+                                                         %fake!))))))
+                          (drv    (gexp->script "guile-thing" exp
+                                                #:guile %bootstrap-guile
+                                                #:module-path (list directory)))
+                          (out -> (derivation->output-path drv))
+                          (done   (built-derivations (list drv))))
+       (let* ((pipe  (open-input-pipe out))
+              (data  (read pipe)))
+         (return (and (zero? (close-pipe pipe))
+                      (match data
+                        ((load-path str*)
+                         (and (string=? str* str)
+                              (not (member directory load-path))))))))))))
+
 (test-assertm "program-file"
   (let* ((n      (random (expt 2 50)))
          (exp    (with-imported-modules '((guix build utils))
@@ -870,6 +921,33 @@
           (return (and (zero? (close-pipe pipe))
                        (= n (string->number str)))))))))
 
+(test-assertm "program-file #:module-path"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (define text (random-text))
+
+     (call-with-output-file (string-append directory "/stupid-module.scm")
+       (lambda (port)
+         (write `(begin (define-module (stupid-module))
+                        (define-public %stupid-thing ,text))
+                port)))
+
+     (let* ((exp    (with-imported-modules '((stupid-module))
+                      (gexp (begin
+                              (use-modules (stupid-module))
+                              (display %stupid-thing)))))
+            (file   (program-file "program" exp
+                                  #:guile %bootstrap-guile
+                                  #:module-path (list directory))))
+       (mlet* %store-monad ((drv (lower-object file))
+                            (out -> (derivation->output-path drv)))
+         (mbegin %store-monad
+           (built-derivations (list drv))
+           (let* ((pipe  (open-input-pipe out))
+                  (str   (get-string-all pipe)))
+             (return (and (zero? (close-pipe pipe))
+                          (string=? text str))))))))))
+
 (test-assertm "scheme-file"
   (let* ((text   (plain-file "foo" "Hello, world!"))
          (scheme (scheme-file "bar" #~(list "foo" #$text))))
diff --git a/tests/graph.scm b/tests/graph.scm
index 00fd37243c..5faa19298a 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -271,6 +271,24 @@ edges."
                           (list txt out))
                   (equal? edges `((,txt ,out)))))))))))
 
+(test-assert "module graph"
+  (let-values (((backend nodes+edges) (make-recording-backend)))
+    (run-with-store %store
+      (export-graph '((gnu packages guile)) 'port
+                    #:node-type %module-node-type
+                    #:backend backend))
+
+    (let-values (((nodes edges) (nodes+edges)))
+      (and (member '(gnu packages guile)
+                   (match nodes
+                     (((ids labels) ...) ids)))
+           (->bool (and (member (list '(gnu packages guile)
+                                      '(gnu packages libunistring))
+                                edges)
+                        (member (list '(gnu packages guile)
+                                      '(gnu packages bdw-gc))
+                                edges)))))))
+
 (test-assert "node-edges"
   (run-with-store %store
     (let ((packages (fold-packages cons '())))
diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh
index efbc7e759c..ef2d9543b7 100644
--- a/tests/guix-gc.sh
+++ b/tests/guix-gc.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2013, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2013, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -54,6 +54,9 @@ guix gc --references "$out/bin/guile"
 if guix gc --references /dev/null;
 then false; else true; fi
 
+# Check derivers.
+guix gc --derivers "$out" | grep "$drv"
+
 # Add then reclaim a .drv file.
 drv="`guix build idutils -d`"
 test -f "$drv"
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
new file mode 100644
index 0000000000..1b63b957be
--- /dev/null
+++ b/tests/guix-pack.sh
@@ -0,0 +1,83 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
+#
+# 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/>.
+
+#
+# Test the `guix pack' command-line utility.
+#
+
+# A network connection is required to build %bootstrap-coreutils&co,
+# which is required to run these tests with the --bootstrap option.
+if ! guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null; then
+    exit 77
+fi
+
+guix pack --version
+
+# Use --no-substitutes because we need to verify we can do this ourselves.
+GUIX_BUILD_OPTIONS="--no-substitutes"
+export GUIX_BUILD_OPTIONS
+
+# Build a tarball with no compression.
+guix pack --compression=none --bootstrap guile-bootstrap
+
+# Build a tarball (with compression).
+guix pack --bootstrap guile-bootstrap
+
+# Build a tarball with a symlink.
+the_pack="`guix pack --bootstrap -S /opt/gnu/bin=bin guile-bootstrap`"
+
+# Try to extract it.
+test_directory="`mktemp -d`"
+trap 'rm -rf "$test_directory"' EXIT
+cd "$test_directory"
+tar -xf "$the_pack"
+test -x opt/gnu/bin/guile
+
+is_available () {
+    # Use the "type" shell builtin to see if the program is on PATH.
+    type "$1" > /dev/null
+}
+
+if is_available chroot && is_available unshare; then
+    # Verify we can use what we built.
+    unshare -r chroot . /opt/gnu/bin/guile --version
+    cd -
+else
+    echo "warning: skipped some verification because chroot or unshare is unavailable" >&2
+fi
+
+# For the tests that build Docker images below, we currently have to use
+# --dry-run because if we don't, there are only two possible cases:
+#
+#     Case 1: We do not use --bootstrap, and the build takes hours to finish
+#             because it needs to build tar etc.
+#
+#     Case 2: We use --bootstrap, and the build fails because the bootstrap
+#             Guile cannot dlopen shared libraries.  Not to mention the fact
+#             that we would still have to build many non-bootstrap inputs
+#             (e.g., guile-json) in order to create the Docker image.
+
+# Build a Docker image.
+guix pack --dry-run --bootstrap -f docker guile-bootstrap
+
+# Build a Docker image with a symlink.
+guix pack --dry-run --bootstrap -f docker -S /opt/gnu=/ guile-bootstrap
+
+# Build a tarball pack of cross-compiled software.  Use coreutils because
+# guile-bootstrap is not intended to be cross-compiled.
+guix pack --dry-run --bootstrap --target=arm-unknown-linux-gnueabihf coreutils
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index 760a2e4c9b..aa5eaa66e7 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -60,6 +60,14 @@ test -L "$profile" && test -L "$profile-1-link"
 ! test -f "$profile-2-link"
 test -f "$profile/bin/guile"
 
+# Collisions are properly flagged (in this case, 'python-wrapper' propagates
+# python@3, which conflicts with python@2.)
+if guix package --bootstrap -n -p "$profile" -i python@2 python-wrapper
+then false; else true; fi
+
+guix package --bootstrap -n -p "$profile" -i python@2 python-wrapper \
+     --allow-collisions
+
 # No search path env. var. here.
 guix package -p "$profile" --search-paths
 guix package -p "$profile" --search-paths | grep '^export PATH='
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index ed8563c8aa..211c26f43d 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -1,6 +1,7 @@
 # GNU Guix --- Functional package management for GNU
 # Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 # Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
+# Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 #
 # This file is part of GNU Guix.
 #
@@ -267,3 +268,19 @@ guix system build "$tmpdir/config.scm" -n
 # Searching.
 guix system search tor | grep "^name: tor"
 guix system search anonym network | grep "^name: tor"
+
+# Below, use -n (--dry-run) for the tests because if we actually tried to
+# build these images, the commands would take hours to run in the worst case.
+
+# Verify that the examples can be built.
+for example in gnu/system/examples/*; do
+    guix system -n disk-image $example
+done
+
+# Verify that the disk image types can be built.
+guix system -n vm gnu/system/examples/vm-image.tmpl
+guix system -n vm-image gnu/system/examples/vm-image.tmpl
+# This invocation was taken care of in the loop above:
+# guix system -n disk-image gnu/system/examples/bare-bones.tmpl
+guix system -n disk-image --file-system-type=iso9660 gnu/system/examples/bare-bones.tmpl
+guix system -n docker-image gnu/system/examples/docker-image.tmpl
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 22ca2a05d4..0d07280b99 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -151,7 +151,13 @@
 ;; XXX: Skip this test when running Linux > 4.7.5 to work around
 ;; <https://bugzilla.kernel.org/show_bug.cgi?id=183461>.
 (when (or (not perform-container-tests?)
-          (version>? (utsname:release (uname)) "4.7.5"))
+          (version>? (utsname:release (uname)) "4.7.5")
+
+          ;; Skip on Ubuntu's 4.4 kernels, which contain a backport of the
+          ;; faulty code: <https://bugs.gnu.org/25476>.
+          (member (utsname:release (uname))
+                  '("4.4.0-21-generic" "4.4.0-59-generic"
+                    "4.4.0-116-generic")))
   (test-skip 1))
 (test-equal "pivot-root"
   #t
diff --git a/tests/union.scm b/tests/union.scm
index b63edc757b..aa95cae001 100644
--- a/tests/union.scm
+++ b/tests/union.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -124,6 +124,46 @@
                 ;; new 'bin' sub-directory in the profile.
                 (eq? 'directory (stat:type (lstat "bin"))))))))
 
+(test-assert "union-build collision first & last"
+  (let* ((guile   (package-derivation %store %bootstrap-guile))
+         (fake    (build-expression->derivation
+                   %store "fake-guile"
+                   '(begin
+                      (use-modules (guix build utils))
+                      (let ((out (assoc-ref %outputs "out")))
+                        (mkdir-p (string-append out "/bin"))
+                        (call-with-output-file (string-append out "/bin/guile")
+                          (const #t))))
+                   #:modules '((guix build utils))))
+         (builder (lambda (policy)
+                    `(begin
+                       (use-modules (guix build union)
+                                    (srfi srfi-1))
+                       (union-build (assoc-ref %outputs "out")
+                                    (map cdr %build-inputs)
+                                    #:resolve-collision ,policy))))
+         (drv1
+          (build-expression->derivation %store "union-first"
+                                        (builder 'first)
+                                        #:inputs `(("guile" ,guile)
+                                                   ("fake" ,fake))
+                                        #:modules '((guix build union))))
+         (drv2
+          (build-expression->derivation %store "union-last"
+                                        (builder 'last)
+                                        #:inputs `(("guile" ,guile)
+                                                   ("fake" ,fake))
+                                        #:modules '((guix build union)))))
+    (and (build-derivations %store (list drv1 drv2))
+         (with-directory-excursion (derivation->output-path drv1)
+           (string=? (readlink "bin/guile")
+                     (string-append (derivation->output-path guile)
+                                    "/bin/guile")))
+         (with-directory-excursion (derivation->output-path drv2)
+           (string=? (readlink "bin/guile")
+                     (string-append (derivation->output-path fake)
+                                    "/bin/guile"))))))
+
 (test-assert "union-build #:create-all-directories? #t"
   (let* ((build  `(begin
                     (use-modules (guix build union))