Subject: [PATCH v2 5/9] DRAFT tests: Run in a chroot and unprivileged user namespaces.

From: Ludovic Courtès <[email-masked]>
Date: Thu, 13 Feb 2025 13:13:08 +0100

DRAFT:

  - Double-check the test suite.

* build-aux/test-env.in: Pass ‘--disable-chroot’ only when unprivileged
user namespace support is lacking.
* tests/store.scm ("build-things, check mode"): Use ‘gettimeofday’
rather than a shared file as a source of entropy.
("isolated environment", "inputs are read-only")
("inputs cannot be remounted read-write"): New tests.

Change-Id: Iedb816ef548c77799e5b2f9b6a3b7510ad19ec2a
---
 build-aux/test-env.in |  14 +++-
 tests/store.scm       | 144 ++++++++++++++++++++++++++++++++----------
 2 files changed, 121 insertions(+), 37 deletions(-)

diff --git a/build-aux/test-env.in b/build-aux/test-env.in
index 9caa29da581..5626152b346 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 <[email-masked]>
+# Copyright © 2012-2019, 2021, 2025 Ludovic Courtès <[email-masked]>
 #
 # This file is part of GNU Guix.
 #
@@ -102,10 +102,20 @@ 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/sys/kernel/unprivileged_userns_clone ] \
+       || [ "$(cat /proc/sys/kernel/unprivileged_userns_clone)" -eq 1 ]; then
+	extra_options=""
+    else
+	extra_options="--disable-chroot"
+    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/store.scm b/tests/store.scm
index 45948f4f433..cf19cf91211 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 <[email-masked]>
+;;; Copyright © 2012-2021, 2023, 2025 Ludovic Courtès <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,8 +28,12 @@ (define-module (test-store)
   #: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,85 @@ (define %shell
          (equal? (valid-derivers %store o)
                  (list (derivation-file-name d))))))
 
+(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-remount-input-read-write"
+             (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)))
+
 (test-equal "with-build-handler"
   'success
   (let* ((b  (add-text-to-store %store "build" "echo $foo > $out" '()))
@@ -1333,40 +1416,31 @@ (define %shell
 
 (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
-- 
2.48.1