build: linux-container: Fix run-container.

[jackhill/guix/guix.git] / gnu / build / linux-container.scm

diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index e86ac60..2d4de78 100644 (file)
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -130,9 +130,14 @@ for the process."
               "/dev/random"
               "/dev/urandom"
               "/dev/tty"
-              "/dev/ptmx"
               "/dev/fuse"))
 
+  ;; Mount a new devpts instance on /dev/pts.
+  (when (file-exists? "/dev/ptmx")
+    (mount* "none" (scope "/dev/pts") "devpts" 0
+            "newinstance,mode=0620")
+    (symlink "/dev/pts/ptmx" (scope "/dev/ptmx")))
+
   ;; Setup the container's /dev/console by bind mounting the pseudo-terminal
   ;; associated with standard input when there is one.
   (let* ((in      (current-input-port))
@@ -238,7 +243,8 @@ that host UIDs (respectively GIDs) map to in the namespace."
              (match (read child)
                ('ready
                 (purify-environment)
-                (when (memq 'mnt namespaces)
+                (when (and (memq 'mnt namespaces)
+                           (not (string=? root "/")))
                   (catch #t
                     (lambda ()
                       (mount-file-systems root mounts
@@ -294,8 +300,10 @@ delete it when leaving the dynamic extent of this call."
         (false-if-exception (delete-file-recursively tmp-dir))))))
 
 (define* (call-with-container mounts thunk #:key (namespaces %namespaces)
-                              (host-uids 1) (guest-uid 0) (guest-gid 0))
-  "Run THUNK in a new container process and return its exit status.
+                              (host-uids 1) (guest-uid 0) (guest-gid 0)
+                              (process-spawned-hook (const #t)))
+  "Run THUNK in a new container process and return its exit status; call
+PROCESS-SPAWNED-HOOK with the PID of the new process that has been spawned.
 MOUNTS is a list of <file-system> objects that specify file systems to mount
 inside the container.  NAMESPACES is a list of symbols corresponding to
 the identifiers for Linux namespaces: mnt, ipc, uts, pid, user, and net.  By
@@ -324,6 +332,7 @@ load path must be adjusted as needed."
            (false-if-exception
             (kill pid SIGKILL))))
 
+       (process-spawned-hook pid)
        (match (waitpid pid)
          ((_ . status) status))))))