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.

1 files changed, 29 insertions, 17 deletions

diff --git a/tests/containers.scm b/tests/containers.scm
index 1378b10f22b..70d5ba2d309 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))