diff options
author | Ludovic Courtès <ludo@gnu.org> | 2022-04-28 16:24:46 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2022-04-28 16:24:46 +0200 |
commit | 284fa7264963acc5d114ef5d54c347126b1654ba (patch) | |
tree | 3e5360fcc81b6d0dce76a65aca60cf8528f2931f /gnu/build/shepherd.scm | |
parent | 12c9da35389dfba86ae0d863132a6b2c4374205a (diff) | |
parent | 882cacc1bb5be0df334dd7ce55b385a3a1678728 (diff) | |
download | guix-patches-284fa7264963acc5d114ef5d54c347126b1654ba.tar guix-patches-284fa7264963acc5d114ef5d54c347126b1654ba.tar.gz |
Merge branch 'master' into staging
Diffstat (limited to 'gnu/build/shepherd.scm')
-rw-r--r-- | gnu/build/shepherd.scm | 89 |
1 files changed, 60 insertions, 29 deletions
diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm index 778e3fc627..d52e53eb78 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. ;;; @@ -103,8 +104,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 +120,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 +149,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 +193,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 +230,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) |