linux-container: 'container-excursion' forks to join the PID namespace.

Fixes <https://issues.guix.gnu.org/61156>.

* gnu/build/linux-container.scm (container-excursion): Add extra call to
'primitive-fork' and invoke THUNK in the child process.
* tests/containers.scm ("container-excursion"): Remove extra
'primitive-fork' call, now unnecessary.
("container-excursion*, /proc"): New test.

2 files changed, 40 insertions, 19 deletions

diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index d11c49c0d8..dee6885400 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2017-2019, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017-2019, 2022, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -432,7 +432,16 @@ return the exit status, an integer as returned by 'waitpid'."
                   '("user" "ipc" "uts" "net" "pid" "mnt"))
         (purify-environment)
         (chdir "/")
-        (thunk))))
+
+        ;; Per setns(2), changing the PID namespace only applies to child
+        ;; processes, not to the process itself.  Thus fork so that THUNK runs
+        ;; in the right PID namespace, which also gives it access to /proc.
+        (match (primitive-fork)
+          (0 (call-with-clean-exit thunk))
+          (pid (primitive-exit
+                (match (waitpid pid)
+                  ((_ . status)
+                   (or (status:exit-val status) 127)))))))))
     (pid
      (match (waitpid pid)
        ((_ . status)
diff --git a/tests/containers.scm b/tests/containers.scm
index 1378b10f22..70d5ba2d30 100644
--- a/tests/containers.scm
+++ b/tests/containers.scm
@@ -1,6 +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>
+;;; Copyright © 2016, 2017, 2019, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -31,7 +31,8 @@
   #:use-module (guix tests)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64)
-  #:use-module (ice-9 match))
+  #:use-module (ice-9 match)
+  #:use-module ((ice-9 ftw) #:select (scandir)))
 
 (define (assert-exit x)
   (primitive-exit (if x 0 1)))
@@ -176,21 +177,11 @@
                   (close start-in)
                   (container-excursion pid
                     (lambda ()
-                      ;; Fork again so that the pid is within the context of
-                      ;; the joined pid namespace instead of the original pid
-                      ;; namespace.
-                      (match (primitive-fork)
-                        (0
-                         ;; Check that all of the namespace identifiers are
-                         ;; the same as the container process.
-                         (assert-exit
-                          (equal? container-namespaces
-                                  (namespaces (getpid)))))
-                        (fork-pid
-                         (match (waitpid fork-pid)
-                           ((_ . status)
-                            (primitive-exit
-                             (status:exit-val status)))))))))))
+                      ;; Check that all of the namespace identifiers are
+                      ;; the same as the container process.
+                      (assert-exit
+                       (equal? container-namespaces
+                               (namespaces (getpid)))))))))
           (close end-in)
           ;; Stop the container.
           (write 'done end-out)
@@ -237,6 +228,27 @@
       (* 6 7))))
 
 (skip-if-unsupported)
+(test-equal "container-excursion*, /proc"
+  '("1" "2")
+  (call-with-temporary-directory
+   (lambda (root)
+     (let* ((pid    (run-container root '()
+                                   %namespaces 1
+                                   (lambda ()
+                                     (sleep 100))))
+            (result (container-excursion* pid
+                      (lambda ()
+                        ;; We expect to see exactly two processes in this
+                        ;; namespace.
+                        (scandir "/proc"
+                                 (lambda (file)
+                                   (char-set-contains?
+                                    char-set:digit
+                                    (string-ref file 0))))))))
+       (kill pid SIGKILL)
+       result))))
+
+(skip-if-unsupported)
 (test-equal "eval/container, exit status"
   42
   (let* ((store  (open-connection-for-tests))