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