projects/guix·blob java-team · refs

168 lines · 6.3 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2017, 2018, 2019, 2020, 2022 Ludovic Courtès <[email protected]>
3;;; Copyright © 2020 Mathieu Othacehe <[email protected]>
4;;; Copyright © 2022 Leo Nikkilä <[email protected]>
5;;; Copyright © 2022 Arun Isaac <[email protected]>
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 fork+exec-command/container))
37
38;;; Commentary:
39;;;
40;;; This module provides extensions to the GNU Shepherd. In particular, it
41;;; provides a helper to start services in a container.
42;;;
43;;; Code:
44
45(define (clean-up file)
46 (when file
47 (catch 'system-error
48 (lambda ()
49 (delete-file file))
50 (lambda args
51 (unless (= ENOENT (system-error-errno args))
52 (apply throw args))))))
53
54(define-syntax-rule (catch-system-error exp)
55 (catch 'system-error
56 (lambda ()
57 exp)
58 (const #f)))
59
60(define (default-namespaces args)
61 ;; Most daemons are here to talk to the network, and most of them expect to
62 ;; run under a non-zero UID.
63 (fold delq %namespaces '(net user)))
64
65(define* (default-mounts #:key (namespaces (default-namespaces '())))
66 (define (tmpfs directory)
67 (file-system
68 (device "none")
69 (mount-point directory)
70 (type "tmpfs")
71 (check? #f)))
72
73 (define accounts
74 ;; This is for processes in the default user namespace but living in a
75 ;; different mount namespace, so that they can lookup users.
76 (list (file-system-mapping
77 (source "/etc/passwd") (target source))
78 (file-system-mapping
79 (source "/etc/group") (target source))))
80
81 (append (cons (tmpfs "/tmp") %container-file-systems)
82 (let ((mappings `(,@(if (memq 'net namespaces)
83 '()
84 %network-file-mappings)
85 ,@(if (and (memq 'mnt namespaces)
86 (not (memq 'user namespaces)))
87 accounts
88 '())
89
90 ;; Tell the process what timezone we're in. This
91 ;; makes sure that, for instance, its syslog
92 ;; messages have the correct timestamp.
93 ,(file-system-mapping
94 (source "/etc/localtime")
95 (target source))
96
97 ,%store-mapping))) ;XXX: coarse-grain
98 (map file-system-mapping->bind-mount
99 (filter (lambda (mapping)
100 (file-exists? (file-system-mapping-source mapping)))
101 mappings)))))
102
103(define* (exec-command* command #:key user group log-file pid-file
104 (supplementary-groups '())
105 (directory "/") (environment-variables (environ)))
106 "Like 'exec-command', but first restore signal handles modified by
107shepherd (PID 1)."
108 ;; First restore the default handlers.
109 (for-each (cut sigaction <> SIG_DFL) %precious-signals)
110
111 ;; Unblock any signals that have been blocked by the parent process.
112 (unblock-signals %precious-signals)
113
114 (mkdir-p "/var/run")
115 (clean-up pid-file)
116
117 (exec-command command
118 #:user user
119 #:group group
120 #:supplementary-groups supplementary-groups
121 #:log-file log-file
122 #:directory directory
123 #:environment-variables environment-variables))
124
125(define* (fork+exec-command/container command
126 #:key pid
127 #:allow-other-keys
128 #:rest args)
129 "This is a variant of 'fork+exec-command' procedure, that joins the
130namespaces of process PID beforehand. If there is no support for containers,
131on Hurd systems for instance, fallback to direct forking."
132 (define (strip-pid args)
133 ;; TODO: Replace with 'strip-keyword-arguments' when that no longer pulls
134 ;; in (guix config).
135 (let loop ((args args)
136 (result '()))
137 (match args
138 (()
139 (reverse result))
140 ((#:pid _ . rest)
141 (loop rest result))
142 ((head . rest)
143 (loop rest (cons head result))))))
144
145 (let ((container-support? (file-exists? "/proc/self/ns")))
146 (if (and container-support?
147 (not (and pid (= pid (getpid)))))
148 (container-excursion* pid
149 (lambda ()
150 ;; Note: In the Shepherd 0.9, 'fork+exec-command' expects to be
151 ;; called from the shepherd process (because it creates a pipe to
152 ;; capture stdout/stderr and spawns a logging fiber) so we cannot
153 ;; use it here.
154 (match (primitive-fork)
155 (0 (dynamic-wind
156 (const #t)
157 (lambda ()
158 (apply exec-command* command (strip-pid args)))
159 (lambda ()
160 (primitive-_exit 127))))
161 (pid pid)))) ;XXX: assuming the same PID namespace
162 (apply fork+exec-command command (strip-pid args)))))
163
164;; Local Variables:
165;; eval: (put 'container-excursion* 'scheme-indent-function 1)
166;; End:
167
168;;; shepherd.scm ends here