Merge branch 'master' into staging

3 files changed, 632 insertions, 206 deletions

diff --git a/gnu/build/accounts.scm b/gnu/build/accounts.scm
new file mode 100644
index 0000000000..6b44ab610b
--- /dev/null
+++ b/gnu/build/accounts.scm
@@ -0,0 +1,561 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 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 accounts)
+  #:use-module (guix records)
+  #:use-module (guix combinators)
+  #:use-module (gnu system accounts)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 rdelim)
+  #:export (password-entry
+            password-entry?
+            password-entry-name
+            password-entry-uid
+            password-entry-gid
+            password-entry-real-name
+            password-entry-directory
+            password-entry-shell
+
+            shadow-entry
+            shadow-entry?
+            shadow-entry-name
+            shadow-entry-minimum-change-period
+            shadow-entry-maximum-change-period
+            shadow-entry-change-warning-time
+            shadow-entry-maximum-inactivity
+            shadow-entry-expiration
+
+            group-entry
+            group-entry?
+            group-entry-name
+            group-entry-gid
+            group-entry-members
+
+            write-group
+            write-passwd
+            write-shadow
+            read-group
+            read-passwd
+            read-shadow
+
+            %id-min
+            %id-max
+            %system-id-min
+            %system-id-max
+
+            user+group-databases))
+
+;;; Commentary:
+;;;
+;;; This modules provides functionality equivalent to the C library's
+;;; <shadow.h>, <pwd.h>, and <grp.h> routines, as well as a subset of the
+;;; functionality of the Shadow command-line tools.  It can parse and write
+;;; /etc/passwd, /etc/shadow, and /etc/group.  It can also take care of UID
+;;; and GID allocation in a way similar to what 'useradd' does.
+;;;
+;;; The benefit is twofold: less code is involved, and the ID allocation
+;;; strategy and state preservation is made explicit.
+;;;
+;;; Code:
+
+
+;;;
+;;; Machinery to define user and group databases.
+;;;
+
+(define-syntax serialize-field
+  (syntax-rules (serialization)
+    ((_ entry (field get (serialization ->string string->) _ ...))
+     (->string (get entry)))
+    ((_ entry (field get _ ...))
+     (get entry))))
+
+(define-syntax deserialize-field
+  (syntax-rules (serialization)
+    ((_ str (field get (serialization ->string string->) _ ...))
+     (string-> str))
+    ((_ str (field get _ ...))
+     str)))
+
+(define-syntax let/fields
+  (syntax-rules ()
+    ((_ (((name get attributes ...) rest ...) lst) body ...)
+     (let ((l lst))
+       (let ((name (deserialize-field (car l)
+                                      (name get attributes ...))))
+         (let/fields ((rest ...) (cdr l)) body ...))))
+    ((_ (() lst) body ...)
+     (begin body ...))))
+
+(define-syntax define-database-entry
+  (syntax-rules (serialization)
+    "Define a record data type, as per 'define-record-type*', with additional
+information on how to serialize and deserialize the whole database as well as
+each field."
+    ((_ <record> record make-record record?
+        (serialization separator entry->string string->entry)
+        fields ...)
+     (let-syntax ((field-name
+                   (syntax-rules ()
+                     ((_ (name _ (... ...))) name))))
+       (define-record-type* <record> record make-record
+         record?
+         fields ...)
+
+       (define (entry->string entry)
+         (string-join (list (serialize-field entry fields) ...)
+                      (string separator)))
+
+       (define (string->entry str)
+         (let/fields ((fields ...) (string-split str #\:))
+                     (make-record (field-name fields) ...)))))))
+
+
+(define number->string*
+  (match-lambda
+    ((? number? number) (number->string number))
+    (_ "")))
+
+(define (false-if-string=? false-string)
+  (lambda (str)
+    (if (string=? str false-string)
+        #f
+        str)))
+
+(define (string-if-false str)
+  (lambda (obj)
+    (if (not obj) str obj)))
+
+(define (comma-separated->list str)
+  (string-tokenize str (char-set-complement (char-set #\,))))
+
+(define (list->comma-separated lst)
+  (string-join lst ","))
+
+
+;;;
+;;; Database definitions.
+;;;
+
+(define-database-entry <password-entry>           ;<pwd.h>
+  password-entry make-password-entry
+  password-entry?
+  (serialization #\: password-entry->string string->password-entry)
+
+  (name       password-entry-name)
+  (password   password-entry-password
+              (serialization (const "x") (const #f))
+              (default "x"))
+  (uid        password-entry-uid
+              (serialization number->string string->number))
+  (gid        password-entry-gid
+              (serialization number->string string->number))
+  (real-name  password-entry-real-name
+              (default ""))
+  (directory  password-entry-directory)
+  (shell      password-entry-shell
+              (default "/bin/sh")))
+
+(define-database-entry <shadow-entry>             ;<shadow.h>
+  shadow-entry make-shadow-entry
+  shadow-entry?
+  (serialization #\: shadow-entry->string string->shadow-entry)
+
+  (name                  shadow-entry-name)       ;string
+  (password              shadow-entry-password    ;string | #f
+                         (serialization (string-if-false "!")
+                                        (false-if-string=? "!"))
+                         (default #f))
+  (last-change           shadow-entry-last-change ;days since 1970-01-01
+                         (serialization number->string* string->number)
+                         (default 0))
+  (minimum-change-period shadow-entry-minimum-change-period
+                         (serialization number->string* string->number)
+                         (default #f))            ;days | #f
+  (maximum-change-period shadow-entry-maximum-change-period
+                         (serialization number->string* string->number)
+                         (default #f))            ;days | #f
+  (change-warning-time   shadow-entry-change-warning-time
+                         (serialization number->string* string->number)
+                         (default #f))            ;days | #f
+  (maximum-inactivity    shadow-entry-maximum-inactivity
+                         (serialization number->string* string->number)
+                         (default #f))             ;days | #f
+  (expiration            shadow-entry-expiration
+                         (serialization number->string* string->number)
+                         (default #f))            ;days since 1970-01-01 | #f
+  (flags                 shadow-entry-flags       ;"reserved"
+                         (serialization number->string* string->number)
+                         (default #f)))
+
+(define-database-entry <group-entry>              ;<grp.h>
+  group-entry make-group-entry
+  group-entry?
+  (serialization #\: group-entry->string string->group-entry)
+
+  (name            group-entry-name)
+  (password        group-entry-password
+                   (serialization (string-if-false "x")
+                                  (false-if-string=? "x"))
+                   (default #f))
+  (gid             group-entry-gid
+                   (serialization number->string string->number))
+  (members         group-entry-members
+                   (serialization list->comma-separated comma-separated->list)
+                   (default '())))
+
+(define (database-writer file mode entry->string)
+  (lambda* (entries #:optional (file-or-port file))
+    "Write ENTRIES to FILE-OR-PORT.  When FILE-OR-PORT is a file name, write
+to it atomically and set the appropriate permissions."
+    (define (write-entries port)
+      (for-each (lambda (entry)
+                  (display (entry->string entry) port)
+                  (newline port))
+                entries))
+
+    (if (port? file-or-port)
+        (write-entries file-or-port)
+        (let* ((template (string-append file-or-port ".XXXXXX"))
+               (port     (mkstemp! template)))
+          (dynamic-wind
+            (const #t)
+            (lambda ()
+              (chmod port mode)
+              (write-entries port)
+              (rename-file template file-or-port))
+            (lambda ()
+              (close-port port)
+              (when (file-exists? template)
+                (delete-file template))))))))
+
+(define write-passwd
+  (database-writer "/etc/passwd" #o644 password-entry->string))
+(define write-shadow
+  (database-writer "/etc/shadow" #o600 shadow-entry->string))
+(define write-group
+  (database-writer "/etc/group" #o644 group-entry->string))
+
+(define (database-reader file string->entry)
+  (lambda* (#:optional (file-or-port file))
+    (define (read-entries port)
+      (let loop ((entries '()))
+        (match (read-line port)
+          ((? eof-object?)
+           (reverse entries))
+          (line
+           (loop (cons (string->entry line) entries))))))
+
+    (if (port? file-or-port)
+        (read-entries file-or-port)
+        (call-with-input-file file-or-port
+          read-entries))))
+
+(define read-passwd
+  (database-reader "/etc/passwd" string->password-entry))
+(define read-shadow
+  (database-reader "/etc/shadow" string->shadow-entry))
+(define read-group
+  (database-reader "/etc/group" string->group-entry))
+
+
+;;;
+;;; Building databases.
+;;;
+
+(define-record-type* <allocation>
+  allocation make-allocation
+  allocation?
+  (ids            allocation-ids (default vlist-null))
+  (next-id        allocation-next-id (default %id-min))
+  (next-system-id allocation-next-system-id (default %system-id-max)))
+
+;; Trick to avoid name clashes...
+(define-syntax %allocation (identifier-syntax allocation))
+
+;; Minimum and maximum UIDs and GIDs (from find_new_uid.c and find_new_gid.c
+;; in Shadow.)
+(define %id-min 1000)
+(define %id-max 60000)
+
+(define %system-id-min 100)
+(define %system-id-max 999)
+
+(define (system-id? id)
+  (and (> id %system-id-min)
+       (<= id %system-id-max)))
+
+(define (user-id? id)
+  (and (>= id %id-min)
+       (< id %id-max)))
+
+(define* (allocate-id assignment #:key system?)
+  "Return two values: a newly allocated ID, and an updated <allocation> record
+based on ASSIGNMENT.  If SYSTEM? is true, return a system ID."
+  (define next
+    ;; Return the next available ID, looping if necessary.
+    (if system?
+        (lambda (id)
+          (let ((next-id (- id 1)))
+            (if (< next-id %system-id-min)
+                %system-id-max
+                next-id)))
+        (lambda (id)
+          (let ((next-id (+ id 1)))
+            (if (>= next-id %id-max)
+                %id-min
+                next-id)))))
+
+  (let loop ((id (if system?
+                     (allocation-next-system-id assignment)
+                     (allocation-next-id assignment))))
+    (if (vhash-assv id (allocation-ids assignment))
+        (loop (next id))
+        (let ((taken (vhash-consv id #t (allocation-ids assignment))))
+          (values (if system?
+                      (allocation (inherit assignment)
+                                  (next-system-id (next id))
+                                  (ids taken))
+                      (allocation (inherit assignment)
+                                  (next-id (next id))
+                                  (ids taken)))
+                  id)))))
+
+(define* (reserve-ids allocation ids #:key (skip? #t))
+  "Mark the numbers listed in IDS as reserved in ALLOCATION.  When SKIP? is
+true, start allocation after the highest (or lowest, depending on whether it's
+a system ID allocation) number among IDS."
+  (%allocation
+   (inherit allocation)
+   (next-id (if skip?
+                (+ (reduce max
+                           (- (allocation-next-id allocation) 1)
+                           (filter user-id? ids))
+                   1)
+                (allocation-next-id allocation)))
+   (next-system-id
+    (if skip?
+        (- (reduce min
+                   (+ 1 (allocation-next-system-id allocation))
+                   (filter system-id? ids))
+           1)
+        (allocation-next-system-id allocation)))
+   (ids (fold (cut vhash-consv <> #t <>)
+              (allocation-ids allocation)
+              ids))))
+
+(define (allocated? allocation id)
+  "Return true if ID is already allocated as part of ALLOCATION."
+  (->bool (vhash-assv id (allocation-ids allocation))))
+
+(define (lookup-procedure lst key)
+  "Return a lookup procedure for the elements of LST, calling KEY to obtain
+the key of each element."
+  (let ((table (fold (lambda (obj table)
+                       (vhash-cons (key obj) obj table))
+                     vlist-null
+                     lst)))
+    (lambda (key)
+      (match (vhash-assoc key table)
+        (#f #f)
+        ((_ . value) value)))))
+
+(define* (allocate-groups groups members
+                          #:optional (current-groups '()))
+  "Return a list of group entries for GROUPS, a list of <user-group>.  Members
+for each group are taken from MEMBERS, a vhash that maps group names to member
+names.  GIDs and passwords found in CURRENT-GROUPS, a list of group entries,
+are reused."
+  (define gids
+    ;; Mark all the currently-used GIDs and the explicitly requested GIDs as
+    ;; reserved.
+    (reserve-ids (reserve-ids (allocation)
+                              (map group-entry-gid current-groups))
+                 (filter-map user-group-id groups)
+                 #:skip? #f))
+
+  (define previous-entry
+    (lookup-procedure current-groups group-entry-name))
+
+  (reverse
+   (fold2 (lambda (group result allocation)
+            (let ((name         (user-group-name group))
+                  (password     (user-group-password group))
+                  (requested-id (user-group-id group))
+                  (system?      (user-group-system? group)))
+              (let*-values (((previous)
+                             (previous-entry name))
+                            ((allocation id)
+                             (cond
+                              ((number? requested-id)
+                               (values (reserve-ids allocation
+                                                    (list requested-id))
+                                       requested-id))
+                              (previous
+                               (values allocation
+                                       (group-entry-gid previous)))
+                              (else
+                               (allocate-id allocation
+                                            #:system? system?)))))
+                (values (cons (group-entry
+                               (name name)
+                               (password
+                                (if previous
+                                    (group-entry-password previous)
+                                    password))
+                               (gid id)
+                               (members (vhash-fold* cons '() name members)))
+                              result)
+                        allocation))))
+          '()
+          gids
+          groups)))
+
+(define* (allocate-passwd users groups #:optional (current-passwd '()))
+  "Return a list of password entries for USERS, a list of <user-account>.
+Take GIDs from GROUPS, a list of group entries.  Reuse UIDs from
+CURRENT-PASSWD, a list of password entries, when possible; otherwise allocate
+new UIDs."
+  (define uids
+    (reserve-ids (reserve-ids (allocation)
+                              (map password-entry-uid current-passwd))
+                 (filter-map user-account-uid users)
+                 #:skip? #f))
+
+  (define previous-entry
+    (lookup-procedure current-passwd password-entry-name))
+
+  (define (group-id name)
+    (or (any (lambda (entry)
+               (and (string=? (group-entry-name entry) name)
+                    (group-entry-gid entry)))
+             groups)
+        (error "group not found" name)))
+
+  (reverse
+   (fold2 (lambda (user result allocation)
+            (let ((name         (user-account-name user))
+                  (requested-id (user-account-uid user))
+                  (group        (user-account-group user))
+                  (real-name    (user-account-comment user))
+                  (directory    (user-account-home-directory user))
+                  (shell        (user-account-shell user))
+                  (system?      (user-account-system? user)))
+              (let*-values (((previous)
+                             (previous-entry name))
+                            ((allocation id)
+                             (cond
+                              ((number? requested-id)
+                               (values (reserve-ids allocation
+                                                    (list requested-id))
+                                       requested-id))
+                              (previous
+                               (values allocation
+                                       (password-entry-uid previous)))
+                              (else
+                               (allocate-id allocation
+                                            #:system? system?)))))
+                (values (cons (password-entry
+                               (name name)
+                               (uid id)
+                               (directory directory)
+                               (gid (if (number? group) group (group-id group)))
+                               (real-name (if previous
+                                              (password-entry-real-name previous)
+                                              real-name))
+                               (shell (if previous
+                                          (password-entry-shell previous)
+                                          shell)))
+                              result)
+                        allocation))))
+          '()
+          uids
+          users)))
+
+(define* (days-since-epoch #:optional (current-time current-time))
+  "Return the number of days elapsed since the 1st of January, 1970."
+  (let* ((now   (current-time time-utc))
+         (epoch (make-time time-utc 0 0))
+         (diff  (time-difference now epoch)))
+    (quotient (time-second diff) (* 24 3600))))
+
+(define* (passwd->shadow users passwd #:optional (current-shadow '())
+                         #:key (current-time current-time))
+  "Return a list of shadow entries for the password entries listed in PASSWD.
+Reuse shadow entries from CURRENT-SHADOW when they exist, and take the initial
+password from USERS."
+  (define previous-entry
+    (lookup-procedure current-shadow shadow-entry-name))
+
+  (define now
+    (days-since-epoch current-time))
+
+  (map (lambda (user passwd)
+         (or (previous-entry (password-entry-name passwd))
+             (shadow-entry (name (password-entry-name passwd))
+                           (password (user-account-password user))
+                           (last-change now))))
+       users passwd))
+
+(define (empty-if-not-found thunk)
+  "Call THUNK and return the empty list if that throws to ENOENT."
+  (catch 'system-error
+    thunk
+    (lambda args
+      (if (= ENOENT (system-error-errno args))
+          '()
+          (apply throw args)))))
+
+(define* (user+group-databases users groups
+                               #:key
+                               (current-passwd
+                                (empty-if-not-found read-passwd))
+                               (current-groups
+                                (empty-if-not-found read-group))
+                               (current-shadow
+                                (empty-if-not-found read-shadow))
+                               (current-time current-time))
+  "Return three values: the list of group entries, the list of password
+entries, and the list of shadow entries corresponding to USERS and GROUPS.
+Preserve stateful bits from CURRENT-PASSWD, CURRENT-GROUPS, and
+CURRENT-SHADOW: UIDs, GIDs, passwords, user shells, etc."
+  (define members
+    ;; Map group name to user names.
+    (fold (lambda (user members)
+            (fold (cute vhash-cons <> (user-account-name user) <>)
+                  members
+                  (user-account-supplementary-groups user)))
+          vlist-null
+          users))
+
+  (define group-entries
+    (allocate-groups groups members current-groups))
+
+  (define passwd-entries
+    (allocate-passwd users group-entries current-passwd))
+
+  (define shadow-entries
+    (passwd->shadow users passwd-entries current-shadow
+                    #:current-time current-time))
+
+  (values group-entries passwd-entries shadow-entries))
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index d516f5bdc9..cfdf17df0f 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, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -18,11 +18,15 @@
 ;;; 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 (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
@@ -42,35 +46,6 @@
 ;;;
 ;;; 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.
@@ -116,191 +91,82 @@ owner-writable in HOME."
                     (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 home `("-d" ,home) '())
-
-                    ;; Home directories of non-system accounts are created by
-                    ;; 'activate-user-home'.
-                    ,@(if (and home create-home? system?
-                               (not (file-exists? 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'.
-                ,@(if home `("-d" ,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 (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 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
-                     #:create-home? create-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")
+  "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")
 
-  ;; 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)))))
+  (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
-    (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)
-           (chmod home #o700)
-           (copy-account-skeletons home
-                                   #:uid uid #:gid gid))))))
+    (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))
 
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index c9ebe124fe..c0d4d44091 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -117,7 +117,6 @@ STORE."
     (directory "/var/tmp" 0 0 #o1777)
     (directory "/var/lock" 0 0 #o1777)
 
-    (directory "/root" 0 0)                       ; an exception
     (directory "/home" 0 0)))
 
 (define (populate-root-file-system system target)