projects/guix·blob java-team · refs

587 lines · 24.1 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2015 David Thompson <[email protected]>
3;;; Copyright © 2017-2019, 2022-2023, 2025 Ludovic Courtès <[email protected]>
4;;; Copyright © 2026 Giacomo Leidi <[email protected]>
5;;;
6;;; This file is part of GNU Guix.
7;;;
8;;; GNU Guix is free software; you can redistribute it and/or modify it
9;;; under the terms of the GNU General Public License as published by
10;;; the Free Software Foundation; either version 3 of the License, or (at
11;;; your option) any later version.
12;;;
13;;; GNU Guix is distributed in the hope that it will be useful, but
14;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;;; GNU General Public License for more details.
17;;;
18;;; You should have received a copy of the GNU General Public License
19;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20
21(define-module (gnu build linux-container)
22 #:use-module (ice-9 format)
23 #:use-module (ice-9 match)
24 #:use-module (ice-9 rdelim)
25 #:use-module (srfi srfi-98)
26 #:use-module (guix build utils)
27 #:use-module (guix build syscalls)
28 #:use-module (gnu system file-systems) ;<file-system>
29 #:use-module ((gnu build file-systems) #:select (mount-file-system))
30 #:export (user-namespace-supported?
31 unprivileged-user-namespace-supported?
32 setgroups-supported?
33 %namespaces
34 %writable-/tmp
35 run-container
36 call-with-container
37 container-excursion
38 container-excursion*))
39
40(define (user-namespace-supported?)
41 "Return #t if user namespaces are supported on this system."
42 (file-exists? "/proc/self/ns/user"))
43
44(define (unprivileged-user-namespace-supported?)
45 "Return #t if user namespaces can be created by unprivileged users."
46 (let ((userns-file "/proc/sys/kernel/unprivileged_userns_clone"))
47 (if (file-exists? userns-file)
48 (eqv? #\1 (call-with-input-file userns-file read-char))
49 (user-namespace-supported?))))
50
51(define (setgroups-supported?)
52 "Return #t if the setgroups proc file, introduced in Linux-libre 3.19,
53exists."
54 (file-exists? "/proc/self/setgroups"))
55
56(define %namespaces
57 '(cgroup mnt pid ipc uts user net))
58
59(define (call-with-clean-exit thunk)
60 "Apply THUNK, but exit with a status code of 1 if it fails."
61 (dynamic-wind
62 (const #t)
63 (lambda ()
64 (thunk)
65
66 ;; XXX: Somehow we sometimes get EBADF from write(2) or close(2) upon
67 ;; exit (coming from fd finalizers) when used by the Shepherd. To work
68 ;; around that, exit forcefully so fd finalizers don't have a chance to
69 ;; run and fail.
70 (primitive-_exit 0))
71 (lambda ()
72 (primitive-_exit 1))))
73
74(define (purify-environment)
75 "Unset all environment variables."
76 (for-each unsetenv
77 (match (get-environment-variables)
78 (((names . _) ...) names))))
79
80(define (remount-read-only mount-point)
81 (mount mount-point mount-point "none"
82 (logior MS_BIND MS_REMOUNT MS_RDONLY)))
83
84;; The container setup procedure closely resembles that of the Docker
85;; specification:
86;; https://raw.githubusercontent.com/docker/libcontainer/master/SPEC.md
87(define* (mount-file-systems root mounts #:key mount-/sys? mount-/proc?
88 (populate-file-system (const #t))
89 writable-root?)
90 "Mount the essential file systems and those in MOUNTS, a list of
91<file-system> objects, relative to ROOT; then make ROOT the new root directory
92for the process."
93 (define (scope dir)
94 (string-append root dir))
95
96 (define (touch file-name)
97 (call-with-output-file file-name (const #t)))
98
99 (define (bind-mount src dest)
100 (mount src dest "none" MS_BIND))
101
102 ;; Like mount, but creates the mount point if it doesn't exist.
103 (define* (mount* source target type #:optional (flags 0) options
104 #:key (update-mtab? #f))
105 (mkdir-p target)
106 (mount source target type flags options #:update-mtab? update-mtab?))
107
108 ;; Detach our mount namespace from the host's propagation peer
109 ;; group. Without this, when the host's / is MS_SHARED - as it
110 ;; is on a system running rootless-podman-service-type, and as it
111 ;; is by default on systemd hosts - 'pivot_root' below fails
112 ;; with EINVAL because the new root and its parent must not have
113 ;; propagation type MS_SHARED (pivot_root(2)). This is the same
114 ;; remount that runc, crun and buildah perform immediately after
115 ;; unshare(CLONE_NEWNS).
116 (mount #f "/" #f (logior MS_REC MS_PRIVATE))
117
118 ;; The container's file system is completely ephemeral, sans directories
119 ;; bind-mounted from the host.
120 (mount "none" root "tmpfs")
121
122 ;; A proc mount requires a new pid namespace.
123 (when mount-/proc?
124 (mount* "none" (scope "/proc") "proc"
125 (logior MS_NOEXEC MS_NOSUID MS_NODEV)))
126
127 ;; A sysfs mount requires the user to have the CAP_SYS_ADMIN capability in
128 ;; the current network namespace.
129 (when mount-/sys?
130 (catch 'system-error
131 (lambda ()
132 (mount* "none" (scope "/sys") "sysfs"
133 (logior MS_NOEXEC MS_NOSUID MS_NODEV MS_RDONLY)))
134 (lambda args
135 ;; EPERM means that CAP_SYS_ADMIN is missing. Ignore.
136 (unless (= EPERM (system-error-errno args))
137 (apply throw args)))))
138
139 (mount* "none" (scope "/dev") "tmpfs"
140 (logior MS_NOEXEC MS_STRICTATIME)
141 "mode=755")
142
143 ;; Create essential device nodes via bind-mounting them from the
144 ;; host, because a process within a user namespace cannot create
145 ;; device nodes.
146 (for-each (lambda (device)
147 (when (file-exists? device)
148 ;; Create the mount point file.
149 (touch (scope device))
150 (bind-mount device (scope device))))
151 '("/dev/null"
152 "/dev/zero"
153 "/dev/full"
154 "/dev/random"
155 "/dev/urandom"
156 "/dev/tty"
157 "/dev/fuse"))
158
159 ;; Mount a new devpts instance on /dev/pts.
160 (when (file-exists? "/dev/ptmx")
161 (mount* "none" (scope "/dev/pts") "devpts" 0
162 "newinstance,mode=0620")
163 (symlink "/dev/pts/ptmx" (scope "/dev/ptmx")))
164
165 ;; Setup the container's /dev/console by bind mounting the pseudo-terminal
166 ;; associated with standard input when there is one.
167 (let* ((in (current-input-port))
168 (tty (catch 'system-error
169 (lambda ()
170 ;; This call throws if IN does not correspond to a tty.
171 ;; This is more reliable than 'isatty?'.
172 (ttyname in))
173 (const #f)))
174 (console (scope "/dev/console")))
175 (when tty
176 (touch console)
177 (chmod console #o600)
178 (bind-mount tty console)))
179
180 ;; Setup standard input/output/error.
181 (symlink "/proc/self/fd" (scope "/dev/fd"))
182 (symlink "/proc/self/fd/0" (scope "/dev/stdin"))
183 (symlink "/proc/self/fd/1" (scope "/dev/stdout"))
184 (symlink "/proc/self/fd/2" (scope "/dev/stderr"))
185
186 ;; Mount user-specified file systems.
187 (for-each (lambda (file-system)
188 (mount-file-system file-system #:root root))
189 mounts)
190
191 ;; Jail the process inside the container's root file system.
192 (let ((put-old (string-append root "/real-root")))
193 (mkdir put-old)
194 (pivot-root root put-old)
195 (chdir "/")
196 (umount "real-root" MNT_DETACH)
197 (rmdir "real-root")
198 (populate-file-system)
199 (chmod "/" #o755)
200 (unless writable-root?
201 (remount-read-only "/"))))
202
203(define* (initialize-user-namespace pid host-uids
204 #:key
205 (host-uid (getuid))
206 (host-gid (getgid))
207 (guest-uid 0) (guest-gid 0))
208 "Configure the user namespace for PID. HOST-UIDS specifies the number of
209host user identifiers to map into the user namespace. GUEST-UID and GUEST-GID
210specify the first UID (respectively GID) that host UIDs (respectively GIDs)
211map to in the namespace."
212 (define proc-dir
213 (string-append "/proc/" (number->string pid)))
214
215 (define (scope file)
216 (string-append proc-dir file))
217
218 ;; Only root can write to the gid map without first disabling the
219 ;; setgroups syscall.
220 (unless (and (zero? host-uid) (zero? host-gid))
221 (call-with-output-file (scope "/setgroups")
222 (lambda (port)
223 (display "deny" port))))
224
225 ;; Map the user/group that created the container to the root user
226 ;; within the container.
227 (call-with-output-file (scope "/uid_map")
228 (lambda (port)
229 (format port "~d ~d ~d" guest-uid host-uid host-uids)))
230 (call-with-output-file (scope "/gid_map")
231 (lambda (port)
232 (format port "~d ~d ~d" guest-gid host-gid host-uids))))
233
234(define (namespaces->bit-mask namespaces)
235 "Return the number suitable for the 'flags' argument of 'clone' that
236corresponds to the symbols in NAMESPACES."
237 ;; Use the same flags as fork(3) in addition to the namespace flags.
238 (apply logior SIGCHLD
239 (map (match-lambda
240 ('cgroup CLONE_NEWCGROUP)
241 ('mnt CLONE_NEWNS)
242 ('uts CLONE_NEWUTS)
243 ('ipc CLONE_NEWIPC)
244 ('user CLONE_NEWUSER)
245 ('pid CLONE_NEWPID)
246 ('net CLONE_NEWNET))
247 namespaces)))
248
249(define* (run-container root mounts namespaces host-uids thunk
250 #:key (guest-uid 0) (guest-gid 0)
251 (populate-file-system (const #t))
252 (loopback-network? #t)
253 (lock-mounts? #t)
254 writable-root?)
255 "Run THUNK in a new container process and return its PID. ROOT specifies
256the root directory for the container. MOUNTS is a list of <file-system>
257objects that specify file systems to mount inside the container. NAMESPACES
258is a list of symbols that correspond to the possible Linux namespaces: mnt,
259ipc, uts, user, and net. When LOCK-MOUNTS? is true, arrange so that none of
260MOUNTS can be unmounted or remounted individually from within THUNK.
261
262When LOOPBACK-NETWORK? is true and 'net is amount NAMESPACES, set up the
263loopback device (\"lo\") and a minimal /etc/hosts.
264
265When WRITABLE-ROOT? is false, remount the container's root as read-only before
266calling THUNK. Call POPULATE-FILE-SYSTEM before the root is (potentially)
267made read-only.
268
269HOST-UIDS specifies the number of host user identifiers to map into the user
270namespace. GUEST-UID and GUEST-GID specify the first UID (respectively GID)
271that host UIDs (respectively GIDs) map to in the namespace."
272 ;; The parent process must initialize the user namespace for the child
273 ;; before it can boot. To negotiate this, a pipe is used such that the
274 ;; child process blocks until the parent writes to it.
275 (match (socketpair PF_UNIX (logior SOCK_CLOEXEC SOCK_STREAM) 0)
276 ((child . parent)
277 (safe-clone
278 (namespaces->bit-mask namespaces)
279 (lambda ()
280 (call-with-clean-exit
281 (lambda ()
282 (close-port parent)
283 ;; Wait for parent to set things up.
284 (match (read child)
285 ('ready
286 (purify-environment)
287 (when (and (memq 'mnt namespaces)
288 (not (string=? root "/")))
289 (catch #t
290 (lambda ()
291 (mount-file-systems root mounts
292 #:mount-/proc? (memq 'pid namespaces)
293 #:mount-/sys? (memq 'net
294 namespaces)
295 #:populate-file-system
296 (lambda ()
297 (populate-file-system)
298 (when (and (memq 'net namespaces)
299 loopback-network?)
300 (set-network-interface-up "lo")
301
302 ;; When isolated from the
303 ;; network, provide a minimal
304 ;; /etc/hosts to resolve
305 ;; "localhost".
306 (mkdir-p "/etc")
307 (call-with-output-file "/etc/hosts"
308 (lambda (port)
309 (display "127.0.0.1 localhost\n" port)
310 (chmod port #o444)))))
311 #:writable-root?
312 (or writable-root?
313 (not (memq 'mnt namespaces)))))
314 (lambda args
315 ;; Forward the exception to the parent process.
316 ;; FIXME: SRFI-35 conditions and non-trivial objects
317 ;; cannot be 'read' so they shouldn't be written as is.
318 (write args child)
319 (primitive-exit 3))))
320
321 (when (and lock-mounts?
322 (memq 'mnt namespaces)
323 (memq 'user namespaces))
324 ;; Create a new mount namespace owned by a new user
325 ;; namespace to "lock" together previous mounts, such that
326 ;; they cannot be unmounted or remounted separately--see
327 ;; mount_namespaces(7).
328 (let ((uid (getuid)) (gid (getgid)))
329 (unshare (logior CLONE_NEWUSER CLONE_NEWNS))
330 (when (file-exists? "/proc/self")
331 (initialize-user-namespace (getpid)
332 host-uids
333 #:host-uid uid
334 #:host-gid gid
335 #:guest-uid guest-uid
336 #:guest-gid guest-gid))))
337
338 ;; TODO: Manage capabilities.
339 (write 'ready child)
340 (close-port child)
341 (thunk))
342 (_ ;parent died or something
343 (primitive-exit 2))))))
344 (lambda (pid)
345 (close-port child)
346 (when (memq 'user namespaces)
347 (initialize-user-namespace pid host-uids
348 #:guest-uid guest-uid
349 #:guest-gid guest-gid))
350 ;; TODO: Initialize cgroups.
351 (write 'ready parent)
352 (newline parent)
353
354 ;; Check whether the child process' setup phase succeeded.
355 (let ((message (read parent)))
356 (close-port parent)
357 (match message
358 ('ready ;success
359 pid)
360 (((? symbol? key) args ...) ;exception
361 (apply throw key args))
362 (_ ;unexpected termination
363 #f))))))))
364
365;; FIXME: This is copied from (guix utils), which we cannot use because it
366;; would pull (guix config) and all.
367(define (call-with-temporary-directory proc)
368 "Call PROC with a name of a temporary directory; close the directory and
369delete it when leaving the dynamic extent of this call."
370 (let* ((directory (or (getenv "TMPDIR") "/tmp"))
371 (template (string-append directory "/guix-directory.XXXXXX"))
372 (tmp-dir (mkdtemp! template)))
373 (dynamic-wind
374 (const #t)
375 (lambda ()
376 (proc tmp-dir))
377 (lambda ()
378 (false-if-exception (delete-file-recursively tmp-dir))))))
379
380(define (wait-child-process)
381 "Wait for one child process and return a pair, like 'waitpid', or return #f
382if there are no child processes left."
383 (catch 'system-error
384 (lambda ()
385 (waitpid WAIT_ANY))
386 (lambda args
387 (if (= ECHILD (system-error-errno args))
388 #f
389 (apply throw args)))))
390
391(define (status->exit-status status)
392 "Reify STATUS as an exit status."
393 (or (status:exit-val status)
394 ;; See <http://www.tldp.org/LDP/abs/html/exitcodes.html#EXITCODESREF>.
395 (+ 128 (or (status:term-sig status)
396 (status:stop-sig status)))))
397
398(define %writable-/tmp
399 ;; Writable and volatile /tmp.
400 (file-system
401 (device "none")
402 (mount-point "/tmp")
403 (type "tmpfs")
404 (flags '(no-suid no-dev))
405 (options "mode=755,size=10%")
406 (check? #f)))
407
408(define* (call-with-container mounts thunk #:key (namespaces %namespaces)
409 (host-uids 1) (guest-uid 0) (guest-gid 0)
410 (lock-mounts? #t)
411 (relayed-signals (list SIGINT SIGTERM))
412 (child-is-pid1? #t)
413 (populate-file-system (const #t))
414 (loopback-network? #t)
415 writable-root?
416 (process-spawned-hook (const #t)))
417 "Run THUNK in a new container process and return its exit status; call
418PROCESS-SPAWNED-HOOK with the PID of the new process that has been spawned.
419MOUNTS is a list of <file-system> objects that specify file systems to mount
420inside the container. NAMESPACES is a list of symbols corresponding to
421the identifiers for Linux namespaces: mnt, ipc, uts, pid, user, and net. By
422default, all namespaces are used.
423
424HOST-UIDS is the number of host user identifiers to map into the container's
425user namespace, if there is one. By default, only a single uid/gid, that of
426the current user, is mapped into the container. The host user that creates
427the container is the root user (uid/gid 0) within the container. Only root
428can map more than a single uid/gid.
429
430GUEST-UID and GUEST-GID specify the first UID (respectively GID) that host
431UIDs (respectively GIDs) map to in the namespace.
432
433RELAYED-SIGNALS is the list of signals that are \"relayed\" to the container
434process when caught by its parent.
435
436When LOOPBACK-NETWORK? is true and 'net is amount NAMESPACES, set up the
437loopback device (\"lo\") and a minimal /etc/hosts.
438
439When WRITABLE-ROOT? is false, remount the container's root as read-only before
440calling THUNK. Call POPULATE-FILE-SYSTEM before the root is (potentially)
441made read-only.
442
443When CHILD-IS-PID1? is true, and if NAMESPACES contains 'pid', then the child
444process runs directly as PID 1. As such, it is responsible for (1) installing
445signal handlers and (2) reaping terminated processes by calling 'waitpid'.
446When CHILD-IS-PID1? is false, a new intermediate process is created instead
447that takes this responsibility.
448
449Note that if THUNK needs to load any additional Guile modules, the relevant
450module files must be present in one of the mappings in MOUNTS and the Guile
451load path must be adjusted as needed."
452 (define thunk*
453 (if (and (memq 'pid namespaces)
454 (not child-is-pid1?))
455 (lambda ()
456 ;; Behave like an init process: create a sub-process that calls
457 ;; THUNK, and wait for child processes. Furthermore, forward
458 ;; RELAYED-SIGNALS to the child process.
459 ;; We presently use `safe-clone` here due to a bug in the interaction
460 ;; between Guix and `primitive-fork` in Guile 3.0.11:
461 ;; https://codeberg.org/guix/guix/issues/7690#issuecomment-12744123
462 (safe-clone
463 SIGCHLD
464 (lambda ()
465 (call-with-clean-exit thunk))
466 (lambda (pid)
467 (install-signal-handlers pid)
468 (let loop ()
469 (match (wait-child-process)
470 ((child . status)
471 (if (= child pid)
472 (primitive-exit (status->exit-status status))
473 (loop)))
474 (#f
475 (primitive-exit 128))))))) ;cannot happen
476 thunk))
477
478 (define (periodically-schedule-asyncs)
479 ;; XXX: In Guile there's a time window where a signal-handling async could
480 ;; be queued without being processed by the time we enter a blocking
481 ;; syscall like waitpid(2) (info "(guile) Signals"). This terrible hack
482 ;; ensures pending asyncs get a chance to run periodically.
483 (sigaction SIGALRM (lambda _ (alarm 1)))
484 (alarm 1))
485
486 (define (install-signal-handlers pid)
487 ;; Install handlers that forward signals to PID.
488 (define (relay-signal signal)
489 (false-if-exception (kill pid signal)))
490
491 (periodically-schedule-asyncs)
492 (for-each (lambda (signal)
493 (sigaction signal relay-signal))
494 relayed-signals))
495
496 (call-with-temporary-directory
497 (lambda (root)
498 (let ((pid (run-container root mounts namespaces host-uids thunk*
499 #:lock-mounts? lock-mounts?
500 #:guest-uid guest-uid
501 #:guest-gid guest-gid
502 #:populate-file-system populate-file-system
503 #:loopback-network? loopback-network?
504 #:writable-root? writable-root?)))
505 (install-signal-handlers pid)
506 (process-spawned-hook pid)
507 (match (waitpid pid)
508 ((_ . status) status))))))
509
510(define (container-excursion pid thunk)
511 "Run THUNK as a child process within the namespaces of process PID and
512return the exit status, an integer as returned by 'waitpid'."
513 (define (namespace-file pid namespace)
514 (string-append "/proc/" (number->string pid) "/ns/" namespace))
515
516 (match (primitive-fork)
517 (0
518 (call-with-clean-exit
519 (lambda ()
520 ;; First, determine the user namespace that owns the pid namespace and
521 ;; join that user namespace (the assumption is that it also owns all
522 ;; the other namespaces). It's important that the user namespace is
523 ;; joined first, so that the user will have the privileges to join the
524 ;; other namespaces.
525 (let* ((pid-ns (open-fdes (namespace-file pid "pid")
526 (logior O_CLOEXEC O_RDONLY)))
527 (user-ns (get-user-ns pid-ns)))
528 (close-fdes pid-ns)
529 (unless (equal? (stat user-ns)
530 (stat (namespace-file (getpid) "user")))
531 (setns user-ns 0))
532 (close-fdes user-ns)
533
534 ;; Then join all the remaining namespaces.
535 (for-each (lambda (ns)
536 (let ((source (namespace-file (getpid) ns))
537 (target (namespace-file pid ns)))
538 ;; Joining the namespace that the process already
539 ;; belongs to would throw an error so avoid that.
540 ;; XXX: This /proc interface leads to TOCTTOU.
541 (unless (string=? (readlink source) (readlink target))
542 (call-with-input-file target
543 (lambda (new-ns-port)
544 (setns (fileno new-ns-port) 0))))))
545 ;; It's important that the mount namespace is joined last,
546 ;; otherwise the /proc mount point would no longer be
547 ;; accessible.
548 '("ipc" "uts" "net" "pid" "mnt")))
549 (purify-environment)
550 (chdir "/")
551
552 ;; Per setns(2), changing the PID namespace only applies to child
553 ;; processes, not to the process itself. Thus fork so that THUNK runs
554 ;; in the right PID namespace, which also gives it access to /proc.
555 (match (primitive-fork)
556 (0 (call-with-clean-exit thunk))
557 (pid (primitive-exit
558 (match (waitpid pid)
559 ((_ . status)
560 (or (status:exit-val status) 127)))))))))
561 (pid
562 (match (waitpid pid)
563 ((_ . status)
564 status)))))
565
566(define (container-excursion* pid thunk)
567 "Like 'container-excursion', but return the return value of THUNK."
568 (match (pipe)
569 ((in . out)
570 ;; Make sure IN and OUT are not inherited if THUNK forks + execs.
571 (fcntl in F_SETFD FD_CLOEXEC)
572 (fcntl out F_SETFD FD_CLOEXEC)
573
574 (match (container-excursion pid
575 (lambda ()
576 (close-port in)
577 (write (thunk) out)
578 (close-port out)))
579 (0
580 (close-port out)
581 (let ((result (read in)))
582 (close-port in)
583 result))
584 (_ ;maybe PID died already
585 (close-port out)
586 (close-port in)
587 #f)))))