system: Create home directories once 'file-systems' is up.
Fixes <http://bugs.gnu.org/21108>. Reported by Andy Patterson <ajpatter@uwaterloo.ca> and Leo Famulari <leo@famulari.name>. * gnu/build/activation.scm (activate-users+groups)[activate-user]: Pass #:create-home? #t iff CREATE-HOME? and SYSTEM?. (activate-user-home): New procedure. * gnu/system/shadow.scm (account-shepherd-service): New procedure. (account-service-type)[extensions]: Add SHEPHERD-ROOT-SERVICE-TYPE extension. * gnu/tests/base.scm (run-basic-test)["home"] ["skeletons in home directories"]: New tests. * gnu/tests/install.scm (%separate-home-os, %separate-home-os-source) (%test-separate-home-os): New variables.
This commit is contained in:
Ludovic Courtès
parent
524ee6c9e5
commit
ae763b5b0b
4 changed files with 147 additions and 3 deletions
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
@ -232,6 +232,64 @@ build (current-guix) and then store a couple of full system images.")
|
|||
(run-basic-test %minimal-os command
|
||||
"installed-os")))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; 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.
|
||||
|
|
|
|||
Reference in a new issue