Merge branch 'master' into core-updates

6 files changed, 192 insertions, 4 deletions

diff --git a/tests/gexp.scm b/tests/gexp.scm
index 5873abdd41..2f8940e2c6 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)
@@ -853,6 +854,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 +902,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-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/publish.scm b/tests/publish.scm
index 8c88a8c93d..1ed8308076 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -464,7 +464,7 @@ FileSize: ~a~%"
                                      (lambda (port)
                                        (display "Hello, build log!"
                                                 (current-error-port))
-                                       (display "" port)))))))
+                                       (display #$(random-text) port)))))))
     (build-derivations %store (list drv))
     (let* ((response (http-get
                       (publish-uri (string-append "/log/"
@@ -483,4 +483,12 @@ FileSize: ~a~%"
   (let ((uri (publish-uri "/log/does-not-exist")))
     (response-code (http-get uri))))
 
+(test-equal "non-GET query"
+  '(200 404)
+  (let ((path (string-append "/" (store-path-hash-part %item)
+                             ".narinfo")))
+    (map response-code
+         (list (http-get (publish-uri path))
+               (http-post (publish-uri path))))))
+
 (test-end "publish")