Commit | Line | Data |
---|---|---|
4dfe6c58 | 1 | ;;; GNU Guix --- Functional package management for GNU |
ae763b5b | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017 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) |
8a9e21d1 | 21 | #:use-module (gnu build linux-boot) |
09e028f4 | 22 | #:use-module (guix build utils) |
4dfe6c58 | 23 | #:use-module (ice-9 ftw) |
ab6a279a LC |
24 | #:use-module (ice-9 match) |
25 | #:use-module (srfi srfi-1) | |
ad896f23 | 26 | #:use-module (srfi srfi-26) |
ab6a279a | 27 | #:export (activate-users+groups |
ae763b5b | 28 | activate-user-home |
ab6a279a | 29 | activate-etc |
b4140694 | 30 | activate-setuid-programs |
387e1754 | 31 | activate-special-files |
d460204f | 32 | activate-modprobe |
f34c56be | 33 | activate-firmware |
b158f1d7 | 34 | activate-ptrace-attach |
b4140694 | 35 | activate-current-system)) |
4dfe6c58 LC |
36 | |
37 | ;;; Commentary: | |
38 | ;;; | |
39 | ;;; This module provides "activation" helpers. Activation is the process that | |
40 | ;;; consists in setting up system-wide files and directories so that an | |
41 | ;;; 'operating-system' configuration becomes active. | |
42 | ;;; | |
43 | ;;; Code: | |
44 | ||
9bea87a5 LC |
45 | (define (enumerate thunk) |
46 | "Return the list of values returned by THUNK until it returned #f." | |
47 | (let loop ((entry (thunk)) | |
48 | (result '())) | |
49 | (if (not entry) | |
50 | (reverse result) | |
51 | (loop (thunk) (cons entry result))))) | |
52 | ||
53 | (define (current-users) | |
54 | "Return the passwd entries for all the currently defined user accounts." | |
55 | (setpw) | |
56 | (enumerate getpwent)) | |
57 | ||
58 | (define (current-groups) | |
59 | "Return the group entries for all the currently defined user groups." | |
60 | (setgr) | |
61 | (enumerate getgrent)) | |
62 | ||
c8fa3426 | 63 | (define* (add-group name #:key gid password system? |
ab6a279a LC |
64 | (log-port (current-error-port))) |
65 | "Add NAME as a user group, with the given numeric GID if specified." | |
66 | ;; Use 'groupadd' from the Shadow package. | |
67 | (format log-port "adding group '~a'...~%" name) | |
68 | (let ((args `(,@(if gid `("-g" ,(number->string gid)) '()) | |
69 | ,@(if password `("-p" ,password) '()) | |
c8fa3426 | 70 | ,@(if system? `("--system") '()) |
ab6a279a LC |
71 | ,name))) |
72 | (zero? (apply system* "groupadd" args)))) | |
73 | ||
45c5b47b LC |
74 | (define %skeleton-directory |
75 | ;; Directory containing skeleton files for new accounts. | |
76 | ;; Note: keep the trailing '/' so that 'scandir' enters it. | |
77 | "/etc/skel/") | |
78 | ||
79 | (define (dot-or-dot-dot? file) | |
80 | (member file '("." ".."))) | |
81 | ||
82 | (define* (copy-account-skeletons home | |
cf98d342 LC |
83 | #:key |
84 | (directory %skeleton-directory) | |
85 | uid gid) | |
86 | "Copy the account skeletons from DIRECTORY to HOME. When UID is an integer, | |
87 | make it the owner of all the files created; likewise for GID." | |
88 | (define (set-owner file) | |
89 | (when (or uid gid) | |
90 | (chown file (or uid -1) (or gid -1)))) | |
91 | ||
45c5b47b LC |
92 | (let ((files (scandir directory (negate dot-or-dot-dot?) |
93 | string<?))) | |
94 | (mkdir-p home) | |
cf98d342 | 95 | (set-owner home) |
45c5b47b | 96 | (for-each (lambda (file) |
356a62b8 | 97 | (let ((target (string-append home "/" file))) |
4e8b7502 | 98 | (copy-recursively (string-append directory "/" file) |
2fa909b2 LC |
99 | target |
100 | #:log (%make-void-port "w")) | |
cf98d342 LC |
101 | (for-each set-owner |
102 | (find-files target (const #t) | |
103 | #:directories? #t)) | |
356a62b8 LC |
104 | (make-file-writable target))) |
105 | files))) | |
106 | ||
107 | (define* (make-skeletons-writable home | |
108 | #:optional (directory %skeleton-directory)) | |
109 | "Make sure that the files that have been copied from DIRECTORY to HOME are | |
110 | owner-writable in HOME." | |
111 | (let ((files (scandir directory (negate dot-or-dot-dot?) | |
112 | string<?))) | |
113 | (for-each (lambda (file) | |
114 | (let ((target (string-append home "/" file))) | |
115 | (when (file-exists? target) | |
116 | (make-file-writable target)))) | |
45c5b47b LC |
117 | files))) |
118 | ||
ab6a279a | 119 | (define* (add-user name group |
eb56ee02 LC |
120 | #:key uid comment home create-home? |
121 | shell password system? | |
ab6a279a LC |
122 | (supplementary-groups '()) |
123 | (log-port (current-error-port))) | |
124 | "Create an account for user NAME part of GROUP, with the specified | |
125 | properties. Return #t on success." | |
126 | (format log-port "adding user '~a'...~%" name) | |
127 | ||
128 | (if (and uid (zero? uid)) | |
129 | ||
130 | ;; 'useradd' fails with "Cannot determine your user name" if the root | |
131 | ;; account doesn't exist. Thus, for bootstrapping purposes, create that | |
132 | ;; one manually. | |
41db5a75 | 133 | (let ((home (or home "/root"))) |
ab6a279a LC |
134 | (call-with-output-file "/etc/shadow" |
135 | (cut format <> "~a::::::::~%" name)) | |
136 | (call-with-output-file "/etc/passwd" | |
137 | (cut format <> "~a:x:~a:~a:~a:~a:~a~%" | |
138 | name "0" "0" comment home shell)) | |
139 | (chmod "/etc/shadow" #o600) | |
41db5a75 LC |
140 | (copy-account-skeletons home) |
141 | (chmod home #o700) | |
ab6a279a LC |
142 | #t) |
143 | ||
144 | ;; Use 'useradd' from the Shadow package. | |
145 | (let ((args `(,@(if uid `("-u" ,(number->string uid)) '()) | |
146 | "-g" ,(if (number? group) (number->string group) group) | |
147 | ,@(if (pair? supplementary-groups) | |
148 | `("-G" ,(string-join supplementary-groups ",")) | |
149 | '()) | |
150 | ,@(if comment `("-c" ,comment) '()) | |
eb56ee02 | 151 | ,@(if (and home create-home?) |
f3b692ac LC |
152 | (if (file-exists? home) |
153 | `("-d" ,home) ; avoid warning from 'useradd' | |
154 | `("-d" ,home "--create-home")) | |
155 | '()) | |
ab6a279a LC |
156 | ,@(if shell `("-s" ,shell) '()) |
157 | ,@(if password `("-p" ,password) '()) | |
459dd9ea | 158 | ,@(if system? '("--system") '()) |
ab6a279a | 159 | ,name))) |
356a62b8 LC |
160 | (and (zero? (apply system* "useradd" args)) |
161 | (begin | |
162 | ;; Since /etc/skel is a link to a directory in the store where | |
163 | ;; all files have the writable bit cleared, and since 'useradd' | |
164 | ;; preserves permissions when it copies them, explicitly make | |
165 | ;; them writable. | |
166 | (make-skeletons-writable home) | |
167 | #t))))) | |
ab6a279a | 168 | |
e2b464b7 | 169 | (define* (modify-user name group |
eb56ee02 LC |
170 | #:key uid comment home create-home? |
171 | shell password system? | |
e2b464b7 LC |
172 | (supplementary-groups '()) |
173 | (log-port (current-error-port))) | |
174 | "Modify user account NAME to have all the given settings." | |
175 | ;; Use 'usermod' from the Shadow package. | |
176 | (let ((args `(,@(if uid `("-u" ,(number->string uid)) '()) | |
177 | "-g" ,(if (number? group) (number->string group) group) | |
178 | ,@(if (pair? supplementary-groups) | |
179 | `("-G" ,(string-join supplementary-groups ",")) | |
180 | '()) | |
181 | ,@(if comment `("-c" ,comment) '()) | |
182 | ;; Don't use '--move-home', so ignore HOME. | |
183 | ,@(if shell `("-s" ,shell) '()) | |
184 | ,name))) | |
185 | (zero? (apply system* "usermod" args)))) | |
186 | ||
9bea87a5 LC |
187 | (define* (delete-user name #:key (log-port (current-error-port))) |
188 | "Remove user account NAME. Return #t on success. This may fail if NAME is | |
189 | logged in." | |
190 | (format log-port "deleting user '~a'...~%" name) | |
191 | (zero? (system* "userdel" name))) | |
192 | ||
193 | (define* (delete-group name #:key (log-port (current-error-port))) | |
194 | "Remove group NAME. Return #t on success." | |
195 | (format log-port "deleting group '~a'...~%" name) | |
196 | (zero? (system* "groupdel" name))) | |
197 | ||
e2b464b7 | 198 | (define* (ensure-user name group |
eb56ee02 LC |
199 | #:key uid comment home create-home? |
200 | shell password system? | |
e2b464b7 LC |
201 | (supplementary-groups '()) |
202 | (log-port (current-error-port)) | |
203 | #:rest rest) | |
204 | "Make sure user NAME exists and has the relevant settings." | |
205 | (if (false-if-exception (getpwnam name)) | |
206 | (apply modify-user name group rest) | |
207 | (apply add-user name group rest))) | |
208 | ||
ab6a279a LC |
209 | (define (activate-users+groups users groups) |
210 | "Make sure the accounts listed in USERS and the user groups listed in GROUPS | |
211 | are all available. | |
212 | ||
213 | Each item in USERS is a list of all the characteristics of a user account; | |
214 | each item in GROUPS is a tuple with the group name, group password or #f, and | |
215 | numeric gid or #f." | |
216 | (define (touch file) | |
f01efec0 | 217 | (close-port (open-file file "a0b"))) |
ab6a279a LC |
218 | |
219 | (define activate-user | |
220 | (match-lambda | |
eb56ee02 LC |
221 | ((name uid group supplementary-groups comment home create-home? |
222 | shell password system?) | |
e2b464b7 LC |
223 | (let ((profile-dir (string-append "/var/guix/profiles/per-user/" |
224 | name))) | |
225 | (ensure-user name group | |
226 | #:uid uid | |
227 | #:system? system? | |
228 | #:supplementary-groups supplementary-groups | |
229 | #:comment comment | |
230 | #:home home | |
41f76ae0 LC |
231 | |
232 | ;; Home directories of non-system accounts are created by | |
233 | ;; 'activate-user-home'. | |
ae763b5b | 234 | #:create-home? (and create-home? system?) |
41f76ae0 | 235 | |
e2b464b7 LC |
236 | #:shell shell |
237 | #:password password) | |
238 | ||
239 | (unless system? | |
240 | ;; Create the profile directory for the new account. | |
241 | (let ((pw (getpwnam name))) | |
242 | (mkdir-p profile-dir) | |
243 | (chown profile-dir (passwd:uid pw) (passwd:gid pw)))))))) | |
ab6a279a LC |
244 | |
245 | ;; 'groupadd' aborts if the file doesn't already exist. | |
246 | (touch "/etc/group") | |
247 | ||
6526d43e | 248 | ;; Allow home directories to be created under /var/lib. |
a7199b7d | 249 | (mkdir-p "/var/lib") |
6526d43e | 250 | |
ab6a279a LC |
251 | ;; Create the root account so we can use 'useradd' and 'groupadd'. |
252 | (activate-user (find (match-lambda | |
253 | ((name (? zero?) _ ...) #t) | |
254 | (_ #f)) | |
255 | users)) | |
256 | ||
257 | ;; Then create the groups. | |
258 | (for-each (match-lambda | |
c8fa3426 | 259 | ((name password gid system?) |
e2fcc23a | 260 | (unless (false-if-exception (getgrnam name)) |
c8fa3426 LC |
261 | (add-group name |
262 | #:gid gid #:password password | |
263 | #:system? system?)))) | |
ab6a279a LC |
264 | groups) |
265 | ||
9bea87a5 LC |
266 | ;; Create the other user accounts. |
267 | (for-each activate-user users) | |
268 | ||
269 | ;; Finally, delete extra user accounts and groups. | |
270 | (for-each delete-user | |
271 | (lset-difference string=? | |
272 | (map passwd:name (current-users)) | |
273 | (match users | |
274 | (((names . _) ...) | |
275 | names)))) | |
276 | (for-each delete-group | |
277 | (lset-difference string=? | |
278 | (map group:name (current-groups)) | |
279 | (match groups | |
280 | (((names . _) ...) | |
281 | names))))) | |
ab6a279a | 282 | |
ae763b5b LC |
283 | (define (activate-user-home users) |
284 | "Create and populate the home directory of USERS, a list of tuples, unless | |
285 | they already exist." | |
286 | (define ensure-user-home | |
287 | (match-lambda | |
288 | ((name uid group supplementary-groups comment home create-home? | |
289 | shell password system?) | |
41f76ae0 LC |
290 | ;; The home directories of system accounts are created during |
291 | ;; activation, not here. | |
292 | (unless (or (not home) (not create-home?) system? | |
293 | (directory-exists? home)) | |
cf98d342 LC |
294 | (let* ((pw (getpwnam name)) |
295 | (uid (passwd:uid pw)) | |
296 | (gid (passwd:gid pw))) | |
297 | (mkdir-p home) | |
298 | (chown home uid gid) | |
299 | (unless system? | |
300 | (copy-account-skeletons home | |
301 | #:uid uid #:gid gid))))))) | |
ae763b5b LC |
302 | |
303 | (for-each ensure-user-home users)) | |
304 | ||
4dfe6c58 LC |
305 | (define (activate-etc etc) |
306 | "Install ETC, a directory in the store, as the source of static files for | |
307 | /etc." | |
308 | ||
309 | ;; /etc is a mixture of static and dynamic settings. Here is where we | |
310 | ;; initialize it from the static part. | |
311 | ||
ee7bae3b LC |
312 | (define (rm-f file) |
313 | (false-if-exception (delete-file file))) | |
314 | ||
4dfe6c58 | 315 | (format #t "populating /etc from ~a...~%" etc) |
49962b15 | 316 | (mkdir-p "/etc") |
ee7bae3b | 317 | |
78ab0746 MW |
318 | ;; Create the /etc/ssl -> /run/current-system/profile/etc/ssl symlink. This |
319 | ;; symlink, to a target outside of the store, probably doesn't belong in the | |
320 | ;; static 'etc' store directory. However, if it were to be put there, | |
321 | ;; beware that if /run/current-system/profile/etc/ssl doesn't exist at the | |
322 | ;; time of activation (e.g. when installing a fresh system), the call to | |
323 | ;; 'file-is-directory?' below will fail because it uses 'stat', not 'lstat'. | |
324 | (rm-f "/etc/ssl") | |
325 | (symlink "/run/current-system/profile/etc/ssl" "/etc/ssl") | |
326 | ||
ee7bae3b LC |
327 | (rm-f "/etc/static") |
328 | (symlink etc "/etc/static") | |
329 | (for-each (lambda (file) | |
330 | (let ((target (string-append "/etc/" file)) | |
331 | (source (string-append "/etc/static/" file))) | |
332 | (rm-f target) | |
333 | ||
334 | ;; Things such as /etc/sudoers must be regular files, not | |
335 | ;; symlinks; furthermore, they could be modified behind our | |
336 | ;; back---e.g., with 'visudo'. Thus, make a copy instead of | |
337 | ;; symlinking them. | |
338 | (if (file-is-directory? source) | |
339 | (symlink source target) | |
340 | (copy-file source target)) | |
341 | ||
342 | ;; XXX: Dirty hack to meet sudo's expectations. | |
343 | (when (string=? (basename target) "sudoers") | |
344 | (chmod target #o440)))) | |
45c5b47b | 345 | (scandir etc (negate dot-or-dot-dot?) |
ee7bae3b LC |
346 | |
347 | ;; The default is 'string-locale<?', but we don't have | |
348 | ;; it when run from the initrd's statically-linked | |
349 | ;; Guile. | |
6496de9b | 350 | string<?))) |
4dfe6c58 | 351 | |
09e028f4 LC |
352 | (define %setuid-directory |
353 | ;; Place where setuid programs are stored. | |
354 | "/run/setuid-programs") | |
355 | ||
095f4deb LC |
356 | (define (link-or-copy source target) |
357 | "Attempt to make TARGET a hard link to SOURCE; if it fails, fall back to | |
358 | copy SOURCE to TARGET." | |
359 | (catch 'system-error | |
360 | (lambda () | |
361 | (link source target)) | |
362 | (lambda args | |
363 | ;; Perhaps SOURCE and TARGET live in a different file system, so copy | |
364 | ;; SOURCE. | |
365 | (copy-file source target)))) | |
366 | ||
09e028f4 LC |
367 | (define (activate-setuid-programs programs) |
368 | "Turn PROGRAMS, a list of file names, into setuid programs stored under | |
369 | %SETUID-DIRECTORY." | |
370 | (define (make-setuid-program prog) | |
371 | (let ((target (string-append %setuid-directory | |
372 | "/" (basename prog)))) | |
095f4deb | 373 | (link-or-copy prog target) |
09e028f4 LC |
374 | (chown target 0 0) |
375 | (chmod target #o6555))) | |
376 | ||
377 | (format #t "setting up setuid programs in '~a'...~%" | |
378 | %setuid-directory) | |
379 | (if (file-exists? %setuid-directory) | |
ad896f23 LC |
380 | (for-each (compose delete-file |
381 | (cut string-append %setuid-directory "/" <>)) | |
09e028f4 LC |
382 | (scandir %setuid-directory |
383 | (lambda (file) | |
384 | (not (member file '("." "..")))) | |
385 | string<?)) | |
386 | (mkdir-p %setuid-directory)) | |
387 | ||
388 | (for-each make-setuid-program programs)) | |
389 | ||
387e1754 LC |
390 | (define (activate-special-files special-files) |
391 | "Install the files listed in SPECIAL-FILES. Each element of SPECIAL-FILES | |
392 | is a pair where the first element is the name of the special file and the | |
393 | second element is the name it should appear at, such as: | |
394 | ||
395 | ((\"/bin/sh\" \"/gnu/store/…-bash/bin/sh\") | |
396 | (\"/usr/bin/env\" \"/gnu/store/…-coreutils/bin/env\")) | |
397 | " | |
398 | (define install-special-file | |
399 | (match-lambda | |
400 | ((target file) | |
401 | (let ((pivot (string-append target ".new"))) | |
402 | (mkdir-p (dirname target)) | |
403 | (symlink file pivot) | |
404 | (rename-file pivot target))))) | |
405 | ||
406 | (for-each install-special-file special-files)) | |
ee248b6a | 407 | |
d460204f LC |
408 | (define (activate-modprobe modprobe) |
409 | "Tell the kernel to use MODPROBE to load modules." | |
410 | (call-with-output-file "/proc/sys/kernel/modprobe" | |
411 | (lambda (port) | |
412 | (display modprobe port)))) | |
413 | ||
f34c56be LC |
414 | (define (activate-firmware directory) |
415 | "Tell the kernel to look for device firmware under DIRECTORY. This | |
416 | mechanism bypasses udev: it allows Linux to handle firmware loading directly | |
417 | by itself, without having to resort to a \"user helper\"." | |
418 | (call-with-output-file "/sys/module/firmware_class/parameters/path" | |
419 | (lambda (port) | |
420 | (display directory port)))) | |
b158f1d7 LC |
421 | |
422 | (define (activate-ptrace-attach) | |
423 | "Allow users to PTRACE_ATTACH their own processes. | |
424 | ||
425 | This works around a regression introduced in the default \"security\" policy | |
426 | found in Linux 3.4 onward that prevents users from attaching to their own | |
427 | processes--see Yama.txt in the Linux source tree for the rationale. This | |
428 | sounds like an unacceptable restriction for little or no security | |
429 | improvement." | |
15f0de05 MW |
430 | (let ((file "/proc/sys/kernel/yama/ptrace_scope")) |
431 | (when (file-exists? file) | |
432 | (call-with-output-file file | |
433 | (lambda (port) | |
434 | (display 0 port)))))) | |
f34c56be LC |
435 | |
436 | \f | |
b4140694 LC |
437 | (define %current-system |
438 | ;; The system that is current (a symlink.) This is not necessarily the same | |
484a2b3a LC |
439 | ;; as the system we booted (aka. /run/booted-system) because we can re-build |
440 | ;; a new system configuration and activate it, without rebooting. | |
b4140694 LC |
441 | "/run/current-system") |
442 | ||
443 | (define (boot-time-system) | |
444 | "Return the '--system' argument passed on the kernel command line." | |
445 | (find-long-option "--system" (linux-command-line))) | |
446 | ||
6d49355d LC |
447 | (define* (activate-current-system |
448 | #:optional (system (or (getenv "GUIX_NEW_SYSTEM") | |
449 | (boot-time-system)))) | |
484a2b3a | 450 | "Atomically make SYSTEM the current system." |
6d49355d LC |
451 | ;; The 'GUIX_NEW_SYSTEM' environment variable is used as a way for 'guix |
452 | ;; system reconfigure' to pass the file name of the new system. | |
453 | ||
b4140694 | 454 | (format #t "making '~a' the current system...~%" system) |
b4140694 LC |
455 | |
456 | ;; Atomically make SYSTEM current. | |
457 | (let ((new (string-append %current-system ".new"))) | |
458 | (symlink system new) | |
459 | (rename-file new %current-system))) | |
460 | ||
4dfe6c58 | 461 | ;;; activation.scm ends here |