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