tests: Run in a chroot and unprivileged user namespaces.

* build-aux/test-env.in: Pass ‘--disable-chroot’ only when unprivileged
user namespace support is lacking and warn in that case.
* tests/store.scm ("build-things, check mode"): Use ‘gettimeofday’
rather than a shared file as a source of entropy.
("symlink is symlink")
("isolated environment", "inputs are read-only")
("inputs cannot be remounted read-write")
("build root cannot be made world-readable")
("/tmp, store, and /dev/{null,full} are writable")
("network is unreachable"): New tests.
* tests/processes.scm ("client + lock"): Skip when
‘unprivileged-user-namespace-supported?’ returns true.

Change-Id: I3b3c3ebdf6db5fd36ee70251d07b893c17ca1b84

3 files changed, 236 insertions, 38 deletions

diff --git a/build-aux/test-env.in b/build-aux/test-env.in
index 9caa29da58..86c2e585d7 100644
--- a/build-aux/test-env.in
+++ b/build-aux/test-env.in
@@ -1,7 +1,7 @@
 #!/bin/sh
 
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2012-2019, 2021, 2025 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -102,10 +102,24 @@ then
     rm -rf "$GUIX_STATE_DIRECTORY/daemon-socket"
     mkdir -m 0700 "$GUIX_STATE_DIRECTORY/daemon-socket"
 
+    # If unprivileged user namespaces are not supported, pass
+    # '--disable-chroot'.
+    if [ -f /proc/self/ns/user ] \
+       && { [ ! -f /proc/sys/kernel/unprivileged_userns_clone ] \
+		|| [ "$(cat /proc/sys/kernel/unprivileged_userns_clone)" -eq 1 ]; }
+    then
+	extra_options=""
+    else
+	extra_options="--disable-chroot"
+	echo "unprivileged user namespaces not supported; \
+running 'guix-daemon $extra_options'" >&2
+    fi
+
     # Launch the daemon without chroot support because is may be
     # unavailable, for instance if we're not running as root.
     "@abs_top_builddir@/pre-inst-env"				\
-	"@abs_top_builddir@/guix-daemon" --disable-chroot	\
+	"@abs_top_builddir@/guix-daemon"			\
+        $extra_options						\
 	--substitute-urls="$GUIX_BINARY_SUBSTITUTE_URL" &
 
     daemon_pid=$!
diff --git a/tests/processes.scm b/tests/processes.scm
index ba518f2d9e..a72ba16f58 100644
--- a/tests/processes.scm
+++ b/tests/processes.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2025 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -25,6 +25,8 @@
   #:use-module (guix gexp)
   #:use-module ((guix utils) #:select (call-with-temporary-directory))
   #:use-module (gnu packages bootstrap)
+  #:use-module ((gnu build linux-container)
+                #:select (unprivileged-user-namespace-supported?))
   #:use-module (guix tests)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64)
@@ -84,6 +86,11 @@
       (and (kill (process-id daemon) 0)
            (string-suffix? "guix-daemon" (first (process-command daemon)))))))
 
+(when (unprivileged-user-namespace-supported?)
+  ;; The test below assumes the build process can communicate with the outside
+  ;; world via the TOKEN1 and TOKEN2 files, which is impossible when
+  ;; guix-daemon is set up to build in separate namespaces.
+  (test-skip 1))
 (test-assert* "client + lock"
   (with-store store
     (call-with-temporary-directory
diff --git a/tests/store.scm b/tests/store.scm
index 45948f4f43..b1ddff2082 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2021, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2021, 2023, 2025 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,8 +28,12 @@
   #:use-module (guix base32)
   #:use-module (guix packages)
   #:use-module (guix derivations)
+  #:use-module ((guix modules)
+                #:select (source-module-closure))
   #:use-module (guix serialization)
   #:use-module (guix build utils)
+  #:use-module ((gnu build linux-container)
+                #:select (unprivileged-user-namespace-supported?))
   #:use-module (guix gexp)
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
@@ -391,6 +395,188 @@
          (equal? (valid-derivers %store o)
                  (list (derivation-file-name d))))))
 
+(test-assert "symlink is symlink"
+  (let* ((a (add-text-to-store %store "hello.txt" (random-text)))
+         (b (build-expression->derivation
+             %store "symlink"
+             '(symlink (assoc-ref %build-inputs "a") %output)
+             #:inputs `(("a" ,a))))
+         (c (build-expression->derivation
+             %store "symlink-reference"
+             `(call-with-output-file %output
+                (lambda (port)
+                  ;; Check that B is indeed visible as a symlink.  This should
+                  ;; always be the case, both in the '--disable-chroot' and in
+                  ;; the user namespace setups.
+                  (pk 'stat (lstat (assoc-ref %build-inputs "b")))
+                  (display (readlink (assoc-ref %build-inputs "b"))
+                           port)))
+             #:inputs `(("b" ,b)))))
+    (and (build-derivations %store (list c))
+         (string=? (call-with-input-file (derivation->output-path c)
+                     get-string-all)
+                   a))))
+
+(unless (unprivileged-user-namespace-supported?)
+  (test-skip 1))
+(test-equal "isolated environment"
+  (string-join (append
+                '("PID: 1" "UID: 30001")
+                (delete-duplicates
+                 (sort (list "/dev" "/tmp" "/proc" "/etc"
+                             (match (string-tokenize (%store-prefix)
+                                                     (char-set-complement
+                                                      (char-set #\/)))
+                               ((top _ ...) (string-append "/" top))))
+                       string<?))
+                '("/etc/group" "/etc/hosts" "/etc/passwd")))
+  (let* ((b (add-text-to-store %store "build.sh"
+                               "echo -n PID: $$ UID: $UID /* /etc/* > $out"))
+         (s (add-to-store %store "bash" #t "sha256"
+                          (search-bootstrap-binary "bash"
+                                                   (%current-system))))
+         (d (derivation %store "the-thing"
+                        s `("-e" ,b)
+                        #:env-vars `(("foo" . ,(random-text)))
+                        #:sources (list b s)))
+         (o (derivation->output-path d)))
+    (and (build-derivations %store (list d))
+         (call-with-input-file o get-string-all))))
+
+(unless (unprivileged-user-namespace-supported?)
+  (test-skip 1))
+(test-equal "inputs are read-only"
+  "All good!"
+  (let* ((input (plain-file (string-append "might-be-tampered-with-"
+                                           (number->string
+                                            (car (gettimeofday))
+                                            16))
+                            "All good!"))
+         (drv
+          (run-with-store %store
+            (gexp->derivation
+             "attempt-to-write-to-input"
+             (with-imported-modules (source-module-closure
+                                     '((guix build syscalls)))
+               #~(begin
+                   (use-modules (guix build syscalls))
+
+                   (let ((input #$input))
+                     (chmod input #o666)
+                     (call-with-output-file input
+                       (lambda (port)
+                         (display "BAD!" port)))
+                     (mkdir #$output))))))))
+    (and (guard (c ((store-protocol-error? c) #t))
+           (build-derivations %store (list drv)))
+         (call-with-input-file (run-with-store %store
+                                 (lower-object input))
+           get-string-all))))
+
+(unless (unprivileged-user-namespace-supported?)
+  (test-skip 1))
+(test-assert "inputs cannot be remounted read-write"
+  (let ((drv
+         (run-with-store %store
+           (gexp->derivation
+            "attempt-to-remount-input-read-write"
+            (with-imported-modules (source-module-closure
+                                    '((guix build syscalls)))
+              #~(begin
+                  (use-modules (guix build syscalls))
+
+                  (let ((input #$(plain-file "input-that-might-be-tampered-with"
+                                             "All good!")))
+                    (mount "none" input "none" (logior MS_BIND MS_REMOUNT))
+                    (call-with-output-file input
+                      (lambda (port)
+                        (display "BAD!" port)))
+                    (mkdir #$output))))))))
+    (guard (c ((store-protocol-error? c) #t))
+      (build-derivations %store (list drv))
+      #f)))
+
+(unless (unprivileged-user-namespace-supported?)
+  (test-skip 1))
+(test-assert "build root cannot be made world-readable"
+  (let ((drv
+         (run-with-store %store
+           (gexp->derivation
+            "attempt-to-make-root-world-readable"
+            (with-imported-modules (source-module-closure
+                                    '((guix build syscalls)))
+              #~(begin
+                  (use-modules (guix build syscalls))
+
+                  (catch 'system-error
+                    (lambda ()
+                      (chmod "/" #o777))
+                    (lambda args
+                      (format #t "failed to make root writable: ~a~%"
+                              (strerror (system-error-errno args)))
+                      (format #t "attempting read-write remount~%")
+                      (mount "none" "/" "/" (logior MS_BIND MS_REMOUNT))
+                      (chmod "/" #o777)))
+
+                  ;; At this point, the build process could create a
+                  ;; world-readable setuid binary under its root (so in the
+                  ;; store) that would remain visible until the build
+                  ;; completes.
+                  (mkdir #$output)))))))
+    (guard (c ((store-protocol-error? c) #t))
+      (build-derivations %store (list drv))
+      #f)))
+
+(unless (unprivileged-user-namespace-supported?)
+  (test-skip 1))
+(test-assert "/tmp, store, and /dev/{null,full} are writable"
+  ;; All of /tmp and all of the store must be writable (the store is writable
+  ;; so that derivation outputs can be written to it, but in practice it's
+  ;; always been wide open).  Things like /dev/null must be writable too.
+  (let ((drv (run-with-store %store
+               (gexp->derivation
+                "check-tmp-and-store-are-writable"
+                #~(begin
+                    (mkdir "/tmp/something")
+                    (mkdir (in-vicinity (getenv "NIX_STORE")
+                                        "some-other-thing"))
+                    (call-with-output-file "/dev/null"
+                      (lambda (port)
+                        (display "Welcome to the void." port)))
+                    (catch 'system-error
+                      (lambda ()
+                        (call-with-output-file "/dev/full"
+                          (lambda (port)
+                            (display "No space left!" port)))
+                        (error "Should have thrown!"))
+                      (lambda args
+                        (unless (= ENOSPC (system-error-errno args))
+                          (apply throw args))))
+                    (mkdir #$output))))))
+    (build-derivations %store (list drv))))
+
+(unless (unprivileged-user-namespace-supported?)
+  (test-skip 1))
+(test-assert "network is unreachable"
+  (let ((drv (run-with-store %store
+               (gexp->derivation
+                "check-network-unreachable"
+                #~(let ((check-connection-failure
+                         (lambda (address expected-code)
+                           (let ((s (socket AF_INET SOCK_STREAM 0)))
+                             (catch 'system-error
+                               (lambda ()
+                                 (connect s AF_INET (inet-pton AF_INET address) 80))
+                               (lambda args
+                                 (let ((errno (system-error-errno args)))
+                                   (unless (= expected-code errno)
+                                     (error "wrong error code"
+                                            errno (strerror errno))))))))))
+                    (check-connection-failure "127.0.0.1" ECONNREFUSED)
+                    (check-connection-failure "9.9.9.9" ENETUNREACH)
+                    (mkdir #$output))))))
+    (build-derivations %store (list drv))))
+
 (test-equal "with-build-handler"
   'success
   (let* ((b  (add-text-to-store %store "build" "echo $foo > $out" '()))
@@ -1333,40 +1519,31 @@ System: x86_64-linux~%"
 
 (test-assert "build-things, check mode"
   (with-store store
-    (call-with-temporary-output-file
-     (lambda (entropy entropy-port)
-       (write (random-text) entropy-port)
-       (force-output entropy-port)
-       (let* ((drv  (build-expression->derivation
-                     store "non-deterministic"
-                     `(begin
-                        (use-modules (rnrs io ports))
-                        (let ((out (assoc-ref %outputs "out")))
-                          (call-with-output-file out
-                            (lambda (port)
-                              ;; Rely on the fact that tests do not use the
-                              ;; chroot, and thus ENTROPY is readable.
-                              (display (call-with-input-file ,entropy
-                                         get-string-all)
-                                       port)))
-                          #t))
-                     #:guile-for-build
-                     (package-derivation store %bootstrap-guile (%current-system))))
-              (file (derivation->output-path drv)))
-         (and (build-things store (list (derivation-file-name drv)))
-              (begin
-                (write (random-text) entropy-port)
-                (force-output entropy-port)
-                (guard (c ((store-protocol-error? c)
-                           (pk 'determinism-exception c)
-                           (and (not (zero? (store-protocol-error-status c)))
-                                (string-contains (store-protocol-error-message c)
-                                                 "deterministic"))))
-                  ;; This one will produce a different result.  Since we're in
-                  ;; 'check' mode, this must fail.
-                  (build-things store (list (derivation-file-name drv))
-                                (build-mode check))
-                  #f))))))))
+    (let* ((drv  (build-expression->derivation
+                  store "non-deterministic"
+                  `(begin
+                     (use-modules (rnrs io ports))
+                     (let ((out (assoc-ref %outputs "out")))
+                       (call-with-output-file out
+                         (lambda (port)
+                           (let ((now (gettimeofday)))
+                             (display (+ (car now) (cdr now)) port))))
+                       #t))
+                  #:guile-for-build
+                  (package-derivation store %bootstrap-guile (%current-system))))
+           (file (derivation->output-path drv)))
+      (and (build-things store (list (derivation-file-name drv)))
+           (begin
+             (guard (c ((store-protocol-error? c)
+                        (pk 'determinism-exception c)
+                        (and (not (zero? (store-protocol-error-status c)))
+                             (string-contains (store-protocol-error-message c)
+                                              "deterministic"))))
+               ;; This one will produce a different result.  Since we're in
+               ;; 'check' mode, this must fail.
+               (build-things store (list (derivation-file-name drv))
+                             (build-mode check))
+               #f))))))
 
 (test-assert "build-succeeded trace in check mode"
   (string-contains