me
/
guix
Archived
1
0
Fork 0
This repository has been archived on 2024-08-07. You can view files and clone it, but cannot push or open issues/pull-requests.
guix/gnu/build/activation.scm

461 lines
18 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters!

This file contains invisible Unicode characters that may be processed differently from what appears below. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to reveal hidden characters.

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017 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 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-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 (enumerate thunk)
"Return the list of values returned by THUNK until it returned #f."
(let loop ((entry (thunk))
(result '()))
(if (not entry)
(reverse result)
(loop (thunk) (cons entry result)))))
(define (current-users)
"Return the passwd entries for all the currently defined user accounts."
(setpw)
(enumerate getpwent))
(define (current-groups)
"Return the group entries for all the currently defined user groups."
(setgr)
(enumerate getgrent))
(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 %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* (add-user name group
#:key uid comment home create-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.
(let ((home (or home "/root")))
(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)
(copy-account-skeletons home)
(chmod home #o700)
#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 (and home create-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)))
(and (zero? (apply system* "useradd" args))
(begin
;; Since /etc/skel is a link to a directory in the store where
;; all files have the writable bit cleared, and since 'useradd'
;; preserves permissions when it copies them, explicitly make
;; them writable.
(make-skeletons-writable home)
#t)))))
(define* (modify-user name group
#:key uid comment home create-home?
shell password system?
(supplementary-groups '())
(log-port (current-error-port)))
"Modify user account NAME to have all the given settings."
;; Use 'usermod' 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) '())
;; Don't use '--move-home', so ignore HOME.
,@(if shell `("-s" ,shell) '())
,name)))
(zero? (apply system* "usermod" args))))
(define* (delete-user name #:key (log-port (current-error-port)))
"Remove user account NAME. Return #t on success. This may fail if NAME is
logged in."
(format log-port "deleting user '~a'...~%" name)
(zero? (system* "userdel" name)))
(define* (delete-group name #:key (log-port (current-error-port)))
"Remove group NAME. Return #t on success."
(format log-port "deleting group '~a'...~%" name)
(zero? (system* "groupdel" name)))
(define* (ensure-user name group
#:key uid comment home create-home?
shell password system?
(supplementary-groups '())
(log-port (current-error-port))
#:rest rest)
"Make sure user NAME exists and has the relevant settings."
(if (false-if-exception (getpwnam name))
(apply modify-user name group rest)
(apply add-user name group rest)))
(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 create-home?
shell password system?)
(let ((profile-dir (string-append "/var/guix/profiles/per-user/"
name)))
(ensure-user name group
#:uid uid
#:system? system?
#:supplementary-groups supplementary-groups
#:comment comment
#:home home
;; Home directories of non-system accounts are created by
;; 'activate-user-home'.
#:create-home? (and create-home? system?)
#: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")
;; Allow home directories to be created under /var/lib.
(mkdir-p "/var/lib")
;; 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)
;; Create the other user accounts.
(for-each activate-user users)
;; Finally, delete extra user accounts and groups.
(for-each delete-user
(lset-difference string=?
(map passwd:name (current-users))
(match users
(((names . _) ...)
names))))
(for-each delete-group
(lset-difference string=?
(map group:name (current-groups))
(match groups
(((names . _) ...)
names)))))
(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
(match-lambda
((name uid group supplementary-groups comment home create-home?
shell password system?)
;; 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)
(unless system?
(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)
;; 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 (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 (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."
(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))))))
(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 (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