1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
5 ;;; This file is part of GNU Guix.
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.
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.
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/>.
20 (define-module (gnu build activation)
21 #:use-module (gnu build linux-boot)
22 #:use-module (guix build utils)
23 #:use-module (ice-9 ftw)
24 #:use-module (ice-9 match)
25 #:use-module (srfi srfi-1)
26 #:use-module (srfi srfi-26)
27 #:export (activate-users+groups
29 activate-setuid-programs
33 activate-ptrace-attach
34 activate-current-system))
38 ;;; This module provides "activation" helpers. Activation is the process that
39 ;;; consists in setting up system-wide files and directories so that an
40 ;;; 'operating-system' configuration becomes active.
44 (define (enumerate thunk)
45 "Return the list of values returned by THUNK until it returned #f."
46 (let loop ((entry (thunk))
50 (loop (thunk) (cons entry result)))))
52 (define (current-users)
53 "Return the passwd entries for all the currently defined user accounts."
57 (define (current-groups)
58 "Return the group entries for all the currently defined user groups."
62 (define* (add-group name #:key gid password system?
63 (log-port (current-error-port)))
64 "Add NAME as a user group, with the given numeric GID if specified."
65 ;; Use 'groupadd' from the Shadow package.
66 (format log-port "adding group '~a'...~%" name)
67 (let ((args `(,@(if gid `("-g" ,(number->string gid)) '())
68 ,@(if password `("-p" ,password) '())
69 ,@(if system? `("--system") '())
71 (zero? (apply system* "groupadd" args))))
73 (define %skeleton-directory
74 ;; Directory containing skeleton files for new accounts.
75 ;; Note: keep the trailing '/' so that 'scandir' enters it.
78 (define (dot-or-dot-dot? file)
79 (member file '("." "..")))
81 (define (make-file-writable file)
82 "Make FILE writable for its owner.."
83 (let ((stat (lstat file))) ;XXX: symlinks
84 (chmod file (logior #o600 (stat:perms stat)))))
86 (define* (copy-account-skeletons home
87 #:optional (directory %skeleton-directory))
88 "Copy the account skeletons from DIRECTORY to HOME."
89 (let ((files (scandir directory (negate dot-or-dot-dot?)
92 (for-each (lambda (file)
93 (let ((target (string-append home "/" file)))
94 (copy-recursively (string-append directory "/" file)
96 #:log (%make-void-port "w"))
97 (make-file-writable target)))
100 (define* (make-skeletons-writable home
101 #:optional (directory %skeleton-directory))
102 "Make sure that the files that have been copied from DIRECTORY to HOME are
103 owner-writable in HOME."
104 (let ((files (scandir directory (negate dot-or-dot-dot?)
106 (for-each (lambda (file)
107 (let ((target (string-append home "/" file)))
108 (when (file-exists? target)
109 (make-file-writable target))))
112 (define* (add-user name group
113 #:key uid comment home shell password system?
114 (supplementary-groups '())
115 (log-port (current-error-port)))
116 "Create an account for user NAME part of GROUP, with the specified
117 properties. Return #t on success."
118 (format log-port "adding user '~a'...~%" name)
120 (if (and uid (zero? uid))
122 ;; 'useradd' fails with "Cannot determine your user name" if the root
123 ;; account doesn't exist. Thus, for bootstrapping purposes, create that
126 (call-with-output-file "/etc/shadow"
127 (cut format <> "~a::::::::~%" name))
128 (call-with-output-file "/etc/passwd"
129 (cut format <> "~a:x:~a:~a:~a:~a:~a~%"
130 name "0" "0" comment home shell))
131 (chmod "/etc/shadow" #o600)
132 (copy-account-skeletons (or home "/root"))
135 ;; Use 'useradd' from the Shadow package.
136 (let ((args `(,@(if uid `("-u" ,(number->string uid)) '())
137 "-g" ,(if (number? group) (number->string group) group)
138 ,@(if (pair? supplementary-groups)
139 `("-G" ,(string-join supplementary-groups ","))
141 ,@(if comment `("-c" ,comment) '())
143 (if (file-exists? home)
144 `("-d" ,home) ; avoid warning from 'useradd'
145 `("-d" ,home "--create-home"))
147 ,@(if shell `("-s" ,shell) '())
148 ,@(if password `("-p" ,password) '())
149 ,@(if system? '("--system") '())
151 (and (zero? (apply system* "useradd" args))
153 ;; Since /etc/skel is a link to a directory in the store where
154 ;; all files have the writable bit cleared, and since 'useradd'
155 ;; preserves permissions when it copies them, explicitly make
157 (make-skeletons-writable home)
160 (define* (modify-user name group
161 #:key uid comment home shell password system?
162 (supplementary-groups '())
163 (log-port (current-error-port)))
164 "Modify user account NAME to have all the given settings."
165 ;; Use 'usermod' from the Shadow package.
166 (let ((args `(,@(if uid `("-u" ,(number->string uid)) '())
167 "-g" ,(if (number? group) (number->string group) group)
168 ,@(if (pair? supplementary-groups)
169 `("-G" ,(string-join supplementary-groups ","))
171 ,@(if comment `("-c" ,comment) '())
172 ;; Don't use '--move-home', so ignore HOME.
173 ,@(if shell `("-s" ,shell) '())
175 (zero? (apply system* "usermod" args))))
177 (define* (delete-user name #:key (log-port (current-error-port)))
178 "Remove user account NAME. Return #t on success. This may fail if NAME is
180 (format log-port "deleting user '~a'...~%" name)
181 (zero? (system* "userdel" name)))
183 (define* (delete-group name #:key (log-port (current-error-port)))
184 "Remove group NAME. Return #t on success."
185 (format log-port "deleting group '~a'...~%" name)
186 (zero? (system* "groupdel" name)))
188 (define* (ensure-user name group
189 #:key uid comment home shell password system?
190 (supplementary-groups '())
191 (log-port (current-error-port))
193 "Make sure user NAME exists and has the relevant settings."
194 (if (false-if-exception (getpwnam name))
195 (apply modify-user name group rest)
196 (apply add-user name group rest)))
198 (define (activate-users+groups users groups)
199 "Make sure the accounts listed in USERS and the user groups listed in GROUPS
202 Each item in USERS is a list of all the characteristics of a user account;
203 each item in GROUPS is a tuple with the group name, group password or #f, and
206 (close-port (open-file file "a0b")))
208 (define activate-user
210 ((name uid group supplementary-groups comment home shell password system?)
211 (let ((profile-dir (string-append "/var/guix/profiles/per-user/"
213 (ensure-user name group
216 #:supplementary-groups supplementary-groups
223 ;; Create the profile directory for the new account.
224 (let ((pw (getpwnam name)))
225 (mkdir-p profile-dir)
226 (chown profile-dir (passwd:uid pw) (passwd:gid pw))))))))
228 ;; 'groupadd' aborts if the file doesn't already exist.
231 ;; Create the root account so we can use 'useradd' and 'groupadd'.
232 (activate-user (find (match-lambda
233 ((name (? zero?) _ ...) #t)
237 ;; Then create the groups.
238 (for-each (match-lambda
239 ((name password gid system?)
240 (unless (false-if-exception (getgrnam name))
242 #:gid gid #:password password
243 #:system? system?))))
246 ;; Create the other user accounts.
247 (for-each activate-user users)
249 ;; Finally, delete extra user accounts and groups.
250 (for-each delete-user
251 (lset-difference string=?
252 (map passwd:name (current-users))
256 (for-each delete-group
257 (lset-difference string=?
258 (map group:name (current-groups))
263 (define (activate-etc etc)
264 "Install ETC, a directory in the store, as the source of static files for
267 ;; /etc is a mixture of static and dynamic settings. Here is where we
268 ;; initialize it from the static part.
271 (false-if-exception (delete-file file)))
273 (format #t "populating /etc from ~a...~%" etc)
275 ;; Create the /etc/ssl -> /run/current-system/profile/etc/ssl symlink. This
276 ;; symlink, to a target outside of the store, probably doesn't belong in the
277 ;; static 'etc' store directory. However, if it were to be put there,
278 ;; beware that if /run/current-system/profile/etc/ssl doesn't exist at the
279 ;; time of activation (e.g. when installing a fresh system), the call to
280 ;; 'file-is-directory?' below will fail because it uses 'stat', not 'lstat'.
282 (symlink "/run/current-system/profile/etc/ssl" "/etc/ssl")
285 (symlink etc "/etc/static")
286 (for-each (lambda (file)
287 (let ((target (string-append "/etc/" file))
288 (source (string-append "/etc/static/" file)))
291 ;; Things such as /etc/sudoers must be regular files, not
292 ;; symlinks; furthermore, they could be modified behind our
293 ;; back---e.g., with 'visudo'. Thus, make a copy instead of
295 (if (file-is-directory? source)
296 (symlink source target)
297 (copy-file source target))
299 ;; XXX: Dirty hack to meet sudo's expectations.
300 (when (string=? (basename target) "sudoers")
301 (chmod target #o440))))
302 (scandir etc (negate dot-or-dot-dot?)
304 ;; The default is 'string-locale<?', but we don't have
305 ;; it when run from the initrd's statically-linked
309 (define %setuid-directory
310 ;; Place where setuid programs are stored.
311 "/run/setuid-programs")
313 (define (link-or-copy source target)
314 "Attempt to make TARGET a hard link to SOURCE; if it fails, fall back to
315 copy SOURCE to TARGET."
318 (link source target))
320 ;; Perhaps SOURCE and TARGET live in a different file system, so copy
322 (copy-file source target))))
324 (define (activate-setuid-programs programs)
325 "Turn PROGRAMS, a list of file names, into setuid programs stored under
327 (define (make-setuid-program prog)
328 (let ((target (string-append %setuid-directory
329 "/" (basename prog))))
330 (link-or-copy prog target)
332 (chmod target #o6555)))
334 (format #t "setting up setuid programs in '~a'...~%"
336 (if (file-exists? %setuid-directory)
337 (for-each (compose delete-file
338 (cut string-append %setuid-directory "/" <>))
339 (scandir %setuid-directory
341 (not (member file '("." ".."))))
343 (mkdir-p %setuid-directory))
345 (for-each make-setuid-program programs))
347 (define (activate-/bin/sh shell)
348 "Change /bin/sh to point to SHELL."
349 (symlink shell "/bin/sh.new")
350 (rename-file "/bin/sh.new" "/bin/sh"))
352 (define (activate-modprobe modprobe)
353 "Tell the kernel to use MODPROBE to load modules."
354 (call-with-output-file "/proc/sys/kernel/modprobe"
356 (display modprobe port))))
358 (define (activate-firmware directory)
359 "Tell the kernel to look for device firmware under DIRECTORY. This
360 mechanism bypasses udev: it allows Linux to handle firmware loading directly
361 by itself, without having to resort to a \"user helper\"."
362 (call-with-output-file "/sys/module/firmware_class/parameters/path"
364 (display directory port))))
366 (define (activate-ptrace-attach)
367 "Allow users to PTRACE_ATTACH their own processes.
369 This works around a regression introduced in the default \"security\" policy
370 found in Linux 3.4 onward that prevents users from attaching to their own
371 processes--see Yama.txt in the Linux source tree for the rationale. This
372 sounds like an unacceptable restriction for little or no security
374 (let ((file "/proc/sys/kernel/yama/ptrace_scope"))
375 (when (file-exists? file)
376 (call-with-output-file file
378 (display 0 port))))))
381 (define %current-system
382 ;; The system that is current (a symlink.) This is not necessarily the same
383 ;; as the system we booted (aka. /run/booted-system) because we can re-build
384 ;; a new system configuration and activate it, without rebooting.
385 "/run/current-system")
387 (define (boot-time-system)
388 "Return the '--system' argument passed on the kernel command line."
389 (find-long-option "--system" (linux-command-line)))
391 (define* (activate-current-system
392 #:optional (system (or (getenv "GUIX_NEW_SYSTEM")
393 (boot-time-system))))
394 "Atomically make SYSTEM the current system."
395 ;; The 'GUIX_NEW_SYSTEM' environment variable is used as a way for 'guix
396 ;; system reconfigure' to pass the file name of the new system.
398 (format #t "making '~a' the current system...~%" system)
400 ;; Atomically make SYSTEM current.
401 (let ((new (string-append %current-system ".new")))
403 (rename-file new %current-system)))
405 ;;; activation.scm ends here