gnu/build/shepherd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017, 2018, 2019 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 (srfi srfi-1)
  24   #:use-module (ice-9 match)
  25   #:export (make-forkexec-constructor/container))
  26
  27 ;;; Commentary:
  28 ;;;
  29 ;;; This module provides extensions to the GNU Shepherd.  In particular, it
  30 ;;; provides a helper to start services in a container.
  31 ;;;
  32 ;;; Code:
  33
  34 (define (clean-up file)
  35   (when file
  36     (catch 'system-error
  37       (lambda ()
  38         (delete-file file))
  39       (lambda args
  40         (unless (= ENOENT (system-error-errno args))
  41           (apply throw args))))))
  42
  43 (define-syntax-rule (catch-system-error exp)
  44   (catch 'system-error
  45     (lambda ()
  46       exp)
  47     (const #f)))
  48
  49 (define (default-namespaces args)
  50   ;; Most daemons are here to talk to the network, and most of them expect to
  51   ;; run under a non-zero UID.
  52   (fold delq %namespaces '(net user)))
  53
  54 (define* (default-mounts #:key (namespaces (default-namespaces '())))
  55   (define (tmpfs directory)
  56     (file-system
  57       (device "none")
  58       (mount-point directory)
  59       (type "tmpfs")
  60       (check? #f)))
  61
  62   (define accounts
  63     ;; This is for processes in the default user namespace but living in a
  64     ;; different mount namespace, so that they can lookup users.
  65     (list (file-system-mapping
  66            (source "/etc/passwd") (target source))
  67           (file-system-mapping
  68            (source "/etc/group") (target source))))
  69
  70   (append (cons (tmpfs "/tmp") %container-file-systems)
  71           (let ((mappings `(,@(if (memq 'net namespaces)
  72                                   '()
  73                                   %network-file-mappings)
  74                             ,@(if (and (memq 'mnt namespaces)
  75                                        (not (memq 'user namespaces)))
  76                                   accounts
  77                                   '())
  78
  79                             ;; Tell the process what timezone we're in.  This
  80                             ;; makes sure that, for instance, its syslog
  81                             ;; messages have the correct timestamp.
  82                             ,(file-system-mapping
  83                               (source "/etc/localtime")
  84                               (target source))
  85
  86                             ,%store-mapping)))    ;XXX: coarse-grain
  87             (map file-system-mapping->bind-mount
  88                  (filter (lambda (mapping)
  89                            (file-exists? (file-system-mapping-source mapping)))
  90                          mappings)))))
  91
  92 ;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency.
  93 (module-autoload! (current-module)
  94                   '(shepherd service) '(read-pid-file exec-command))
  95
  96 (define* (read-pid-file/container pid pid-file #:key (max-delay 5))
  97   "Read PID-FILE in the container namespaces of PID, which exists in a
  98 separate mount and PID name space.  Return the \"outer\" PID. "
  99   (match (container-excursion* pid
 100            (lambda ()
 101              (read-pid-file pid-file
 102                             #:max-delay max-delay)))
 103     (#f
 104      (catch-system-error (kill pid SIGTERM))
 105      #f)
 106     ((? integer? container-pid)
 107      ;; XXX: When COMMAND is started in a separate PID namespace, its
 108      ;; PID is always 1, but that's not what Shepherd needs to know.
 109      pid)))
 110
 111 (define* (make-forkexec-constructor/container command
 112                                               #:key
 113                                               (namespaces
 114                                                (default-namespaces args))
 115                                               (mappings '())
 116                                               (user #f)
 117                                               (group #f)
 118                                               (log-file #f)
 119                                               pid-file
 120                                               (pid-file-timeout 5)
 121                                               (directory "/")
 122                                               (environment-variables
 123                                                (environ))
 124                                               #:rest args)
 125   "This is a variant of 'make-forkexec-constructor' that starts COMMAND in
 126 NAMESPACES, a list of Linux namespaces such as '(mnt ipc).  MAPPINGS is the
 127 list of <file-system-mapping> to make in the case of a separate mount
 128 namespace, in addition to essential bind-mounts such /proc."
 129   (define container-directory
 130     (match command
 131       ((program _  ...)
 132        (string-append "/var/run/containers/" (basename program)))))
 133
 134   (define auto-mappings
 135     `(,@(if log-file
 136             (list (file-system-mapping
 137                    (source log-file)
 138                    (target source)
 139                    (writable? #t)))
 140             '())))
 141
 142   (define mounts
 143     (append (map file-system-mapping->bind-mount
 144                  (append auto-mappings mappings))
 145             (default-mounts #:namespaces namespaces)))
 146
 147   (lambda args
 148     (mkdir-p container-directory)
 149
 150     (when log-file
 151       ;; Create LOG-FILE so we can map it in the container.
 152       (unless (file-exists? log-file)
 153         (call-with-output-file log-file (const #t))
 154         (when user
 155           (let ((pw (getpwnam user)))
 156             (chown log-file (passwd:uid pw) (passwd:gid pw))))))
 157
 158     (let ((pid (run-container container-directory
 159                               mounts namespaces 1
 160                               (lambda ()
 161                                 (mkdir-p "/var/run")
 162                                 (clean-up pid-file)
 163
 164                                 (exec-command command
 165                                               #:user user
 166                                               #:group group
 167                                               #:log-file log-file
 168                                               #:directory directory
 169                                               #:environment-variables
 170                                               environment-variables)))))
 171       (if pid-file
 172           (if (or (memq 'mnt namespaces) (memq 'pid namespaces))
 173               (read-pid-file/container pid pid-file
 174                                        #:max-delay pid-file-timeout)
 175               (read-pid-file pid-file #:max-delay pid-file-timeout))
 176           pid))))
 177
 178 ;; Local Variables:
 179 ;; eval: (put 'container-excursion* 'scheme-indent-function 1)
 180 ;; End:
 181
 182 ;;; shepherd.scm ends here