projects/guix·blob java-team · refs

505 lines · 20.8 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012-2021, 2025 Ludovic Courtès <[email protected]>
3;;; Copyright © 2013 Nikita Karetnikov <[email protected]>
4;;; Copyright © 2013 Andreas Enge <[email protected]>
5;;; Copyright © 2015, 2018 Mark H Weaver <[email protected]>
6;;; Copyright © 2018 Arun Isaac <[email protected]>
7;;; Copyright © 2018, 2019 Ricardo Wurmus <[email protected]>
8;;; Copyright © 2021, 2022 Maxime Devos <[email protected]>
9;;; Copyright © 2020 Christine Lemmer-Webber <[email protected]>
10;;; Copyright © 2021 Brice Waegeneire <[email protected]>
11;;; Copyright © 2022 Tobias Geerinckx-Rice <[email protected]>
12;;; Copyright © 2024 Nicolas Graves <[email protected]>
13;;; Copyright © 2024 Giacomo Leidi <[email protected]>
14;;; Copyright © 2025 Maxim Cournoyer <[email protected]>
15;;;
16;;; This file is part of GNU Guix.
17;;;
18;;; GNU Guix is free software; you can redistribute it and/or modify it
19;;; under the terms of the GNU General Public License as published by
20;;; the Free Software Foundation; either version 3 of the License, or (at
21;;; your option) any later version.
22;;;
23;;; GNU Guix is distributed in the hope that it will be useful, but
24;;; WITHOUT ANY WARRANTY; without even the implied warranty of
25;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
26;;; GNU General Public License for more details.
27;;;
28;;; You should have received a copy of the GNU General Public License
29;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
30
31(define-module (gnu build activation)
32 #:use-module (gnu system accounts)
33 #:use-module (gnu system privilege)
34 #:use-module (gnu build accounts)
35 #:use-module (gnu build linux-boot)
36 #:use-module (guix build utils)
37 #:use-module ((guix build syscalls) #:select (with-file-lock))
38 #:use-module (ice-9 ftw)
39 #:use-module (ice-9 match)
40 #:use-module (ice-9 vlist)
41 #:use-module (srfi srfi-1)
42 #:use-module (srfi srfi-11)
43 #:use-module (srfi srfi-26)
44 #:export (activate-users+groups
45 activate-subuids+subgids
46 activate-user-home
47 activate-etc
48 activate-privileged-programs
49 activate-special-files
50 activate-modprobe
51 activate-firmware
52 activate-ptrace-attach
53 activate-current-system
54 mkdir-p/perms))
55
56;;; Commentary:
57;;;
58;;; This module provides "activation" helpers. Activation is the process that
59;;; consists in setting up system-wide files and directories so that an
60;;; 'operating-system' configuration becomes active.
61;;;
62;;; Code:
63
64(define %skeleton-directory
65 ;; Directory containing skeleton files for new accounts.
66 ;; Note: keep the trailing '/' so that 'scandir' enters it.
67 "/etc/skel/")
68
69(define (dot-or-dot-dot? file)
70 (member file '("." "..")))
71
72(define (mkdir-p/perms directory owner bits)
73 "Create directory DIRECTORY and all its ancestors.
74
75Additionally, verify no component of DIRECTORY is a symbolic link,
76without TOCTTOU races. However, if OWNER differs from the the current
77(process) uid/gid, there is a small window in which DIRECTORY is set to the
78current (process) uid/gid instead of OWNER. This is not expected to be
79a problem in practice.
80
81The permission bits and owner of DIRECTORY are set to BITS and OWNER.
82Anything above DIRECTORY that already exists keeps
83its old owner and bits. For components that do not exist yet, the owner
84and bits are set according to the default behaviour of 'mkdir'."
85 (define absolute?
86 (string-prefix? "/" directory))
87
88 (define not-slash
89 (char-set-complement (char-set #\/)))
90
91 ;; By combining O_NOFOLLOW and O_DIRECTORY, this procedure automatically
92 ;; verifies that no components are symlinks.
93 (define open-flags (logior O_CLOEXEC ; don't pass the port on to subprocesses
94 O_RDONLY ;needed on the Hurd, harmless on Linux
95 O_NOFOLLOW ; don't follow symlinks
96 O_DIRECTORY)) ; reject anything not a directory
97
98 (let loop ((components (string-tokenize directory not-slash))
99 (root (open (if absolute? "/" ".") open-flags)))
100 (match components
101 ((head tail ...)
102 (let retry ()
103 ;; In the usual case, we expect HEAD to already exist.
104 (match (catch 'system-error
105 (lambda ()
106 (openat root head open-flags))
107 (lambda args
108 (if (= ENOENT (system-error-errno args))
109 #false
110 (begin
111 (close-port root)
112 (apply throw args)))))
113 ((? port? new-root)
114 (close root)
115 (loop tail new-root))
116 (#false
117 ;; If not, create it.
118 (catch 'system-error
119 (lambda _
120 (if (null? tail)
121 (mkdirat root head bits)
122 (mkdirat root head)))
123 (lambda args
124 ;; Someone else created the directory. Unexpected but fine.
125 (unless (= EEXIST (system-error-errno args))
126 (close-port root)
127 (apply throw args))))
128 (retry)))))
129 (()
130 (catch 'system-error
131 (lambda ()
132 (chown root (passwd:uid owner) (passwd:gid owner))
133 (chmod root bits))
134 (lambda args
135 (close-port root)
136 (apply throw args)))
137 (close-port root)
138 (values)))))
139
140(define* (copy-account-skeletons home
141 #:key
142 (directory %skeleton-directory)
143 uid gid)
144 "Copy the account skeletons from DIRECTORY to HOME and make them writable.
145When UID is an integer, make it the owner of all the files created except the
146home directory; likewise for GID."
147 (define (set-permission file)
148 (when (or uid gid)
149 (chown file (or uid -1) (or gid -1)))
150 (make-file-writable file))
151
152 (let ((files (scandir directory (negate dot-or-dot-dot?)
153 string<?)))
154 (mkdir-p home)
155 (for-each (lambda (file)
156 (let ((target (string-append home "/" file)))
157 (copy-recursively (string-append directory "/" file)
158 target
159 #:log (%make-void-port "w"))
160 (for-each set-permission
161 (find-files target (const #t)
162 #:directories? #t))))
163 files)))
164
165(define* (make-skeletons-writable home
166 #:optional (directory %skeleton-directory))
167 "Make sure that the files that have been copied from DIRECTORY to HOME are
168owner-writable in HOME."
169 (let ((files (scandir directory (negate dot-or-dot-dot?)
170 string<?)))
171 (for-each (lambda (file)
172 (let ((target (string-append home "/" file)))
173 (when (file-exists? target)
174 (make-file-writable target))))
175 files)))
176
177(define (duplicates lst)
178 "Return elements from LST present more than once in LST."
179 (let loop ((lst lst)
180 (seen vlist-null)
181 (result '()))
182 (match lst
183 (()
184 (reverse result))
185 ((head . tail)
186 (loop tail
187 (vhash-cons head #t seen)
188 (if (vhash-assoc head seen)
189 (cons head result)
190 result))))))
191
192(define (activate-users+groups users groups)
193 "Make sure USERS (a list of user account records) and GROUPS (a list of user
194group records) are all available."
195 (define (make-home-directory user)
196 (let ((home (user-account-home-directory user))
197 (pwd (getpwnam (user-account-name user))))
198 (mkdir-p home)
199
200 ;; Always set ownership and permissions for home directories of system
201 ;; accounts. If a service needs looser permissions on its home
202 ;; directories, it can always chmod it in an activation snippet.
203 (chown home (passwd:uid pwd) (passwd:gid pwd))
204 (chmod home #o700)))
205
206 (define system-accounts
207 (filter (lambda (user)
208 (and (user-account-system? user)
209 (user-account-create-home-directory? user)))
210 users))
211
212 ;; Allow home directories to be created under /var/lib.
213 (mkdir-p "/var/lib")
214
215 ;; Take same lock as libc's 'lckpwdf' (but without a timeout) while we read
216 ;; and write the databases. This ensures there's no race condition with
217 ;; other tools that might be accessing it at the same time.
218 (with-file-lock %password-lock-file
219 (let-values (((groups passwd shadow)
220 (user+group-databases users groups)))
221 (write-group groups)
222 (write-passwd passwd)
223 (write-shadow shadow)))
224
225 ;; Home directories of non-system accounts are created by
226 ;; 'activate-user-home'.
227 (for-each make-home-directory system-accounts)
228
229 ;; Turn shared home directories, such as /var/empty, into root-owned,
230 ;; read-only places.
231 (for-each (lambda (directory)
232 (chown directory 0 0)
233 (chmod directory #o555))
234 (duplicates (map user-account-home-directory system-accounts))))
235
236(define (activate-subuids+subgids subuids subgids)
237 "Make sure SUBUIDS (a list of subid range records) and SUBGIDS (a list of
238subid range records) are all available."
239
240 ;; Take same lock as Shadow while we read
241 ;; and write the databases. This ensures there's no race condition with
242 ;; other tools that might be accessing it at the same time.
243 (with-file-lock "/etc/subgid.lock"
244 (let-values (((subuid subgid)
245 (subuid+subgid-databases subuids subgids)))
246 (write-subgid subgid)))
247
248 (with-file-lock "/etc/subuid.lock"
249 (let-values (((subuid subgid)
250 (subuid+subgid-databases subuids subgids)))
251 (write-subuid subuid))))
252
253(define (activate-user-home users)
254 "Create and populate the home directory of USERS, a list of tuples, unless
255they already exist."
256 (define ensure-user-home
257 (lambda (user)
258 (let ((name (user-account-name user))
259 (home (user-account-home-directory user))
260 (create-home? (user-account-create-home-directory? user))
261 (system? (user-account-system? user)))
262 ;; The home directories of system accounts are created during
263 ;; activation, not here.
264 (unless (or (not home) (not create-home?) system?
265 (directory-exists? home))
266 (let* ((pw (getpwnam name))
267 (uid (passwd:uid pw))
268 (gid (passwd:gid pw)))
269 (mkdir-p home)
270 (chmod home #o700)
271 (copy-account-skeletons home
272 #:uid uid #:gid gid)
273
274 ;; It is important 'chown' be called after
275 ;; 'copy-account-skeletons'. Otherwise, a malicious user with
276 ;; good timing could create a symlink in HOME that would be
277 ;; dereferenced by 'copy-account-skeletons'.
278 (chown home uid gid))))))
279
280 (for-each ensure-user-home users))
281
282(define* (canonicalize-path* file)
283 "A safe version of `canonicalize-path' that warns rather than raises on errors.
284`canonicalize-path' uses `realpath(2)', which can return various errors like
285EINVAL, ELOOP, etc."
286 (or (false-if-exception (canonicalize-path file))
287 (begin
288 (format (current-warning-port)
289 "warning: could not canonicalize file `~a'; using as-is~%"
290 file)
291 file)))
292
293(define (activate-etc etc)
294 "Install ETC, a directory in the store, as the source of static files for
295/etc."
296
297 ;; /etc is a mixture of static and dynamic settings. Here is where we
298 ;; initialize it from the static part.
299
300 (define (rm-f file)
301 (false-if-exception (delete-file file)))
302
303 (format #t "populating /etc from ~a...~%" etc)
304 (mkdir-p "/etc")
305
306 ;; Create the /etc/ssl -> /run/current-system/profile/etc/ssl symlink. This
307 ;; symlink, to a target outside of the store, probably doesn't belong in the
308 ;; static 'etc' store directory. However, if it were to be put there,
309 ;; beware that if /run/current-system/profile/etc/ssl doesn't exist at the
310 ;; time of activation (e.g. when installing a fresh system), the call to
311 ;; 'file-is-directory?' below will fail because it uses 'stat', not 'lstat'.
312 (rm-f "/etc/ssl")
313 (symlink "/run/current-system/profile/etc/ssl" "/etc/ssl")
314
315 (for-each (lambda (file)
316 (let ((target (string-append "/etc/" file))
317 ;; Canonicalize the file names to resolve any symlinks, to
318 ;; ensure /etc/localtime points to a timezone data file in
319 ;; the store containing the timezone name. This is done
320 ;; for compatibility with software expecting this systemd
321 ;; convention to be followed.
322 (source (canonicalize-path* (string-append etc "/" file))))
323 (rm-f target)
324 (cond ((string=? (basename target) "sudoers")
325 (begin
326 ;; /etc/sudoers must be a regular file.
327 (copy-file source target)
328 ;; XXX: dirty hack to meet sudo's expectations
329 (chmod target #o440)))
330 ((string=? (basename target) "hosts")
331 ;; /etc/hosts must be a regular file, as some software
332 ;; like vpn-slice expect to be able to write to it.
333 (copy-file source target))
334 (else ;usual case
335 (symlink source target)))))
336 (scandir etc (negate dot-or-dot-dot?)
337 ;; The default is 'string-locale<?', but we don't have
338 ;; it when run from the initrd's statically-linked
339 ;; Guile.
340 string<?)))
341
342(define %setuid-directory
343 ;; Place where setuid programs used to be stored. It exists for backwards
344 ;; compatibility & will be removed. Use %PRIVILEGED-PROGRAM-DIRECTORY instead.
345 "/run/setuid-programs")
346
347(define %privileged-program-directory
348 ;; Place where privileged copies of programs are stored.
349 "/run/privileged/bin")
350
351(define (activate-privileged-programs programs libcap)
352 "Turn PROGRAMS, a list of file privileged-programs records, into privileged
353copies stored under %PRIVILEGED-PROGRAM-DIRECTORY, using LIBCAP's setcap(8)
354binary if needed."
355 (define (ensure-empty-directory directory)
356 (if (file-exists? directory)
357 (for-each (compose delete-file
358 (cut string-append directory "/" <>))
359 (scandir directory
360 (lambda (file)
361 (not (member file '("." ".."))))
362 string<?))
363 (mkdir-p directory)) )
364
365 (define (make-privileged-program program setuid? setgid? uid gid capabilities)
366 (let ((target (string-append %privileged-program-directory
367 "/" (basename program)))
368 (mode (+ #o0555 ; base permissions
369 (if setuid? #o4000 0) ; setuid bit
370 (if setgid? #o2000 0)))) ; setgid bit
371 (copy-file program target)
372 (chown target uid gid)
373 (chmod target mode)
374 (when (and capabilities libcap)
375 (system* (string-append libcap "/sbin/setcap")
376 "-q" capabilities target))))
377
378 (define (make-deprecated-wrapper program)
379 ;; This will eventually become a script that warns on usage, then vanish.
380 (symlink (string-append %privileged-program-directory
381 "/" (basename program))
382 (string-append %setuid-directory
383 "/" (basename program))))
384
385 (format #t "setting up privileged programs in '~a'...~%"
386 %privileged-program-directory)
387 (ensure-empty-directory %privileged-program-directory)
388 (ensure-empty-directory %setuid-directory)
389
390 (for-each (lambda (program)
391 (catch 'system-error
392 (lambda ()
393 (let* ((program-name (privileged-program-program program))
394 (setuid? (privileged-program-setuid? program))
395 (setgid? (privileged-program-setgid? program))
396 (user (privileged-program-user program))
397 (group (privileged-program-group program))
398 (capabilities (privileged-program-capabilities program))
399 (uid (match user
400 ((? string?) (passwd:uid (getpwnam user)))
401 ((? integer?) user)))
402 (gid (match group
403 ((? string?) (group:gid (getgrnam group)))
404 ((? integer?) group))))
405 (make-privileged-program program-name
406 setuid? setgid? uid gid
407 capabilities)
408 (make-deprecated-wrapper program-name)))
409 (lambda args
410 ;; If we fail to create a privileged program, better keep going
411 ;; so that we don't leave %PRIVILEGED-PROGRAM-DIRECTORY empty
412 ;; or half-populated. This can happen if PROGRAMS contains
413 ;; incorrect file names: <https://bugs.gnu.org/38800>.
414 (format (current-error-port)
415 "warning: failed to privilege ~s: ~a~%"
416 (privileged-program-program program)
417 (strerror (system-error-errno args))))))
418 programs))
419
420(define (activate-special-files special-files)
421 "Install the files listed in SPECIAL-FILES. Each element of SPECIAL-FILES
422is a pair where the first element is the name of the special file and the
423second element is the name it should appear at, such as:
424
425 ((\"/bin/sh\" \"/gnu/store/…-bash/bin/sh\")
426 (\"/usr/bin/env\" \"/gnu/store/…-coreutils/bin/env\"))
427"
428 (define install-special-file
429 (match-lambda
430 ((target file)
431 (let ((pivot (string-append target ".new")))
432 (mkdir-p (dirname target))
433 (symlink file pivot)
434 (rename-file pivot target)))))
435
436 (for-each install-special-file special-files))
437
438(define (activate-modprobe modprobe)
439 "Tell the kernel to use MODPROBE to load modules."
440
441 ;; If the kernel was built without loadable module support, this file is
442 ;; unavailable, so check for its existence first.
443 (when (file-exists? "/proc/sys/kernel/modprobe")
444 (call-with-output-file "/proc/sys/kernel/modprobe"
445 (lambda (port)
446 (display modprobe port)))))
447
448(define (activate-firmware directory)
449 "Tell the kernel to look for device firmware under DIRECTORY. This
450mechanism bypasses udev: it allows Linux to handle firmware loading directly
451by itself, without having to resort to a \"user helper\"."
452
453 ;; If the kernel was built without firmware loading support, this file
454 ;; does not exist. Do nothing in that case.
455 (let ((firmware-path "/sys/module/firmware_class/parameters/path"))
456 (when (file-exists? firmware-path)
457 (call-with-output-file firmware-path
458 (lambda (port)
459 (display directory port))))))
460
461(define (activate-ptrace-attach)
462 "Allow users to PTRACE_ATTACH their own processes.
463
464This works around a regression introduced in the default \"security\" policy
465found in Linux 3.4 onward that prevents users from attaching to their own
466processes--see Yama.txt in the Linux source tree for the rationale. This
467sounds like an unacceptable restriction for little or no security
468improvement."
469 (let ((file "/proc/sys/kernel/yama/ptrace_scope"))
470 (when (file-exists? file)
471 (call-with-output-file file
472 (lambda (port)
473 (display 0 port))))))
474
475
476(define %current-system
477 ;; The system that is current (a symlink.) This is not necessarily the same
478 ;; as the system we booted (aka. /run/booted-system) because we can re-build
479 ;; a new system configuration and activate it, without rebooting.
480 "/run/current-system")
481
482(define (boot-time-system)
483 "Return the 'gnu.system' argument passed on the kernel command line."
484 (find-long-option "gnu.system" (if (string-contains %host-type "linux-gnu")
485 (linux-command-line)
486 (command-line))))
487
488(define* (activate-current-system
489 #:optional (system (or (getenv "GUIX_NEW_SYSTEM")
490 (boot-time-system))))
491 "Atomically make SYSTEM the current system."
492 ;; The 'GUIX_NEW_SYSTEM' environment variable is used as a way for 'guix
493 ;; system reconfigure' to pass the file name of the new system.
494
495 (format #t "making '~a' the current system...~%" system)
496
497 (mkdir-p "/run")
498 ;; Atomically make SYSTEM current.
499 (let ((new (string-append %current-system ".new")))
500 (when (file-exists? new)
501 (delete-file new))
502 (symlink system new)
503 (rename-file new %current-system)))
504
505;;; activation.scm ends here