Merge branch 'master' into core-updates

1 files changed, 62 insertions, 30 deletions

diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm
index 778e3fc627..f4caefce3c 100644
--- a/gnu/build/shepherd.scm
+++ b/gnu/build/shepherd.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
+;;; Copyright © 2022 Leo Nikkilä <hello@lnikki.la>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -30,7 +31,8 @@
                                  exec-command
                                  %precious-signals)
   #:autoload (shepherd system) (unblock-signals)
-  #:export (make-forkexec-constructor/container
+  #:export (default-mounts
+            make-forkexec-constructor/container
             fork+exec-command/container))
 
 ;;; Commentary:
@@ -103,8 +105,13 @@
 separate mount and PID name space.  Return the \"outer\" PID. "
   (match (container-excursion* pid
            (lambda ()
-             (read-pid-file pid-file
-                            #:max-delay max-delay)))
+             ;; XXX: Trick for Shepherd 0.9: prevent 'read-pid-file' from
+             ;; using (@ (fibers) sleep), which would try to suspend the
+             ;; current task, which doesn't work in this extra process.
+             (with-continuation-barrier
+              (lambda ()
+                (read-pid-file pid-file
+                               #:max-delay max-delay)))))
     (#f
      ;; Send SIGTERM to the whole process group.
      (catch-system-error (kill (- pid) SIGTERM))
@@ -114,6 +121,28 @@ separate mount and PID name space.  Return the \"outer\" PID. "
      ;; PID is always 1, but that's not what Shepherd needs to know.
      pid)))
 
+(define* (exec-command* command #:key user group log-file pid-file
+                        (supplementary-groups '())
+                        (directory "/") (environment-variables (environ)))
+  "Like 'exec-command', but first restore signal handles modified by
+shepherd (PID 1)."
+  ;; First restore the default handlers.
+  (for-each (cut sigaction <> SIG_DFL) %precious-signals)
+
+  ;; Unblock any signals that have been blocked by the parent process.
+  (unblock-signals %precious-signals)
+
+  (mkdir-p "/var/run")
+  (clean-up pid-file)
+
+  (exec-command command
+                #:user user
+                #:group group
+                #:supplementary-groups supplementary-groups
+                #:log-file log-file
+                #:directory directory
+                #:environment-variables environment-variables))
+
 (define* (make-forkexec-constructor/container command
                                               #:key
                                               (namespaces
@@ -121,6 +150,7 @@ separate mount and PID name space.  Return the \"outer\" PID. "
                                               (mappings '())
                                               (user #f)
                                               (group #f)
+                                              (supplementary-groups '())
                                               (log-file #f)
                                               pid-file
                                               (pid-file-timeout 5)
@@ -164,24 +194,16 @@ namespace, in addition to essential bind-mounts such /proc."
     (let ((pid (run-container container-directory
                               mounts namespaces 1
                               (lambda ()
-                                ;; First restore the default handlers.
-                                (for-each (cut sigaction <> SIG_DFL)
-                                          %precious-signals)
-
-                                ;; Unblock any signals that have been blocked
-                                ;; by the parent process.
-                                (unblock-signals %precious-signals)
-
-                                (mkdir-p "/var/run")
-                                (clean-up pid-file)
-
-                                (exec-command command
-                                              #:user user
-                                              #:group group
-                                              #:log-file log-file
-                                              #:directory directory
-                                              #:environment-variables
-                                              environment-variables)))))
+                                (exec-command* command
+                                               #:user user
+                                               #:group group
+                                               #:supplementary-groups
+                                               supplementary-groups
+                                               #:pid-file pid-file
+                                               #:log-file log-file
+                                               #:directory directory
+                                               #:environment-variables
+                                               environment-variables)))))
       (if pid-file
           (if (or (memq 'mnt namespaces) (memq 'pid namespaces))
               (read-pid-file/container pid pid-file
@@ -209,14 +231,24 @@ on Hurd systems for instance, fallback to direct forking."
         ((head . rest)
          (loop rest (cons head result))))))
 
-  (let ((container-support?
-         (file-exists? "/proc/self/ns"))
-        (fork-proc (lambda ()
-                     (apply fork+exec-command command
-                            (strip-pid args)))))
-    (if container-support?
-        (container-excursion* pid fork-proc)
-        (fork-proc))))
+  (let ((container-support? (file-exists? "/proc/self/ns")))
+    (if (and container-support?
+             (not (and pid (= pid (getpid)))))
+        (container-excursion* pid
+          (lambda ()
+            ;; Note: In the Shepherd 0.9, 'fork+exec-command' expects to be
+            ;; called from the shepherd process (because it creates a pipe to
+            ;; capture stdout/stderr and spawns a logging fiber) so we cannot
+            ;; use it here.
+            (match (primitive-fork)
+              (0 (dynamic-wind
+                   (const #t)
+                   (lambda ()
+                     (apply exec-command* command (strip-pid args)))
+                   (lambda ()
+                     (primitive-_exit 127))))
+              (pid pid))))               ;XXX: assuming the same PID namespace
+        (apply fork+exec-command command (strip-pid args)))))
 
 ;; Local Variables:
 ;; eval: (put 'container-excursion* 'scheme-indent-function 1)