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