diff options
| -rw-r--r-- | gnu/build/activation.scm | 19 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 34 | ||||
| -rw-r--r-- | gnu/tests/base.scm | 37 | ||||
| -rw-r--r-- | gnu/tests/install.scm | 60 |
4 files changed, 147 insertions, 3 deletions
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm index 1b31dc1538..cff176e82a 100644 --- a/gnu/build/activation.scm +++ b/gnu/build/activation.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; 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. @@ -25,6 +25,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (activate-users+groups + activate-user-home activate-etc activate-setuid-programs activate-/bin/sh @@ -220,7 +221,7 @@ numeric gid or #f." #:supplementary-groups supplementary-groups #:comment comment #:home home - #:create-home? create-home? + #:create-home? (and create-home? system?) #:shell shell #:password password) @@ -268,6 +269,20 @@ numeric gid or #f." (((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?) + (unless (or (not home) (directory-exists? home)) + (mkdir-p home) + (unless system? + (copy-account-skeletons home)))))) + + (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." diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index cfdcf5e136..ee9d55c157 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -21,9 +21,11 @@ #:use-module (guix records) #:use-module (guix gexp) #:use-module (guix store) + #:use-module (guix modules) #:use-module (guix sets) #:use-module (guix ui) #:use-module (gnu services) + #:use-module (gnu services shepherd) #:use-module ((gnu system file-systems) #:select (%tty-gid)) #:use-module ((gnu packages admin) @@ -43,6 +45,7 @@ user-account-supplementary-groups user-account-comment user-account-home-directory + user-account-create-home-directory? user-account-shell user-account-system? @@ -288,6 +291,35 @@ group." (activate-users+groups (list #$@user-specs) (list #$@group-specs)))) +(define (account-shepherd-service accounts+groups) + "Return a Shepherd service that creates the home directories for the user +accounts among ACCOUNTS+GROUPS." + (define accounts + (filter user-account? accounts+groups)) + + ;; Create home directories only once 'file-systems' is up. This makes sure + ;; they are created in the right place if /home lives on a separate + ;; partition. + ;; + ;; XXX: We arrange for this service to stop right after it's done its job so + ;; that 'guix system reconfigure' knows that it can reload it fearlessly + ;; (and thus create new home directories). The cost of this hack is that + ;; there's a small window during which first-time logins could happen before + ;; the home directory has been created. + (list (shepherd-service + (requirement '(file-systems)) + (provision '(user-homes)) + (modules '((gnu build activation))) + (start (with-imported-modules (source-module-closure + '((gnu build activation))) + #~(lambda () + (activate-user-home + (list #$@(map user-account->gexp accounts))) + #f))) ;stop + (stop #~(const #f)) + (respawn? #f) + (documentation "Create user home directories.")))) + (define (shells-file shells) "Return a file-like object that builds a shell list for use as /etc/shells based on SHELLS. /etc/shells is used by xterm, polkit, and other programs." @@ -327,6 +359,8 @@ the /etc/skel directory for those." (extensions (list (service-extension activation-service-type account-activation) + (service-extension shepherd-root-service-type + account-shepherd-service) (service-extension etc-service-type etc-files))))) diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index a725ca90f3..756d3df800 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -146,6 +146,43 @@ info --version") (pk 'services services) '(root #$@(operating-system-shepherd-service-names os))))) + (test-assert "homes" + (let ((homes + '#$(map user-account-home-directory + (filter user-account-create-home-directory? + (operating-system-user-accounts os))))) + (marionette-eval + `(begin + (use-modules (gnu services herd) (srfi srfi-1)) + + ;; Home directories are supposed to exist once 'user-homes' + ;; has been started. + (start-service 'user-homes) + + (every (lambda (home) + (and (file-exists? home) + (file-is-directory? home))) + ',homes)) + marionette))) + + (test-assert "skeletons in home directories" + (let ((homes + '#$(filter-map (lambda (account) + (and (user-account-create-home-directory? + account) + (not (user-account-system? account)) + (user-account-home-directory account))) + (operating-system-user-accounts os)))) + (marionette-eval + `(begin + (use-modules (srfi srfi-1) (ice-9 ftw)) + (every (lambda (home) + (null? (lset-difference string=? + (scandir "/etc/skel/") + (scandir home)))) + ',homes)) + marionette))) + (test-equal "login on tty1" "root\n" (begin diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 4e8d594054..b104efcfd5 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -35,6 +35,7 @@ #:use-module (guix utils) #:export (%test-installed-os %test-separate-store-os + %test-separate-home-os %test-raid-root-os %test-encrypted-os %test-btrfs-root-os)) @@ -218,7 +219,6 @@ IMAGE, a disk image. The QEMU VM is has access to MEMORY-SIZE MiB of RAM." "-no-reboot" "-m" #$(number->string memory-size) "-drive" "file=disk.img,if=virtio"))))) - (define %test-installed-os (system-test (name "installed-os") @@ -234,6 +234,64 @@ build (current-guix) and then store a couple of full system images.") ;;; +;;; Separate /home. +;;; + +(define-os-with-source (%separate-home-os %separate-home-os-source) + ;; The OS we want to install. + (use-modules (gnu) (gnu tests) (srfi srfi-1)) + + (operating-system + (host-name "liberigilo") + (timezone "Europe/Paris") + (locale "en_US.utf8") + + (bootloader (grub-configuration (device "/dev/vdb"))) + (kernel-arguments '("console=ttyS0")) + (file-systems (cons* (file-system + (device "my-root") + (title 'label) + (mount-point "/") + (type "ext4")) + (file-system + (device "none") + (title 'device) + (type "tmpfs") + (mount-point "/home") + (type "tmpfs")) + %base-file-systems)) + (users (cons* (user-account + (name "alice") + (group "users") + (home-directory "/home/alice")) + (user-account + (name "charlie") + (group "users") + (home-directory "/home/charlie")) + %base-user-accounts)) + (services (cons (service marionette-service-type + (marionette-configuration + (imported-modules '((gnu services herd) + (guix combinators))))) + %base-services)))) + +(define %test-separate-home-os + (system-test + (name "separate-home-os") + (description + "Test basic functionality of an installed OS with a separate /home +partition. In particular, home directories must be correctly created (see +<https://bugs.gnu.org/21108>).") + (value + (mlet* %store-monad ((image (run-install %separate-home-os + %separate-home-os-source + #:script + %simple-installation-script)) + (command (qemu-command/writable-image image))) + (run-basic-test %separate-home-os command "separate-home-os"))))) + + +;;; ;;; Separate /gnu/store partition. ;;; |