gnu/build/shepherd.scm

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