guix/gnu/build/shepherd.scm

228 lines
8.9 KiB
Scheme
Raw Normal View History

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build shepherd)
#:use-module (gnu system file-systems)
#:use-module (gnu build linux-container)
#:use-module (guix build utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (make-forkexec-constructor/container
fork+exec-command/container))
;;; Commentary:
;;;
;;; This module provides extensions to the GNU Shepherd. In particular, it
;;; provides a helper to start services in a container.
;;;
;;; Code:
(define (clean-up file)
(when file
(catch 'system-error
(lambda ()
(delete-file file))
(lambda args
(unless (= ENOENT (system-error-errno args))
(apply throw args))))))
(define-syntax-rule (catch-system-error exp)
(catch 'system-error
(lambda ()
exp)
(const #f)))
(define (default-namespaces args)
;; Most daemons are here to talk to the network, and most of them expect to
;; run under a non-zero UID.
(fold delq %namespaces '(net user)))
(define* (default-mounts #:key (namespaces (default-namespaces '())))
(define (tmpfs directory)
(file-system
(device "none")
(mount-point directory)
(type "tmpfs")
(check? #f)))
(define accounts
;; This is for processes in the default user namespace but living in a
;; different mount namespace, so that they can lookup users.
(list (file-system-mapping
(source "/etc/passwd") (target source))
(file-system-mapping
(source "/etc/group") (target source))))
(append (cons (tmpfs "/tmp") %container-file-systems)
(let ((mappings `(,@(if (memq 'net namespaces)
'()
%network-file-mappings)
,@(if (and (memq 'mnt namespaces)
(not (memq 'user namespaces)))
accounts
'())
;; Tell the process what timezone we're in. This
;; makes sure that, for instance, its syslog
;; messages have the correct timestamp.
,(file-system-mapping
(source "/etc/localtime")
(target source))
,%store-mapping))) ;XXX: coarse-grain
(map file-system-mapping->bind-mount
(filter (lambda (mapping)
(file-exists? (file-system-mapping-source mapping)))
mappings)))))
;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency.
(module-autoload! (current-module)
'(shepherd service)
'(fork+exec-command read-pid-file exec-command
%precious-signals))
(module-autoload! (current-module)
'(shepherd system) '(unblock-signals))
(define* (read-pid-file/container pid pid-file #:key (max-delay 5))
"Read PID-FILE in the container namespaces of PID, which exists in a
separate mount and PID name space. Return the \"outer\" PID. "
(match (container-excursion* pid
(lambda ()
(read-pid-file pid-file
#:max-delay max-delay)))
(#f
;; Send SIGTERM to the whole process group.
(catch-system-error (kill (- pid) SIGTERM))
#f)
((? integer? container-pid)
;; XXX: When COMMAND is started in a separate PID namespace, its
;; PID is always 1, but that's not what Shepherd needs to know.
pid)))
(define* (make-forkexec-constructor/container command
#:key
(namespaces
(default-namespaces args))
(mappings '())
(user #f)
(group #f)
(log-file #f)
pid-file
(pid-file-timeout 5)
(directory "/")
(environment-variables
(environ))
#:rest args)
"This is a variant of 'make-forkexec-constructor' that starts COMMAND in
NAMESPACES, a list of Linux namespaces such as '(mnt ipc). MAPPINGS is the
list of <file-system-mapping> to make in the case of a separate mount
namespace, in addition to essential bind-mounts such /proc."
(define container-directory
(match command
((program _ ...)
(string-append "/var/run/containers/" (basename program)))))
(define auto-mappings
`(,@(if log-file
(list (file-system-mapping
(source log-file)
(target source)
(writable? #t)))
'())))
(define mounts
(append (map file-system-mapping->bind-mount
(append auto-mappings mappings))
(default-mounts #:namespaces namespaces)))
(lambda args
(mkdir-p container-directory)
(when log-file
;; Create LOG-FILE so we can map it in the container.
(unless (file-exists? log-file)
(call-with-output-file log-file (const #t))
(when user
(let ((pw (getpwnam user)))
(chown log-file (passwd:uid pw) (passwd:gid pw))))))
(let ((pid (run-container container-directory
mounts namespaces 1
(lambda ()
;; First restore the default handlers.
(for-each (cut sigaction <> SIG_DFL)
%precious-signals)
;; Unblock any signals that have been blocked
;; by the parent process.
(unblock-signals %precious-signals)
(mkdir-p "/var/run")
(clean-up pid-file)
(exec-command command
#:user user
#:group group
#:log-file log-file
#:directory directory
#:environment-variables
environment-variables)))))
(if pid-file
(if (or (memq 'mnt namespaces) (memq 'pid namespaces))
(read-pid-file/container pid pid-file
#:max-delay pid-file-timeout)
(read-pid-file pid-file #:max-delay pid-file-timeout))
pid))))
(define* (fork+exec-command/container command
#:key pid
#:allow-other-keys
#:rest args)
"This is a variant of 'fork+exec-command' procedure, that joins the
namespaces of process PID beforehand. If there is no support for containers,
on Hurd systems for instance, fallback to direct forking."
(define (strip-pid args)
;; TODO: Replace with 'strip-keyword-arguments' when that no longer pulls
;; in (guix config).
(let loop ((args args)
(result '()))
(match args
(()
(reverse result))
((#:pid _ . rest)
(loop rest result))
((head . rest)
(loop rest (cons head result))))))
(let ((container-support?
(file-exists? "/proc/self/ns"))
(fork-proc (lambda ()
(apply fork+exec-command command
(strip-pid args)))))
(if container-support?
(container-excursion* pid fork-proc)
(fork-proc))))
;; Local Variables:
;; eval: (put 'container-excursion* 'scheme-indent-function 1)
;; End:
;;; shepherd.scm ends here