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