Merge branch 'master' into core-updates

11 files changed, 239 insertions, 16 deletions

diff --git a/tests/accounts.scm b/tests/accounts.scm
index 127861042d..673dd42432 100644
--- a/tests/accounts.scm
+++ b/tests/accounts.scm
@@ -199,12 +199,10 @@ nobody:!:0::::::\n"))
                         (directory "/var/empty")))
   (allocate-passwd (list (user-account (name "alice")
                                        (comment "Alice")
-                                       (home-directory "/home/alice")
                                        (shell "/bin/sh")
                                        (group "users"))
                          (user-account (name "bob")
                                        (comment "Bob")
-                                       (home-directory "/home/bob")
                                        (shell "/bin/gash")
                                        (group "wheel"))
                          (user-account (name "sshd") (system? #t)
@@ -227,25 +225,23 @@ nobody:!:0::::::\n"))
   ;; Make sure bits of state are preserved: UID, no reuse of previously-used
   ;; UIDs, and shell.
   (list (password-entry (name "alice") (uid 1234) (gid 1000)
-                        (real-name "Alice Smith") (shell "/gnu/.../bin/gash")
+                        (real-name "Alice Smith") (shell "/bin/sh")
                         (directory "/home/alice"))
         (password-entry (name "charlie") (uid 1236) (gid 1000)
                         (real-name "Charlie") (shell "/bin/sh")
                         (directory "/home/charlie")))
   (allocate-passwd (list (user-account (name "alice")
                                        (comment "Alice")
-                                       (home-directory "/home/alice")
-                                       (shell "/bin/sh") ;ignored
+                                       (shell "/bin/sh") ;honored
                                        (group "users"))
                          (user-account (name "charlie")
                                        (comment "Charlie")
-                                       (home-directory "/home/charlie")
                                        (shell "/bin/sh")
                                        (group "users")))
                    (list (group-entry (name "users") (gid 1000)))
                    (list (password-entry (name "alice") (uid 1234) (gid 9999)
                                          (real-name "Alice Smith")
-                                         (shell "/gnu/.../bin/gash")
+                                         (shell "/gnu/.../bin/gash") ;ignored
                                          (directory "/home/alice"))
                          (password-entry (name "bob") (uid 1235) (gid 1001)
                                          (real-name "Bob") (shell "/bin/sh")
diff --git a/tests/containers.scm b/tests/containers.scm
index 5323e5037d..37408f380d 100644
--- a/tests/containers.scm
+++ b/tests/containers.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -52,6 +53,16 @@
      #:namespaces '(user))))
 
 (skip-if-unsupported)
+(test-assert "call-with-container, user namespace, guest UID/GID"
+  (zero?
+   (call-with-container '()
+     (lambda ()
+       (assert-exit (and (= 42 (getuid)) (= 77 (getgid)))))
+     #:guest-uid 42
+     #:guest-gid 77
+     #:namespaces '(user))))
+
+(skip-if-unsupported)
 (test-assert "call-with-container, uts namespace"
   (zero?
    (call-with-container '()
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index 66bf6be8d0..63a9fe68da 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -44,6 +44,13 @@ guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'
      guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)';	\
   then exit 1; fi )
 
+# Passing one '-s' flag.
+test `guix build sed -s x86_64-linux -d | wc -l` = 1
+
+# Passing multiple '-s' flags.
+all_systems="-s x86_64-linux -s i686-linux -s armhf-linux -s aarch64-linux"
+test `guix build sed $all_systems -d | sort -u | wc -l` = 4
+
 # Check --sources option with its arguments
 module_dir="t-guix-build-$$"
 mkdir "$module_dir"
@@ -183,6 +190,13 @@ then false; else true; fi
 
 rm -f "$result"
 
+# Check relative file name canonicalization: <https://bugs.gnu.org/35271>.
+mkdir "$result"
+guix build -r "$result/x" -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'
+test -x "$result/x/bin/guile"
+rm "$result/x"
+rmdir "$result"
+
 # Cross building.
 guix build coreutils --target=mips64el-linux-gnu --dry-run --no-substitutes
 
diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh
index a2da9a0773..78507f76c0 100644
--- a/tests/guix-environment-container.sh
+++ b/tests/guix-environment-container.sh
@@ -44,6 +44,31 @@ else
     test $? = 42
 fi
 
+# By default, the UID inside the container should be the same as outside.
+uid="`id -u`"
+inner_uid="`guix environment -C --ad-hoc --bootstrap guile-bootstrap \
+  -- guile -c '(display (getuid))'`"
+test $inner_uid = $uid
+
+# When '--user' is passed, the UID should be 1000.  (Note: Use a separate HOME
+# so that we don't run into problems when the test directory is under /home.)
+export tmpdir
+inner_uid="`HOME=$tmpdir guix environment -C --ad-hoc --bootstrap guile-bootstrap \
+  --user=gnu-guix -- guile -c '(display (getuid))'`"
+test $inner_uid = 1000
+
+if test "x$USER" = "x"; then USER="`id -un`"; fi
+
+# Check whether /etc/passwd and /etc/group are valid.
+guix environment -C --ad-hoc --bootstrap guile-bootstrap \
+     -- guile -c "(exit (string=? \"$USER\" (passwd:name (getpwuid (getuid)))))"
+guix environment -C --ad-hoc --bootstrap guile-bootstrap \
+     -- guile -c '(exit (string? (group:name (getgrgid (getgid)))))'
+guix environment -C --ad-hoc --bootstrap guile-bootstrap \
+     -- guile -c '(use-modules (srfi srfi-1))
+                  (exit (every group:name
+                               (map getgrgid (vector->list (getgroups)))))'
+
 # Make sure file-not-found errors in mounts are reported.
 if guix environment --container --ad-hoc --bootstrap guile-bootstrap \
 	--expose=/does-not-exist -- guile -c 1 2> "$tmpdir/error"
@@ -111,7 +136,7 @@ rm $tmpdir/mounts
 
 # Test that user can be mocked.
 usertest='(exit (and (string=? (getenv "HOME") "/home/foognu")
-                     (string=? (passwd:name (getpwuid 0)) "foognu")
+                     (string=? (passwd:name (getpwuid 1000)) "foognu")
                      (file-exists? "/home/foognu/umock")))'
 touch "$tmpdir/umock"
 HOME="$tmpdir" guix environment --bootstrap --container --user=foognu \
diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh
index ef2d9543b7..8284287730 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, 2018 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2013, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -34,7 +34,7 @@ unset drv
 unset out
 
 # For some operations, passing extra arguments is an error.
-for option in "" "-C 500M" "--verify" "--optimize"
+for option in "" "-C 500M" "--verify" "--optimize" "--list-roots"
 do
     if guix gc $option whatever; then false; else true; fi
 done
@@ -69,6 +69,8 @@ guix gc --delete "$drv"
 drv="`guix build --root=guix-gc-root lsh -d`"
 test -f "$drv" && test -L guix-gc-root
 
+guix gc --list-roots | grep "$PWD/guix-gc-root"
+
 guix gc --list-live | grep "$drv"
 if guix gc --delete "$drv";
 then false; else true; fi
diff --git a/tests/guix-package-aliases.sh b/tests/guix-package-aliases.sh
new file mode 100644
index 0000000000..5c68664093
--- /dev/null
+++ b/tests/guix-package-aliases.sh
@@ -0,0 +1,60 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2019 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/>.
+
+#
+# Test the `guix package' aliases.
+#
+
+guix install --version
+
+readlink_base ()
+{
+    basename `readlink "$1"`
+}
+
+profile="t-profile-$$"
+rm -f "$profile"
+
+trap 'rm -f "$profile" "$profile-"[0-9]*' EXIT
+
+guix install --bootstrap guile-bootstrap -p "$profile"
+test -x "$profile/bin/guile"
+
+# Make sure '-r' isn't passed as-is to 'guix package'.
+if guix install -r guile-bootstrap -p "$profile" --bootstrap
+then false; else true; fi
+test -x "$profile/bin/guile"
+
+guix upgrade --version
+guix upgrade -n
+guix upgrade gui.e -n
+if guix upgrade foo bar -n;
+then false; else true; fi
+
+guix remove --version
+guix remove --bootstrap guile-bootstrap -p "$profile"
+! test -x "$profile/bin/guile"
+test `guix package -p "$profile" -I | wc -l` -eq 0
+
+if guix remove -p "$profile" this-is-not-installed --bootstrap
+then false; else true; fi
+
+if guix remove -i guile-bootstrap -p "$profile" --bootstrap
+then false; else true; fi
+
+guix search '\<board\>' game | grep '^name: gnubg'
diff --git a/tests/pack.scm b/tests/pack.scm
index 40473a9fe9..ea88cd89f2 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -206,7 +206,11 @@
                                       (file-exists? "var/guix/db/db.sqlite")
                                       (string=? (string-append #$%bootstrap-guile "/bin")
                                                 (pk 'binlink (readlink bin)))
-                                      (string=? (string-append #$profile "/bin")
+
+                                      ;; This is a relative symlink target.
+                                      (string=? (string-drop
+                                                 (string-append #$profile "/bin")
+                                                 1)
                                                 (pk 'guilelink (readlink "bin"))))
                              (mkdir #$output))))))))
       (built-derivations (list check)))))
diff --git a/tests/records.scm b/tests/records.scm
index d9469a78bd..16b7a9c35e 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -170,6 +170,64 @@
            (parameterize ((mark (cons 'a 'b)))
              (eq? (foo-bar y) (mark)))))))
 
+(test-assert "define-record-type* & thunked & this-record"
+  (begin
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar)
+      (baz foo-baz (thunked)))
+
+    (let ((x (foo (bar 40)
+                  (baz (+ (foo-bar this-record) 2)))))
+      (and (= 40 (foo-bar x))
+           (= 42 (foo-baz x))))))
+
+(test-assert "define-record-type* & thunked & default & this-record"
+  (begin
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar)
+      (baz foo-baz (thunked)
+           (default (+ (foo-bar this-record) 2))))
+
+    (let ((x (foo (bar 40))))
+      (and (= 40 (foo-bar x))
+           (= 42 (foo-baz x))))))
+
+(test-assert "define-record-type* & thunked & inherit & this-record"
+  (begin
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar)
+      (baz foo-baz (thunked)
+           (default (+ (foo-bar this-record) 2))))
+
+    (let* ((x (foo (bar 40)))
+           (y (foo (inherit x) (bar -2)))
+           (z (foo (inherit x) (baz -2))))
+      (and (= -2 (foo-bar y))
+           (=  0 (foo-baz y))
+           (= 40 (foo-bar z))
+           (= -2 (foo-baz z))))))
+
+(test-assert "define-record-type* & thunked & inherit & custom this"
+  (let ()
+    (define-record-type* <foo> foo make-foo
+      foo? this-foo
+      (thing foo-thing (thunked)))
+    (define-record-type* <bar> bar make-bar
+      bar? this-bar
+      (baz bar-baz (thunked)))
+
+    ;; Nest records and test the two self references.
+    (let* ((x (foo (thing (bar (baz (list this-bar this-foo))))))
+           (y (foo-thing x)))
+      (match (bar-baz y)
+        ((first second)
+         (and (eq? second x)
+              (bar? first)
+              (eq? first y)))))))
+
 (test-assert "define-record-type* & delayed"
   (begin
     (define-record-type* <foo> foo make-foo
diff --git a/tests/scripts.scm b/tests/scripts.scm
index efee271197..0315642f38 100644
--- a/tests/scripts.scm
+++ b/tests/scripts.scm
@@ -19,6 +19,7 @@
 
 (define-module (test-scripts)
   #:use-module (guix scripts)
+  #:use-module (guix tests)
   #:use-module ((guix scripts build)
                 #:select (%standard-build-options))
   #:use-module (srfi srfi-64))
diff --git a/tests/store-roots.scm b/tests/store-roots.scm
new file mode 100644
index 0000000000..5bcf1bc87e
--- /dev/null
+++ b/tests/store-roots.scm
@@ -0,0 +1,53 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 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-store-deduplication)
+  #:use-module (guix tests)
+  #:use-module (guix store)
+  #:use-module (guix store roots)
+  #:use-module ((guix utils) #:select (call-with-temporary-directory))
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-64))
+
+(define %store
+  (open-connection))
+
+(test-begin "store-roots")
+
+(test-assert "gc-roots, regular root"
+  (let* ((item (add-text-to-store %store "something"
+                                  (random-text)))
+         (root (string-append %gc-roots-directory "/test-gc-root")))
+    (symlink item root)
+    (let ((result (member root (gc-roots))))
+      (delete-file root)
+      result)))
+
+(test-assert "gc-roots, indirect root"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (let* ((item (add-text-to-store %store "something"
+                                     (random-text)))
+            (root (string-append directory "/gc-root")))
+       (symlink item root)
+       (add-indirect-root %store root)
+       (let ((result (member root (gc-roots))))
+         (delete-file root)
+         result)))))
+
+(test-end "store-roots")
diff --git a/tests/zlib.scm b/tests/zlib.scm
index 5455240a71..7c595a422c 100644
--- a/tests/zlib.scm
+++ b/tests/zlib.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,11 +26,10 @@
 
 ;; Test the (guix zlib) module.
 
-(unless (zlib-available?)
-  (exit 77))
-
 (test-begin "zlib")
 
+(unless (zlib-available?)
+  (test-skip 1))
 (test-assert "compression/decompression pipe"
   (let ((data (random-bytevector (+ (random 10000)
                                     (* 20 1024)))))