Commit | Line | Data |
---|---|---|
4dfe6c58 | 1 | ;;; GNU Guix --- Functional package management for GNU |
520bac7e MD |
2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
3 | ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> | |
4 | ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> | |
5 | ;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org> | |
6 | ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> | |
7 | ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> | |
8 | ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> | |
4dfe6c58 LC |
9 | ;;; |
10 | ;;; This file is part of GNU Guix. | |
11 | ;;; | |
12 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
13 | ;;; under the terms of the GNU General Public License as published by | |
14 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
15 | ;;; your option) any later version. | |
16 | ;;; | |
17 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
18 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;;; GNU General Public License for more details. | |
21 | ;;; | |
22 | ;;; You should have received a copy of the GNU General Public License | |
23 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
24 | ||
548f7a8f | 25 | (define-module (gnu build activation) |
6061d015 | 26 | #:use-module (gnu system accounts) |
0ae735bc | 27 | #:use-module (gnu build accounts) |
8a9e21d1 | 28 | #:use-module (gnu build linux-boot) |
09e028f4 | 29 | #:use-module (guix build utils) |
d497b6ab | 30 | #:use-module ((guix build syscalls) #:select (with-file-lock)) |
4dfe6c58 | 31 | #:use-module (ice-9 ftw) |
ab6a279a | 32 | #:use-module (ice-9 match) |
d429878d | 33 | #:use-module (ice-9 vlist) |
ab6a279a | 34 | #:use-module (srfi srfi-1) |
0ae735bc | 35 | #:use-module (srfi srfi-11) |
ad896f23 | 36 | #:use-module (srfi srfi-26) |
ab6a279a | 37 | #:export (activate-users+groups |
ae763b5b | 38 | activate-user-home |
ab6a279a | 39 | activate-etc |
b4140694 | 40 | activate-setuid-programs |
387e1754 | 41 | activate-special-files |
d460204f | 42 | activate-modprobe |
f34c56be | 43 | activate-firmware |
b158f1d7 | 44 | activate-ptrace-attach |
520bac7e MD |
45 | activate-current-system |
46 | mkdir-p/perms)) | |
4dfe6c58 LC |
47 | |
48 | ;;; Commentary: | |
49 | ;;; | |
50 | ;;; This module provides "activation" helpers. Activation is the process that | |
51 | ;;; consists in setting up system-wide files and directories so that an | |
52 | ;;; 'operating-system' configuration becomes active. | |
53 | ;;; | |
54 | ;;; Code: | |
55 | ||
45c5b47b LC |
56 | (define %skeleton-directory |
57 | ;; Directory containing skeleton files for new accounts. | |
58 | ;; Note: keep the trailing '/' so that 'scandir' enters it. | |
59 | "/etc/skel/") | |
60 | ||
61 | (define (dot-or-dot-dot? file) | |
62 | (member file '("." ".."))) | |
63 | ||
520bac7e MD |
64 | ;; Based upon mkdir-p from (guix build utils) |
65 | (define (verify-not-symbolic dir) | |
66 | "Verify DIR or its ancestors aren't symbolic links." | |
67 | (define absolute? | |
68 | (string-prefix? "/" dir)) | |
69 | ||
70 | (define not-slash | |
71 | (char-set-complement (char-set #\/))) | |
72 | ||
73 | (define (verify-component file) | |
74 | (unless (eq? 'directory (stat:type (lstat file))) | |
75 | (error "file name component is not a directory" dir))) | |
76 | ||
77 | (let loop ((components (string-tokenize dir not-slash)) | |
78 | (root (if absolute? | |
79 | "" | |
80 | "."))) | |
81 | (match components | |
82 | ((head tail ...) | |
83 | (let ((file (string-append root "/" head))) | |
84 | (catch 'system-error | |
85 | (lambda () | |
86 | (verify-component file) | |
87 | (loop tail file)) | |
88 | (lambda args | |
89 | (if (= ENOENT (system-error-errno args)) | |
90 | #t | |
91 | (apply throw args)))))) | |
92 | (() #t)))) | |
93 | ||
94 | ;; TODO: the TOCTTOU race can be addressed once guile has bindings | |
95 | ;; for fstatat, openat and friends. | |
96 | (define (mkdir-p/perms directory owner bits) | |
97 | "Create the directory DIRECTORY and all its ancestors. | |
98 | Verify no component of DIRECTORY is a symbolic link. | |
99 | Warning: this is currently suspect to a TOCTTOU race!" | |
100 | (verify-not-symbolic directory) | |
101 | (mkdir-p directory) | |
102 | (chown directory (passwd:uid owner) (passwd:gid owner)) | |
103 | (chmod directory bits)) | |
104 | ||
45c5b47b | 105 | (define* (copy-account-skeletons home |
cf98d342 LC |
106 | #:key |
107 | (directory %skeleton-directory) | |
108 | uid gid) | |
109 | "Copy the account skeletons from DIRECTORY to HOME. When UID is an integer, | |
2161820e MD |
110 | make it the owner of all the files created except the home directory; likewise |
111 | for GID." | |
cf98d342 LC |
112 | (define (set-owner file) |
113 | (when (or uid gid) | |
114 | (chown file (or uid -1) (or gid -1)))) | |
115 | ||
45c5b47b LC |
116 | (let ((files (scandir directory (negate dot-or-dot-dot?) |
117 | string<?))) | |
118 | (mkdir-p home) | |
119 | (for-each (lambda (file) | |
356a62b8 | 120 | (let ((target (string-append home "/" file))) |
4e8b7502 | 121 | (copy-recursively (string-append directory "/" file) |
2fa909b2 LC |
122 | target |
123 | #:log (%make-void-port "w")) | |
cf98d342 LC |
124 | (for-each set-owner |
125 | (find-files target (const #t) | |
126 | #:directories? #t)) | |
356a62b8 LC |
127 | (make-file-writable target))) |
128 | files))) | |
129 | ||
130 | (define* (make-skeletons-writable home | |
131 | #:optional (directory %skeleton-directory)) | |
132 | "Make sure that the files that have been copied from DIRECTORY to HOME are | |
133 | owner-writable in HOME." | |
134 | (let ((files (scandir directory (negate dot-or-dot-dot?) | |
135 | string<?))) | |
136 | (for-each (lambda (file) | |
137 | (let ((target (string-append home "/" file))) | |
138 | (when (file-exists? target) | |
139 | (make-file-writable target)))) | |
45c5b47b LC |
140 | files))) |
141 | ||
d429878d LC |
142 | (define (duplicates lst) |
143 | "Return elements from LST present more than once in LST." | |
144 | (let loop ((lst lst) | |
145 | (seen vlist-null) | |
146 | (result '())) | |
147 | (match lst | |
148 | (() | |
149 | (reverse result)) | |
150 | ((head . tail) | |
151 | (loop tail | |
152 | (vhash-cons head #t seen) | |
153 | (if (vhash-assoc head seen) | |
154 | (cons head result) | |
155 | result)))))) | |
156 | ||
ab6a279a | 157 | (define (activate-users+groups users groups) |
6061d015 LC |
158 | "Make sure USERS (a list of user account records) and GROUPS (a list of user |
159 | group records) are all available." | |
0ae735bc LC |
160 | (define (make-home-directory user) |
161 | (let ((home (user-account-home-directory user)) | |
162 | (pwd (getpwnam (user-account-name user)))) | |
163 | (mkdir-p home) | |
d429878d LC |
164 | |
165 | ;; Always set ownership and permissions for home directories of system | |
166 | ;; accounts. If a service needs looser permissions on its home | |
167 | ;; directories, it can always chmod it in an activation snippet. | |
0ae735bc LC |
168 | (chown home (passwd:uid pwd) (passwd:gid pwd)) |
169 | (chmod home #o700))) | |
ab6a279a | 170 | |
d429878d LC |
171 | (define system-accounts |
172 | (filter (lambda (user) | |
173 | (and (user-account-system? user) | |
174 | (user-account-create-home-directory? user))) | |
175 | users)) | |
176 | ||
6526d43e | 177 | ;; Allow home directories to be created under /var/lib. |
a7199b7d | 178 | (mkdir-p "/var/lib") |
6526d43e | 179 | |
d497b6ab LC |
180 | ;; Take same lock as libc's 'lckpwdf' (but without a timeout) while we read |
181 | ;; and write the databases. This ensures there's no race condition with | |
182 | ;; other tools that might be accessing it at the same time. | |
183 | (with-file-lock %password-lock-file | |
184 | (let-values (((groups passwd shadow) | |
185 | (user+group-databases users groups))) | |
186 | (write-group groups) | |
187 | (write-passwd passwd) | |
188 | (write-shadow shadow))) | |
189 | ||
190 | ;; Home directories of non-system accounts are created by | |
191 | ;; 'activate-user-home'. | |
192 | (for-each make-home-directory system-accounts) | |
193 | ||
194 | ;; Turn shared home directories, such as /var/empty, into root-owned, | |
195 | ;; read-only places. | |
196 | (for-each (lambda (directory) | |
197 | (chown directory 0 0) | |
198 | (chmod directory #o555)) | |
199 | (duplicates (map user-account-home-directory system-accounts)))) | |
ab6a279a | 200 | |
ae763b5b LC |
201 | (define (activate-user-home users) |
202 | "Create and populate the home directory of USERS, a list of tuples, unless | |
203 | they already exist." | |
204 | (define ensure-user-home | |
6061d015 LC |
205 | (lambda (user) |
206 | (let ((name (user-account-name user)) | |
207 | (home (user-account-home-directory user)) | |
208 | (create-home? (user-account-create-home-directory? user)) | |
209 | (system? (user-account-system? user))) | |
210 | ;; The home directories of system accounts are created during | |
211 | ;; activation, not here. | |
212 | (unless (or (not home) (not create-home?) system? | |
213 | (directory-exists? home)) | |
214 | (let* ((pw (getpwnam name)) | |
215 | (uid (passwd:uid pw)) | |
216 | (gid (passwd:gid pw))) | |
217 | (mkdir-p home) | |
6061d015 LC |
218 | (chmod home #o700) |
219 | (copy-account-skeletons home | |
2161820e MD |
220 | #:uid uid #:gid gid) |
221 | ||
222 | ;; It is important 'chown' be called after | |
223 | ;; 'copy-account-skeletons'. Otherwise, a malicious user with | |
224 | ;; good timing could create a symlink in HOME that would be | |
225 | ;; dereferenced by 'copy-account-skeletons'. | |
226 | (chown home uid gid)))))) | |
ae763b5b LC |
227 | |
228 | (for-each ensure-user-home users)) | |
229 | ||
4dfe6c58 LC |
230 | (define (activate-etc etc) |
231 | "Install ETC, a directory in the store, as the source of static files for | |
232 | /etc." | |
233 | ||
234 | ;; /etc is a mixture of static and dynamic settings. Here is where we | |
235 | ;; initialize it from the static part. | |
236 | ||
ee7bae3b LC |
237 | (define (rm-f file) |
238 | (false-if-exception (delete-file file))) | |
239 | ||
4dfe6c58 | 240 | (format #t "populating /etc from ~a...~%" etc) |
49962b15 | 241 | (mkdir-p "/etc") |
ee7bae3b | 242 | |
78ab0746 MW |
243 | ;; Create the /etc/ssl -> /run/current-system/profile/etc/ssl symlink. This |
244 | ;; symlink, to a target outside of the store, probably doesn't belong in the | |
245 | ;; static 'etc' store directory. However, if it were to be put there, | |
246 | ;; beware that if /run/current-system/profile/etc/ssl doesn't exist at the | |
247 | ;; time of activation (e.g. when installing a fresh system), the call to | |
248 | ;; 'file-is-directory?' below will fail because it uses 'stat', not 'lstat'. | |
249 | (rm-f "/etc/ssl") | |
250 | (symlink "/run/current-system/profile/etc/ssl" "/etc/ssl") | |
251 | ||
ee7bae3b LC |
252 | (rm-f "/etc/static") |
253 | (symlink etc "/etc/static") | |
254 | (for-each (lambda (file) | |
255 | (let ((target (string-append "/etc/" file)) | |
256 | (source (string-append "/etc/static/" file))) | |
257 | (rm-f target) | |
258 | ||
259 | ;; Things such as /etc/sudoers must be regular files, not | |
260 | ;; symlinks; furthermore, they could be modified behind our | |
261 | ;; back---e.g., with 'visudo'. Thus, make a copy instead of | |
262 | ;; symlinking them. | |
263 | (if (file-is-directory? source) | |
264 | (symlink source target) | |
265 | (copy-file source target)) | |
266 | ||
267 | ;; XXX: Dirty hack to meet sudo's expectations. | |
268 | (when (string=? (basename target) "sudoers") | |
269 | (chmod target #o440)))) | |
45c5b47b | 270 | (scandir etc (negate dot-or-dot-dot?) |
ee7bae3b LC |
271 | |
272 | ;; The default is 'string-locale<?', but we don't have | |
273 | ;; it when run from the initrd's statically-linked | |
274 | ;; Guile. | |
6496de9b | 275 | string<?))) |
4dfe6c58 | 276 | |
09e028f4 LC |
277 | (define %setuid-directory |
278 | ;; Place where setuid programs are stored. | |
279 | "/run/setuid-programs") | |
280 | ||
281 | (define (activate-setuid-programs programs) | |
282 | "Turn PROGRAMS, a list of file names, into setuid programs stored under | |
283 | %SETUID-DIRECTORY." | |
284 | (define (make-setuid-program prog) | |
285 | (let ((target (string-append %setuid-directory | |
286 | "/" (basename prog)))) | |
5e66574a | 287 | (copy-file prog target) |
09e028f4 | 288 | (chown target 0 0) |
aa8de806 | 289 | (chmod target #o4555))) |
09e028f4 LC |
290 | |
291 | (format #t "setting up setuid programs in '~a'...~%" | |
292 | %setuid-directory) | |
293 | (if (file-exists? %setuid-directory) | |
ad896f23 LC |
294 | (for-each (compose delete-file |
295 | (cut string-append %setuid-directory "/" <>)) | |
09e028f4 LC |
296 | (scandir %setuid-directory |
297 | (lambda (file) | |
298 | (not (member file '("." "..")))) | |
299 | string<?)) | |
300 | (mkdir-p %setuid-directory)) | |
301 | ||
7c4e4bac LC |
302 | (for-each (lambda (program) |
303 | (catch 'system-error | |
304 | (lambda () | |
305 | (make-setuid-program program)) | |
306 | (lambda args | |
307 | ;; If we fail to create a setuid program, better keep going | |
308 | ;; so that we don't leave %SETUID-DIRECTORY empty or | |
309 | ;; half-populated. This can happen if PROGRAMS contains | |
310 | ;; incorrect file names: <https://bugs.gnu.org/38800>. | |
311 | (format (current-error-port) | |
312 | "warning: failed to make '~a' setuid-root: ~a~%" | |
313 | program (strerror (system-error-errno args)))))) | |
314 | programs)) | |
09e028f4 | 315 | |
387e1754 LC |
316 | (define (activate-special-files special-files) |
317 | "Install the files listed in SPECIAL-FILES. Each element of SPECIAL-FILES | |
318 | is a pair where the first element is the name of the special file and the | |
319 | second element is the name it should appear at, such as: | |
320 | ||
321 | ((\"/bin/sh\" \"/gnu/store/…-bash/bin/sh\") | |
322 | (\"/usr/bin/env\" \"/gnu/store/…-coreutils/bin/env\")) | |
323 | " | |
324 | (define install-special-file | |
325 | (match-lambda | |
326 | ((target file) | |
327 | (let ((pivot (string-append target ".new"))) | |
328 | (mkdir-p (dirname target)) | |
329 | (symlink file pivot) | |
330 | (rename-file pivot target))))) | |
331 | ||
332 | (for-each install-special-file special-files)) | |
ee248b6a | 333 | |
d460204f LC |
334 | (define (activate-modprobe modprobe) |
335 | "Tell the kernel to use MODPROBE to load modules." | |
83460433 | 336 | |
337 | ;; If the kernel was built without loadable module support, this file is | |
338 | ;; unavailable, so check for its existence first. | |
339 | (when (file-exists? "/proc/sys/kernel/modprobe") | |
340 | (call-with-output-file "/proc/sys/kernel/modprobe" | |
341 | (lambda (port) | |
342 | (display modprobe port))))) | |
d460204f | 343 | |
f34c56be LC |
344 | (define (activate-firmware directory) |
345 | "Tell the kernel to look for device firmware under DIRECTORY. This | |
346 | mechanism bypasses udev: it allows Linux to handle firmware loading directly | |
347 | by itself, without having to resort to a \"user helper\"." | |
348 | (call-with-output-file "/sys/module/firmware_class/parameters/path" | |
349 | (lambda (port) | |
350 | (display directory port)))) | |
b158f1d7 LC |
351 | |
352 | (define (activate-ptrace-attach) | |
353 | "Allow users to PTRACE_ATTACH their own processes. | |
354 | ||
355 | This works around a regression introduced in the default \"security\" policy | |
356 | found in Linux 3.4 onward that prevents users from attaching to their own | |
357 | processes--see Yama.txt in the Linux source tree for the rationale. This | |
358 | sounds like an unacceptable restriction for little or no security | |
359 | improvement." | |
15f0de05 MW |
360 | (let ((file "/proc/sys/kernel/yama/ptrace_scope")) |
361 | (when (file-exists? file) | |
362 | (call-with-output-file file | |
363 | (lambda (port) | |
364 | (display 0 port)))))) | |
f34c56be LC |
365 | |
366 | \f | |
b4140694 LC |
367 | (define %current-system |
368 | ;; The system that is current (a symlink.) This is not necessarily the same | |
484a2b3a LC |
369 | ;; as the system we booted (aka. /run/booted-system) because we can re-build |
370 | ;; a new system configuration and activate it, without rebooting. | |
b4140694 LC |
371 | "/run/current-system") |
372 | ||
373 | (define (boot-time-system) | |
374 | "Return the '--system' argument passed on the kernel command line." | |
c3fd2df7 | 375 | (find-long-option "--system" (if (string-contains %host-type "linux-gnu") |
ea80cdbc | 376 | (linux-command-line) |
c3fd2df7 | 377 | (command-line)))) |
b4140694 | 378 | |
6d49355d LC |
379 | (define* (activate-current-system |
380 | #:optional (system (or (getenv "GUIX_NEW_SYSTEM") | |
381 | (boot-time-system)))) | |
484a2b3a | 382 | "Atomically make SYSTEM the current system." |
6d49355d LC |
383 | ;; The 'GUIX_NEW_SYSTEM' environment variable is used as a way for 'guix |
384 | ;; system reconfigure' to pass the file name of the new system. | |
385 | ||
b4140694 | 386 | (format #t "making '~a' the current system...~%" system) |
b4140694 LC |
387 | |
388 | ;; Atomically make SYSTEM current. | |
389 | (let ((new (string-append %current-system ".new"))) | |
390 | (symlink system new) | |
391 | (rename-file new %current-system))) | |
392 | ||
4dfe6c58 | 393 | ;;; activation.scm ends here |