-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (gnu build activation)
- #:use-module (gnu build linux-boot)
- #:use-module (guix build utils)
- #:use-module (ice-9 ftw)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
- #:export (activate-users+groups
- activate-etc
- activate-setuid-programs
- activate-current-system))
-
-;;; Commentary:
-;;;
-;;; This module provides "activation" helpers. Activation is the process that
-;;; consists in setting up system-wide files and directories so that an
-;;; 'operating-system' configuration becomes active.
-;;;
-;;; Code:
-
-(define* (add-group name #:key gid password system?
- (log-port (current-error-port)))
- "Add NAME as a user group, with the given numeric GID if specified."
- ;; Use 'groupadd' from the Shadow package.
- (format log-port "adding group '~a'...~%" name)
- (let ((args `(,@(if gid `("-g" ,(number->string gid)) '())
- ,@(if password `("-p" ,password) '())
- ,@(if system? `("--system") '())
- ,name)))
- (zero? (apply system* "groupadd" args))))
-
-(define* (add-user name group
- #:key uid comment home shell password system?
- (supplementary-groups '())
- (log-port (current-error-port)))
- "Create an account for user NAME part of GROUP, with the specified
-properties. Return #t on success."
- (format log-port "adding user '~a'...~%" name)
-
- (if (and uid (zero? uid))
-
- ;; 'useradd' fails with "Cannot determine your user name" if the root
- ;; account doesn't exist. Thus, for bootstrapping purposes, create that
- ;; one manually.
- (begin
- (call-with-output-file "/etc/shadow"
- (cut format <> "~a::::::::~%" name))
- (call-with-output-file "/etc/passwd"
- (cut format <> "~a:x:~a:~a:~a:~a:~a~%"
- name "0" "0" comment home shell))
- (chmod "/etc/shadow" #o600)
- #t)
-
- ;; Use 'useradd' from the Shadow package.
- (let ((args `(,@(if uid `("-u" ,(number->string uid)) '())
- "-g" ,(if (number? group) (number->string group) group)
- ,@(if (pair? supplementary-groups)
- `("-G" ,(string-join supplementary-groups ","))
- '())
- ,@(if comment `("-c" ,comment) '())
- ,@(if home
- (if (file-exists? home)
- `("-d" ,home) ; avoid warning from 'useradd'
- `("-d" ,home "--create-home"))
- '())
- ,@(if shell `("-s" ,shell) '())
- ,@(if password `("-p" ,password) '())
- ,@(if system? '("--system") '())
- ,name)))
- (zero? (apply system* "useradd" args)))))
-
-(define (activate-users+groups users groups)
- "Make sure the accounts listed in USERS and the user groups listed in GROUPS
-are all available.
-
-Each item in USERS is a list of all the characteristics of a user account;
-each item in GROUPS is a tuple with the group name, group password or #f, and
-numeric gid or #f."
- (define (touch file)
- (close-port (open-file file "a0b")))
-
- (define activate-user
- (match-lambda
- ((name uid group supplementary-groups comment home shell password system?)
- (unless (false-if-exception (getpwnam name))
- (let ((profile-dir (string-append "/var/guix/profiles/per-user/"
- name)))
- (add-user name group
- #:uid uid
- #:system? system?
- #:supplementary-groups supplementary-groups
- #:comment comment
- #:home home
- #:shell shell
- #:password password)
-
- (unless system?
- ;; Create the profile directory for the new account.
- (let ((pw (getpwnam name)))
- (mkdir-p profile-dir)
- (chown profile-dir (passwd:uid pw) (passwd:gid pw)))))))))
-
- ;; 'groupadd' aborts if the file doesn't already exist.
- (touch "/etc/group")
-
- ;; Create the root account so we can use 'useradd' and 'groupadd'.
- (activate-user (find (match-lambda
- ((name (? zero?) _ ...) #t)
- (_ #f))
- users))
-
- ;; Then create the groups.
- (for-each (match-lambda
- ((name password gid system?)
- (unless (false-if-exception (getgrnam name))
- (add-group name
- #:gid gid #:password password
- #:system? system?))))
- groups)
-
- ;; Finally create the other user accounts.
- (for-each activate-user users))
-
-(define (activate-etc etc)
- "Install ETC, a directory in the store, as the source of static files for
-/etc."
-
- ;; /etc is a mixture of static and dynamic settings. Here is where we
- ;; initialize it from the static part.
-
- (format #t "populating /etc from ~a...~%" etc)
- (let ((rm-f (lambda (f)
- (false-if-exception (delete-file f)))))
- (rm-f "/etc/static")
- (symlink etc "/etc/static")
- (for-each (lambda (file)
- ;; TODO: Handle 'shadow' specially so that changed
- ;; password aren't lost.
- (let ((target (string-append "/etc/" file))
- (source (string-append "/etc/static/" file)))
- (rm-f target)
- (symlink source target)))
- (scandir etc
- (lambda (file)
- (not (member file '("." ".."))))
-
- ;; The default is 'string-locale<?', but we don't have
- ;; it when run from the initrd's statically-linked
- ;; Guile.
- string<?))
-
- ;; Prevent ETC from being GC'd.
- (rm-f "/var/guix/gcroots/etc-directory")
- (symlink etc "/var/guix/gcroots/etc-directory")))
-
-(define %setuid-directory
- ;; Place where setuid programs are stored.
- "/run/setuid-programs")
-
-(define (link-or-copy source target)
- "Attempt to make TARGET a hard link to SOURCE; if it fails, fall back to
-copy SOURCE to TARGET."
- (catch 'system-error
- (lambda ()
- (link source target))
- (lambda args
- ;; Perhaps SOURCE and TARGET live in a different file system, so copy
- ;; SOURCE.
- (copy-file source target))))
-
-(define (activate-setuid-programs programs)
- "Turn PROGRAMS, a list of file names, into setuid programs stored under
-%SETUID-DIRECTORY."
- (define (make-setuid-program prog)
- (let ((target (string-append %setuid-directory
- "/" (basename prog))))
- (link-or-copy prog target)
- (chown target 0 0)
- (chmod target #o6555)))
-
- (format #t "setting up setuid programs in '~a'...~%"
- %setuid-directory)
- (if (file-exists? %setuid-directory)
- (for-each (compose delete-file
- (cut string-append %setuid-directory "/" <>))
- (scandir %setuid-directory
- (lambda (file)
- (not (member file '("." ".."))))
- string<?))
- (mkdir-p %setuid-directory))
-
- (for-each make-setuid-program programs))
-
-(define %current-system
- ;; The system that is current (a symlink.) This is not necessarily the same
- ;; as the system we booted (aka. /run/booted-system) because we can re-build
- ;; a new system configuration and activate it, without rebooting.
- "/run/current-system")
-
-(define (boot-time-system)
- "Return the '--system' argument passed on the kernel command line."
- (find-long-option "--system" (linux-command-line)))
-
-(define* (activate-current-system #:optional (system (boot-time-system)))
- "Atomically make SYSTEM the current system."
- (format #t "making '~a' the current system...~%" system)
-
- ;; Atomically make SYSTEM current.
- (let ((new (string-append %current-system ".new")))
- (symlink system new)
- (rename-file new %current-system)))
-
-;;; activation.scm ends here
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu build activation)
+ #:use-module (gnu system accounts)
+ #:use-module (gnu build accounts)
+ #:use-module (gnu build linux-boot)
+ #:use-module (guix build utils)
+ #:use-module ((guix build syscalls) #:select (with-file-lock))
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:export (activate-users+groups
+ activate-user-home
+ activate-etc
+ activate-setuid-programs
+ activate-special-files
+ activate-modprobe
+ activate-firmware
+ activate-ptrace-attach
+ activate-current-system))
+
+;;; Commentary:
+;;;
+;;; This module provides "activation" helpers. Activation is the process that
+;;; consists in setting up system-wide files and directories so that an
+;;; 'operating-system' configuration becomes active.
+;;;
+;;; Code:
+
+(define %skeleton-directory
+ ;; Directory containing skeleton files for new accounts.
+ ;; Note: keep the trailing '/' so that 'scandir' enters it.
+ "/etc/skel/")
+
+(define (dot-or-dot-dot? file)
+ (member file '("." "..")))
+
+(define* (copy-account-skeletons home
+ #:key
+ (directory %skeleton-directory)
+ uid gid)
+ "Copy the account skeletons from DIRECTORY to HOME. When UID is an integer,
+make it the owner of all the files created; likewise for GID."
+ (define (set-owner file)
+ (when (or uid gid)
+ (chown file (or uid -1) (or gid -1))))
+
+ (let ((files (scandir directory (negate dot-or-dot-dot?)
+ string<?)))
+ (mkdir-p home)
+ (set-owner home)
+ (for-each (lambda (file)
+ (let ((target (string-append home "/" file)))
+ (copy-recursively (string-append directory "/" file)
+ target
+ #:log (%make-void-port "w"))
+ (for-each set-owner
+ (find-files target (const #t)
+ #:directories? #t))
+ (make-file-writable target)))
+ files)))
+
+(define* (make-skeletons-writable home
+ #:optional (directory %skeleton-directory))
+ "Make sure that the files that have been copied from DIRECTORY to HOME are
+owner-writable in HOME."
+ (let ((files (scandir directory (negate dot-or-dot-dot?)
+ string<?)))
+ (for-each (lambda (file)
+ (let ((target (string-append home "/" file)))
+ (when (file-exists? target)
+ (make-file-writable target))))
+ files)))
+
+(define (duplicates lst)
+ "Return elements from LST present more than once in LST."
+ (let loop ((lst lst)
+ (seen vlist-null)
+ (result '()))
+ (match lst
+ (()
+ (reverse result))
+ ((head . tail)
+ (loop tail
+ (vhash-cons head #t seen)
+ (if (vhash-assoc head seen)
+ (cons head result)
+ result))))))
+
+(define (activate-users+groups users groups)
+ "Make sure USERS (a list of user account records) and GROUPS (a list of user
+group records) are all available."
+ (define (make-home-directory user)
+ (let ((home (user-account-home-directory user))
+ (pwd (getpwnam (user-account-name user))))
+ (mkdir-p home)
+
+ ;; Always set ownership and permissions for home directories of system
+ ;; accounts. If a service needs looser permissions on its home
+ ;; directories, it can always chmod it in an activation snippet.
+ (chown home (passwd:uid pwd) (passwd:gid pwd))
+ (chmod home #o700)))
+
+ (define system-accounts
+ (filter (lambda (user)
+ (and (user-account-system? user)
+ (user-account-create-home-directory? user)))
+ users))
+
+ ;; Allow home directories to be created under /var/lib.
+ (mkdir-p "/var/lib")
+
+ ;; Take same lock as libc's 'lckpwdf' (but without a timeout) while we read
+ ;; and write the databases. This ensures there's no race condition with
+ ;; other tools that might be accessing it at the same time.
+ (with-file-lock %password-lock-file
+ (let-values (((groups passwd shadow)
+ (user+group-databases users groups)))
+ (write-group groups)
+ (write-passwd passwd)
+ (write-shadow shadow)))
+
+ ;; Home directories of non-system accounts are created by
+ ;; 'activate-user-home'.
+ (for-each make-home-directory system-accounts)
+
+ ;; Turn shared home directories, such as /var/empty, into root-owned,
+ ;; read-only places.
+ (for-each (lambda (directory)
+ (chown directory 0 0)
+ (chmod directory #o555))
+ (duplicates (map user-account-home-directory system-accounts))))
+
+(define (activate-user-home users)
+ "Create and populate the home directory of USERS, a list of tuples, unless
+they already exist."
+ (define ensure-user-home
+ (lambda (user)
+ (let ((name (user-account-name user))
+ (home (user-account-home-directory user))
+ (create-home? (user-account-create-home-directory? user))
+ (system? (user-account-system? user)))
+ ;; The home directories of system accounts are created during
+ ;; activation, not here.
+ (unless (or (not home) (not create-home?) system?
+ (directory-exists? home))
+ (let* ((pw (getpwnam name))
+ (uid (passwd:uid pw))
+ (gid (passwd:gid pw)))
+ (mkdir-p home)
+ (chown home uid gid)
+ (chmod home #o700)
+ (copy-account-skeletons home
+ #:uid uid #:gid gid))))))
+
+ (for-each ensure-user-home users))
+
+(define (activate-etc etc)
+ "Install ETC, a directory in the store, as the source of static files for
+/etc."
+
+ ;; /etc is a mixture of static and dynamic settings. Here is where we
+ ;; initialize it from the static part.
+
+ (define (rm-f file)
+ (false-if-exception (delete-file file)))
+
+ (format #t "populating /etc from ~a...~%" etc)
+ (mkdir-p "/etc")
+
+ ;; Create the /etc/ssl -> /run/current-system/profile/etc/ssl symlink. This
+ ;; symlink, to a target outside of the store, probably doesn't belong in the
+ ;; static 'etc' store directory. However, if it were to be put there,
+ ;; beware that if /run/current-system/profile/etc/ssl doesn't exist at the
+ ;; time of activation (e.g. when installing a fresh system), the call to
+ ;; 'file-is-directory?' below will fail because it uses 'stat', not 'lstat'.
+ (rm-f "/etc/ssl")
+ (symlink "/run/current-system/profile/etc/ssl" "/etc/ssl")
+
+ (rm-f "/etc/static")
+ (symlink etc "/etc/static")
+ (for-each (lambda (file)
+ (let ((target (string-append "/etc/" file))
+ (source (string-append "/etc/static/" file)))
+ (rm-f target)
+
+ ;; Things such as /etc/sudoers must be regular files, not
+ ;; symlinks; furthermore, they could be modified behind our
+ ;; back---e.g., with 'visudo'. Thus, make a copy instead of
+ ;; symlinking them.
+ (if (file-is-directory? source)
+ (symlink source target)
+ (copy-file source target))
+
+ ;; XXX: Dirty hack to meet sudo's expectations.
+ (when (string=? (basename target) "sudoers")
+ (chmod target #o440))))
+ (scandir etc (negate dot-or-dot-dot?)
+
+ ;; The default is 'string-locale<?', but we don't have
+ ;; it when run from the initrd's statically-linked
+ ;; Guile.
+ string<?)))
+
+(define %setuid-directory
+ ;; Place where setuid programs are stored.
+ "/run/setuid-programs")
+
+(define (activate-setuid-programs programs)
+ "Turn PROGRAMS, a list of file names, into setuid programs stored under
+%SETUID-DIRECTORY."
+ (define (make-setuid-program prog)
+ (let ((target (string-append %setuid-directory
+ "/" (basename prog))))
+ (copy-file prog target)
+ (chown target 0 0)
+ (chmod target #o6555)))
+
+ (format #t "setting up setuid programs in '~a'...~%"
+ %setuid-directory)
+ (if (file-exists? %setuid-directory)
+ (for-each (compose delete-file
+ (cut string-append %setuid-directory "/" <>))
+ (scandir %setuid-directory
+ (lambda (file)
+ (not (member file '("." ".."))))
+ string<?))
+ (mkdir-p %setuid-directory))
+
+ (for-each (lambda (program)
+ (catch 'system-error
+ (lambda ()
+ (make-setuid-program program))
+ (lambda args
+ ;; If we fail to create a setuid program, better keep going
+ ;; so that we don't leave %SETUID-DIRECTORY empty or
+ ;; half-populated. This can happen if PROGRAMS contains
+ ;; incorrect file names: <https://bugs.gnu.org/38800>.
+ (format (current-error-port)
+ "warning: failed to make '~a' setuid-root: ~a~%"
+ program (strerror (system-error-errno args))))))
+ programs))
+
+(define (activate-special-files special-files)
+ "Install the files listed in SPECIAL-FILES. Each element of SPECIAL-FILES
+is a pair where the first element is the name of the special file and the
+second element is the name it should appear at, such as:
+
+ ((\"/bin/sh\" \"/gnu/store/…-bash/bin/sh\")
+ (\"/usr/bin/env\" \"/gnu/store/…-coreutils/bin/env\"))
+"
+ (define install-special-file
+ (match-lambda
+ ((target file)
+ (let ((pivot (string-append target ".new")))
+ (mkdir-p (dirname target))
+ (symlink file pivot)
+ (rename-file pivot target)))))
+
+ (for-each install-special-file special-files))
+
+(define (activate-modprobe modprobe)
+ "Tell the kernel to use MODPROBE to load modules."
+
+ ;; If the kernel was built without loadable module support, this file is
+ ;; unavailable, so check for its existence first.
+ (when (file-exists? "/proc/sys/kernel/modprobe")
+ (call-with-output-file "/proc/sys/kernel/modprobe"
+ (lambda (port)
+ (display modprobe port)))))
+
+(define (activate-firmware directory)
+ "Tell the kernel to look for device firmware under DIRECTORY. This
+mechanism bypasses udev: it allows Linux to handle firmware loading directly
+by itself, without having to resort to a \"user helper\"."
+ (call-with-output-file "/sys/module/firmware_class/parameters/path"
+ (lambda (port)
+ (display directory port))))
+
+(define (activate-ptrace-attach)
+ "Allow users to PTRACE_ATTACH their own processes.
+
+This works around a regression introduced in the default \"security\" policy
+found in Linux 3.4 onward that prevents users from attaching to their own
+processes--see Yama.txt in the Linux source tree for the rationale. This
+sounds like an unacceptable restriction for little or no security
+improvement."
+ (let ((file "/proc/sys/kernel/yama/ptrace_scope"))
+ (when (file-exists? file)
+ (call-with-output-file file
+ (lambda (port)
+ (display 0 port))))))
+
+\f
+(define %current-system
+ ;; The system that is current (a symlink.) This is not necessarily the same
+ ;; as the system we booted (aka. /run/booted-system) because we can re-build
+ ;; a new system configuration and activate it, without rebooting.
+ "/run/current-system")
+
+(define (boot-time-system)
+ "Return the '--system' argument passed on the kernel command line."
+ (find-long-option "--system" (if (string-contains %host-type "linux-gnu")
+ (linux-command-line)
+ (command-line))))
+
+(define* (activate-current-system
+ #:optional (system (or (getenv "GUIX_NEW_SYSTEM")
+ (boot-time-system))))
+ "Atomically make SYSTEM the current system."
+ ;; The 'GUIX_NEW_SYSTEM' environment variable is used as a way for 'guix
+ ;; system reconfigure' to pass the file name of the new system.
+
+ (format #t "making '~a' the current system...~%" system)
+
+ ;; Atomically make SYSTEM current.
+ (let ((new (string-append %current-system ".new")))
+ (symlink system new)
+ (rename-file new %current-system)))
+
+;;; activation.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff