gnu/build/shepherd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017, 2018, 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
   4 ;;; Copyright © 2022 Leo Nikkilä <hello@lnikki.la>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (gnu build shepherd)
  22   #:use-module (gnu system file-systems)
  23   #:use-module (gnu build linux-container)
  24   #:use-module (guix build utils)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-26)
  27   #:use-module (ice-9 match)
  28   ;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency.
  29   #:autoload (shepherd service) (fork+exec-command
  30                                  read-pid-file
  31                                  exec-command
  32                                  %precious-signals)
  33   #:autoload (shepherd system) (unblock-signals)
  34   #:export (default-mounts
  35             make-forkexec-constructor/container
  36             fork+exec-command/container))
  37
  38 ;;; Commentary:
  39 ;;;
  40 ;;; This module provides extensions to the GNU Shepherd.  In particular, it
  41 ;;; provides a helper to start services in a container.
  42 ;;;
  43 ;;; Code:
  44
  45 (define (clean-up file)
  46   (when file
  47     (catch 'system-error
  48       (lambda ()
  49         (delete-file file))
  50       (lambda args
  51         (unless (= ENOENT (system-error-errno args))
  52           (apply throw args))))))
  53
  54 (define-syntax-rule (catch-system-error exp)
  55   (catch 'system-error
  56     (lambda ()
  57       exp)
  58     (const #f)))
  59
  60 (define (default-namespaces args)
  61   ;; Most daemons are here to talk to the network, and most of them expect to
  62   ;; run under a non-zero UID.
  63   (fold delq %namespaces '(net user)))
  64
  65 (define* (default-mounts #:key (namespaces (default-namespaces '())))
  66   (define (tmpfs directory)
  67     (file-system
  68       (device "none")
  69       (mount-point directory)
  70       (type "tmpfs")
  71       (check? #f)))
  72
  73   (define accounts
  74     ;; This is for processes in the default user namespace but living in a
  75     ;; different mount namespace, so that they can lookup users.
  76     (list (file-system-mapping
  77            (source "/etc/passwd") (target source))
  78           (file-system-mapping
  79            (source "/etc/group") (target source))))
  80
  81   (append (cons (tmpfs "/tmp") %container-file-systems)
  82           (let ((mappings `(,@(if (memq 'net namespaces)
  83                                   '()
  84                                   %network-file-mappings)
  85                             ,@(if (and (memq 'mnt namespaces)
  86                                        (not (memq 'user namespaces)))
  87                                   accounts
  88                                   '())
  89
  90                             ;; Tell the process what timezone we're in.  This
  91                             ;; makes sure that, for instance, its syslog
  92                             ;; messages have the correct timestamp.
  93                             ,(file-system-mapping
  94                               (source "/etc/localtime")
  95                               (target source))
  96
  97                             ,%store-mapping)))    ;XXX: coarse-grain
  98             (map file-system-mapping->bind-mount
  99                  (filter (lambda (mapping)
 100                            (file-exists? (file-system-mapping-source mapping)))
 101                          mappings)))))
 102
 103 (define* (read-pid-file/container pid pid-file #:key (max-delay 5))
 104   "Read PID-FILE in the container namespaces of PID, which exists in a
 105 separate mount and PID name space.  Return the \"outer\" PID. "
 106   (match (container-excursion* pid
 107            (lambda ()
 108              ;; XXX: Trick for Shepherd 0.9: prevent 'read-pid-file' from
 109              ;; using (@ (fibers) sleep), which would try to suspend the
 110              ;; current task, which doesn't work in this extra process.
 111              (with-continuation-barrier
 112               (lambda ()
 113                 (read-pid-file pid-file
 114                                #:max-delay max-delay)))))
 115     (#f
 116      ;; Send SIGTERM to the whole process group.
 117      (catch-system-error (kill (- pid) SIGTERM))
 118      #f)
 119     ((? integer? container-pid)
 120      ;; XXX: When COMMAND is started in a separate PID namespace, its
 121      ;; PID is always 1, but that's not what Shepherd needs to know.
 122      pid)))
 123
 124 (define* (exec-command* command #:key user group log-file pid-file
 125                         (supplementary-groups '())
 126                         (directory "/") (environment-variables (environ)))
 127   "Like 'exec-command', but first restore signal handles modified by
 128 shepherd (PID 1)."
 129   ;; First restore the default handlers.
 130   (for-each (cut sigaction <> SIG_DFL) %precious-signals)
 131
 132   ;; Unblock any signals that have been blocked by the parent process.
 133   (unblock-signals %precious-signals)
 134
 135   (mkdir-p "/var/run")
 136   (clean-up pid-file)
 137
 138   (exec-command command
 139                 #:user user
 140                 #:group group
 141                 #:supplementary-groups supplementary-groups
 142                 #:log-file log-file
 143                 #:directory directory
 144                 #:environment-variables environment-variables))
 145
 146 (define* (make-forkexec-constructor/container command
 147                                               #:key
 148                                               (namespaces
 149                                                (default-namespaces args))
 150                                               (mappings '())
 151                                               (user #f)
 152                                               (group #f)
 153                                               (supplementary-groups '())
 154                                               (log-file #f)
 155                                               pid-file
 156                                               (pid-file-timeout 5)
 157                                               (directory "/")
 158                                               (environment-variables
 159                                                (environ))
 160                                               #:rest args)
 161   "This is a variant of 'make-forkexec-constructor' that starts COMMAND in
 162 NAMESPACES, a list of Linux namespaces such as '(mnt ipc).  MAPPINGS is the
 163 list of <file-system-mapping> to make in the case of a separate mount
 164 namespace, in addition to essential bind-mounts such /proc."
 165   (define container-directory
 166     (match command
 167       ((program _  ...)
 168        (string-append "/var/run/containers/" (basename program)))))
 169
 170   (define auto-mappings
 171     `(,@(if log-file
 172             (list (file-system-mapping
 173                    (source log-file)
 174                    (target source)
 175                    (writable? #t)))
 176             '())))
 177
 178   (define mounts
 179     (append (map file-system-mapping->bind-mount
 180                  (append auto-mappings mappings))
 181             (default-mounts #:namespaces namespaces)))
 182
 183   (lambda args
 184     (mkdir-p container-directory)
 185
 186     (when log-file
 187       ;; Create LOG-FILE so we can map it in the container.
 188       (unless (file-exists? log-file)
 189         (call-with-output-file log-file (const #t))
 190         (when user
 191           (let ((pw (getpwnam user)))
 192             (chown log-file (passwd:uid pw) (passwd:gid pw))))))
 193
 194     (let ((pid (run-container container-directory
 195                               mounts namespaces 1
 196                               (lambda ()
 197                                 (exec-command* command
 198                                                #:user user
 199                                                #:group group
 200                                                #:supplementary-groups
 201                                                supplementary-groups
 202                                                #:pid-file pid-file
 203                                                #:log-file log-file
 204                                                #:directory directory
 205                                                #:environment-variables
 206                                                environment-variables)))))
 207       (if pid-file
 208           (if (or (memq 'mnt namespaces) (memq 'pid namespaces))
 209               (read-pid-file/container pid pid-file
 210                                        #:max-delay pid-file-timeout)
 211               (read-pid-file pid-file #:max-delay pid-file-timeout))
 212           pid))))
 213
 214 (define* (fork+exec-command/container command
 215                                       #:key pid
 216                                       #:allow-other-keys
 217                                       #:rest args)
 218   "This is a variant of 'fork+exec-command' procedure, that joins the
 219 namespaces of process PID beforehand.  If there is no support for containers,
 220 on Hurd systems for instance, fallback to direct forking."
 221   (define (strip-pid args)
 222     ;; TODO: Replace with 'strip-keyword-arguments' when that no longer pulls
 223     ;; in (guix config).
 224     (let loop ((args args)
 225                (result '()))
 226       (match args
 227         (()
 228          (reverse result))
 229         ((#:pid _ . rest)
 230          (loop rest result))
 231         ((head . rest)
 232          (loop rest (cons head result))))))
 233
 234   (let ((container-support? (file-exists? "/proc/self/ns")))
 235     (if (and container-support?
 236              (not (and pid (= pid (getpid)))))
 237         (container-excursion* pid
 238           (lambda ()
 239             ;; Note: In the Shepherd 0.9, 'fork+exec-command' expects to be
 240             ;; called from the shepherd process (because it creates a pipe to
 241             ;; capture stdout/stderr and spawns a logging fiber) so we cannot
 242             ;; use it here.
 243             (match (primitive-fork)
 244               (0 (dynamic-wind
 245                    (const #t)
 246                    (lambda ()
 247                      (apply exec-command* command (strip-pid args)))
 248                    (lambda ()
 249                      (primitive-_exit 127))))
 250               (pid pid))))               ;XXX: assuming the same PID namespace
 251         (apply fork+exec-command command (strip-pid args)))))
 252
 253 ;; Local Variables:
 254 ;; eval: (put 'container-excursion* 'scheme-indent-function 1)
 255 ;; End:
 256
 257 ;;; shepherd.scm ends here