* [bug#34730] [PATCH 2/4] activation: Operate on <user-account> and <user-group> records.
2019-03-04 11:16 ` [bug#34730] [PATCH 1/4] system: Add (gnu system accounts) Ludovic Courtès
@ 2019-03-04 11:16 ` Ludovic Courtès
2019-03-04 11:16 ` [bug#34730] [PATCH 3/4] Add (gnu build accounts) Ludovic Courtès
2019-03-04 11:16 ` [bug#34730] [PATCH 4/4] activation: Build account databases with " Ludovic Courtès
2 siblings, 0 replies; 6+ messages in thread
From: Ludovic Courtès @ 2019-03-04 11:16 UTC (permalink / raw)
To: 34730
* gnu/system/accounts.scm (sexp->user-group, sexp->user-account): New
procedures.
* gnu/system/shadow.scm (account-activation): Call them in the arguments
to 'activate-users+groups'.
(account-shepherd-service): Likewise.
* gnu/build/activation.scm (activate-users+groups): Expect a list of
<user-account> and a list of <user-group>. Replace uses of 'match' on
tuples with calls to record accessors.
(activate-user-home): Likewise.
---
gnu/build/activation.scm | 118 ++++++++++++++++++++-------------------
gnu/system/accounts.scm | 28 ++++++++++
gnu/system/shadow.scm | 22 +++++---
3 files changed, 103 insertions(+), 65 deletions(-)
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index 0e77677de1..820e04d648 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,6 +18,7 @@
;;; 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 linux-boot)
#:use-module (guix build utils)
#:use-module (ice-9 ftw)
@@ -212,37 +213,42 @@ logged in."
(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."
+ "Make sure USERS (a list of user account records) and GROUPS (a list of user
+group records) are all available."
(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?
+ (lambda (user)
+ (let ((name (user-account-name user))
+ (uid (user-account-uid user))
+ (group (user-account-group user))
+ (supplementary-groups
+ (user-account-supplementary-groups user))
+ (comment (user-account-comment user))
+ (home (user-account-home-directory user))
+ (create-home? (user-account-create-home-directory? user))
+ (shell (user-account-shell user))
+ (password (user-account-password user))
+ (system? (user-account-system? user)))
+ (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)
+ #: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))))))))
+ (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")
@@ -251,18 +257,18 @@ numeric gid or #f."
(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))
+ (activate-user (find (compose zero? user-account-uid) 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?))))
+ (for-each (lambda (group)
+ (let ((name (user-group-name group))
+ (password (user-group-password group))
+ (gid (user-group-id group))
+ (system? (user-group-system? group)))
+ (unless (false-if-exception (getgrnam name))
+ (add-group name
+ #:gid gid #:password password
+ #:system? system?))))
groups)
;; Create the other user accounts.
@@ -272,35 +278,33 @@ numeric gid or #f."
(for-each delete-user
(lset-difference string=?
(map passwd:name (current-users))
- (match users
- (((names . _) ...)
- names))))
+ (map user-account-name users)))
(for-each delete-group
(lset-difference string=?
(map group:name (current-groups))
- (match groups
- (((names . _) ...)
- names)))))
+ (map user-group-name groups))))
(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)))))))
+ (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)
+ (unless system?
+ (copy-account-skeletons home
+ #:uid uid #:gid gid)))))))
(for-each ensure-user-home users))
diff --git a/gnu/system/accounts.scm b/gnu/system/accounts.scm
index 36ee62e851..eb18fb5e43 100644
--- a/gnu/system/accounts.scm
+++ b/gnu/system/accounts.scm
@@ -18,6 +18,7 @@
(define-module (gnu system accounts)
#:use-module (guix records)
+ #:use-module (ice-9 match)
#:export (user-account
user-account?
user-account-name
@@ -38,6 +39,9 @@
user-group-id
user-group-system?
+ sexp->user-account
+ sexp->user-group
+
default-shell))
@@ -79,3 +83,27 @@
(id user-group-id (default #f))
(system? user-group-system? ; Boolean
(default #f)))
+
+(define (sexp->user-group sexp)
+ "Take SEXP, a tuple as returned by 'user-group->gexp', and turn it into a
+user-group record."
+ (match sexp
+ ((name password id system?)
+ (user-group (name name)
+ (password password)
+ (id id)
+ (system? system?)))))
+
+(define (sexp->user-account sexp)
+ "Take SEXP, a tuple as returned by 'user-account->gexp', and turn it into a
+user-account record."
+ (match sexp
+ ((name uid group supplementary-groups comment home-directory
+ create-home-directory? shell password system?)
+ (user-account (name name) (uid uid) (group group)
+ (supplementary-groups supplementary-groups)
+ (comment comment)
+ (home-directory home-directory)
+ (create-home-directory? create-home-directory?)
+ (shell shell) (password password)
+ (system? system?)))))
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index a9a4afd414..4e5b6ae5f2 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -298,11 +298,14 @@ group."
(assert-valid-users/groups accounts groups)
;; Add users and user groups.
- #~(begin
- (setenv "PATH"
- (string-append #$(@ (gnu packages admin) shadow) "/sbin"))
- (activate-users+groups (list #$@user-specs)
- (list #$@group-specs))))
+ (with-imported-modules (source-module-closure '((gnu system accounts)))
+ #~(begin
+ (use-modules (gnu system accounts))
+
+ (setenv "PATH"
+ (string-append #$(@ (gnu packages admin) shadow) "/sbin"))
+ (activate-users+groups (map sexp->user-account (list #$@user-specs))
+ (map sexp->user-group (list #$@group-specs))))))
(define (account-shepherd-service accounts+groups)
"Return a Shepherd service that creates the home directories for the user
@@ -322,12 +325,15 @@ accounts among ACCOUNTS+GROUPS."
(list (shepherd-service
(requirement '(file-systems))
(provision '(user-homes))
- (modules '((gnu build activation)))
+ (modules '((gnu build activation)
+ (gnu system accounts)))
(start (with-imported-modules (source-module-closure
- '((gnu build activation)))
+ '((gnu build activation)
+ (gnu system accounts)))
#~(lambda ()
(activate-user-home
- (list #$@(map user-account->gexp accounts)))
+ (map sexp->user-account
+ (list #$@(map user-account->gexp accounts))))
#f))) ;stop
(stop #~(const #f))
(respawn? #f)
--
2.21.0
^ permalink raw reply related [flat|nested] 6+ messages in thread* [bug#34730] [PATCH 3/4] Add (gnu build accounts).
2019-03-04 11:16 ` [bug#34730] [PATCH 1/4] system: Add (gnu system accounts) Ludovic Courtès
2019-03-04 11:16 ` [bug#34730] [PATCH 2/4] activation: Operate on <user-account> and <user-group> records Ludovic Courtès
@ 2019-03-04 11:16 ` Ludovic Courtès
2019-03-04 11:16 ` [bug#34730] [PATCH 4/4] activation: Build account databases with " Ludovic Courtès
2 siblings, 0 replies; 6+ messages in thread
From: Ludovic Courtès @ 2019-03-04 11:16 UTC (permalink / raw)
To: 34730
* gnu/build/accounts.scm, tests/accounts.scm: New files.
* Makefile.am (SCM_TESTS): Add tests/accounts.scm.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add build/accounts.scm.
---
Makefile.am | 1 +
gnu/build/accounts.scm | 561 +++++++++++++++++++++++++++++++++++++++++
gnu/local.mk | 1 +
tests/accounts.scm | 309 +++++++++++++++++++++++
4 files changed, 872 insertions(+)
create mode 100644 gnu/build/accounts.scm
create mode 100644 tests/accounts.scm
diff --git a/Makefile.am b/Makefile.am
index fec9800ce7..b63737260f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -390,6 +390,7 @@ SCM_TESTS = \
tests/file-systems.scm \
tests/uuid.scm \
tests/system.scm \
+ tests/accounts.scm \
tests/services.scm \
tests/scripts-build.scm \
tests/containers.scm \
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:
+
+\f
+;;;
+;;; 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 ","))
+
+\f
+;;;
+;;; 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))
+
+\f
+;;;
+;;; 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/local.mk b/gnu/local.mk
index a8915cf36b..e0b0173828 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -540,6 +540,7 @@ GNU_SYSTEM_MODULES = \
%D%/system/uuid.scm \
%D%/system/vm.scm \
\
+ %D%/build/accounts.scm \
%D%/build/activation.scm \
%D%/build/bootloader.scm \
%D%/build/cross-toolchain.scm \
diff --git a/tests/accounts.scm b/tests/accounts.scm
new file mode 100644
index 0000000000..127861042d
--- /dev/null
+++ b/tests/accounts.scm
@@ -0,0 +1,309 @@
+;;; 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 (test-accounts)
+ #:use-module (gnu build accounts)
+ #:use-module (gnu system accounts)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-64)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 match))
+
+(define %passwd-sample
+ "\
+root:x:0:0:Admin:/root:/bin/sh
+charlie:x:1000:998:Charlie:/home/charlie:/bin/sh\n")
+
+(define %group-sample
+ "\
+root:x:0:
+wheel:x:999:alice,bob
+hackers:x:65000:alice,charlie\n")
+
+(define %shadow-sample
+ (string-append "\
+root:" (crypt "secret" "$6$abc") ":17169::::::
+charlie:" (crypt "hey!" "$6$abc") ":17169::::::
+nobody:!:0::::::\n"))
+
+\f
+(test-begin "accounts")
+
+(test-equal "write-passwd"
+ %passwd-sample
+ (call-with-output-string
+ (lambda (port)
+ (write-passwd (list (password-entry
+ (name "root")
+ (uid 0) (gid 0)
+ (real-name "Admin")
+ (directory "/root")
+ (shell "/bin/sh"))
+ (password-entry
+ (name "charlie")
+ (uid 1000) (gid 998)
+ (real-name "Charlie")
+ (directory "/home/charlie")
+ (shell "/bin/sh")))
+ port))))
+
+(test-equal "read-passwd + write-passwd"
+ %passwd-sample
+ (call-with-output-string
+ (lambda (port)
+ (write-passwd (call-with-input-string %passwd-sample
+ read-passwd)
+ port))))
+
+(test-equal "write-group"
+ %group-sample
+ (call-with-output-string
+ (lambda (port)
+ (write-group (list (group-entry
+ (name "root") (gid 0))
+ (group-entry
+ (name "wheel") (gid 999)
+ (members '("alice" "bob")))
+ (group-entry
+ (name "hackers") (gid 65000)
+ (members '("alice" "charlie"))))
+ port))))
+
+(test-equal "read-group + write-group"
+ %group-sample
+ (call-with-output-string
+ (lambda (port)
+ (write-group (call-with-input-string %group-sample
+ read-group)
+ port))))
+
+(test-equal "write-shadow"
+ %shadow-sample
+ (call-with-output-string
+ (lambda (port)
+ (write-shadow (list (shadow-entry
+ (name "root")
+ (password (crypt "secret" "$6$abc"))
+ (last-change 17169))
+ (shadow-entry
+ (name "charlie")
+ (password (crypt "hey!" "$6$abc"))
+ (last-change 17169))
+ (shadow-entry
+ (name "nobody")))
+ port))))
+
+(test-equal "read-shadow + write-shadow"
+ %shadow-sample
+ (call-with-output-string
+ (lambda (port)
+ (write-shadow (call-with-input-string %shadow-sample
+ read-shadow)
+ port))))
+
+\f
+(define allocate-groups (@@ (gnu build accounts) allocate-groups))
+(define allocate-passwd (@@ (gnu build accounts) allocate-passwd))
+
+(test-equal "allocate-groups"
+ ;; Allocate GIDs in a stateless fashion.
+ (list (group-entry (name "s") (gid %system-id-max))
+ (group-entry (name "x") (gid 900))
+ (group-entry (name "t") (gid 899))
+ (group-entry (name "a") (gid %id-min) (password "foo")
+ (members '("alice" "bob")))
+ (group-entry (name "b") (gid (+ %id-min 1))
+ (members '("charlie"))))
+ (allocate-groups (list (user-group (name "s") (system? #t))
+ (user-group (name "x") (id 900))
+ (user-group (name "t") (system? #t))
+ (user-group (name "a") (password "foo"))
+ (user-group (name "b")))
+ (alist->vhash `(("a" . "bob")
+ ("a" . "alice")
+ ("b" . "charlie")))))
+
+(test-equal "allocate-groups with requested GIDs"
+ ;; Make sure the requested GID for "b" is honored.
+ (list (group-entry (name "a") (gid (+ 1 %id-min)))
+ (group-entry (name "b") (gid %id-min))
+ (group-entry (name "c") (gid (+ 2 %id-min))))
+ (allocate-groups (list (user-group (name "a"))
+ (user-group (name "b") (id %id-min))
+ (user-group (name "c")))
+ vlist-null))
+
+(test-equal "allocate-groups with previous state"
+ ;; Make sure bits of state are preserved: password, GID, no reuse of
+ ;; previously-used GIDs.
+ (list (group-entry (name "s") (gid (- %system-id-max 1)))
+ (group-entry (name "t") (gid (- %system-id-max 2)))
+ (group-entry (name "a") (gid 30000) (password #f)
+ (members '("alice" "bob")))
+ (group-entry (name "b") (gid 30001) (password "bar")
+ (members '("charlie"))))
+ (allocate-groups (list (user-group (name "s") (system? #t))
+ (user-group (name "t") (system? #t))
+ (user-group (name "a") (password "foo"))
+ (user-group (name "b")))
+ (alist->vhash `(("a" . "bob")
+ ("a" . "alice")
+ ("b" . "charlie")))
+ (list (group-entry (name "a") (gid 30000))
+ (group-entry (name "b") (gid 30001)
+ (password "bar"))
+ (group-entry (name "removed")
+ (gid %system-id-max)))))
+
+(test-equal "allocate-groups with previous state, looping"
+ ;; Check that allocation starts after the highest previously-used GID, and
+ ;; loops back to the lowest GID.
+ (list (group-entry (name "a") (gid (- %id-max 1)))
+ (group-entry (name "b") (gid %id-min))
+ (group-entry (name "c") (gid (+ 1 %id-min))))
+ (allocate-groups (list (user-group (name "a"))
+ (user-group (name "b"))
+ (user-group (name "c")))
+ vlist-null
+ (list (group-entry (name "d")
+ (gid (- %id-max 2))))))
+
+(test-equal "allocate-passwd"
+ ;; Allocate UIDs in a stateless fashion.
+ (list (password-entry (name "alice") (uid %id-min) (gid 1000)
+ (real-name "Alice") (shell "/bin/sh")
+ (directory "/home/alice"))
+ (password-entry (name "bob") (uid (+ 1 %id-min)) (gid 1001)
+ (real-name "Bob") (shell "/bin/gash")
+ (directory "/home/bob"))
+ (password-entry (name "sshd") (uid %system-id-max) (gid 500)
+ (real-name "sshd") (shell "/nologin")
+ (directory "/var/empty"))
+ (password-entry (name "guix") (uid 30000) (gid 499)
+ (real-name "Guix") (shell "/nologin")
+ (directory "/var/empty")))
+ (allocate-passwd (list (user-account (name "alice")
+ (comment "Alice")
+ (home-directory "/home/alice")
+ (shell "/bin/sh")
+ (group "users"))
+ (user-account (name "bob")
+ (comment "Bob")
+ (home-directory "/home/bob")
+ (shell "/bin/gash")
+ (group "wheel"))
+ (user-account (name "sshd") (system? #t)
+ (comment "sshd")
+ (home-directory "/var/empty")
+ (shell "/nologin")
+ (group "sshd"))
+ (user-account (name "guix") (system? #t)
+ (comment "Guix")
+ (home-directory "/var/empty")
+ (shell "/nologin")
+ (group "guix")
+ (uid 30000)))
+ (list (group-entry (name "users") (gid 1000))
+ (group-entry (name "wheel") (gid 1001))
+ (group-entry (name "sshd") (gid 500))
+ (group-entry (name "guix") (gid 499)))))
+
+(test-equal "allocate-passwd with previous state"
+ ;; Make sure bits of state are preserved: UID, no reuse of previously-used
+ ;; UIDs, and shell.
+ (list (password-entry (name "alice") (uid 1234) (gid 1000)
+ (real-name "Alice Smith") (shell "/gnu/.../bin/gash")
+ (directory "/home/alice"))
+ (password-entry (name "charlie") (uid 1236) (gid 1000)
+ (real-name "Charlie") (shell "/bin/sh")
+ (directory "/home/charlie")))
+ (allocate-passwd (list (user-account (name "alice")
+ (comment "Alice")
+ (home-directory "/home/alice")
+ (shell "/bin/sh") ;ignored
+ (group "users"))
+ (user-account (name "charlie")
+ (comment "Charlie")
+ (home-directory "/home/charlie")
+ (shell "/bin/sh")
+ (group "users")))
+ (list (group-entry (name "users") (gid 1000)))
+ (list (password-entry (name "alice") (uid 1234) (gid 9999)
+ (real-name "Alice Smith")
+ (shell "/gnu/.../bin/gash")
+ (directory "/home/alice"))
+ (password-entry (name "bob") (uid 1235) (gid 1001)
+ (real-name "Bob") (shell "/bin/sh")
+ (directory "/home/bob")))))
+
+(test-equal "user+group-databases"
+ ;; The whole shebang.
+ (list (list (group-entry (name "a") (gid %id-min)
+ (members '("bob")))
+ (group-entry (name "b") (gid (+ 1 %id-min))
+ (members '("alice")))
+ (group-entry (name "s") (gid %system-id-max)))
+ (list (password-entry (name "alice") (real-name "Alice")
+ (uid %id-min) (gid %id-min)
+ (directory "/a"))
+ (password-entry (name "bob") (real-name "Bob")
+ (uid (+ 1 %id-min)) (gid (+ 1 %id-min))
+ (directory "/b"))
+ (password-entry (name "nobody")
+ (uid 65534) (gid %system-id-max)
+ (directory "/var/empty")))
+ (list (shadow-entry (name "alice") (last-change 100)
+ (password (crypt "initial pass" "$6$")))
+ (shadow-entry (name "bob") (last-change 50)
+ (password (crypt "foo" "$6$")))
+ (shadow-entry (name "nobody") (last-change 100))))
+ (call-with-values
+ (lambda ()
+ (user+group-databases (list (user-account
+ (name "alice")
+ (comment "Alice")
+ (home-directory "/a")
+ (group "a")
+ (supplementary-groups '("b"))
+ (password (crypt "initial pass" "$6$")))
+ (user-account
+ (name "bob")
+ (comment "Bob")
+ (home-directory "/b")
+ (group "b")
+ (supplementary-groups '("a")))
+ (user-account
+ (name "nobody")
+ (group "s")
+ (uid 65534)
+ (home-directory "/var/empty")))
+ (list (user-group (name "a"))
+ (user-group (name "b"))
+ (user-group (name "s") (system? #t)))
+ #:current-passwd '()
+ #:current-shadow
+ (list (shadow-entry (name "bob")
+ (password (crypt "foo" "$6$"))
+ (last-change 50)))
+ #:current-groups '()
+ #:current-time
+ (lambda (type)
+ (make-time type 0 (* 24 3600 100)))))
+ list))
+
+(test-end "accounts")
--
2.21.0
^ permalink raw reply related [flat|nested] 6+ messages in thread* [bug#34730] [PATCH 4/4] activation: Build account databases with (gnu build accounts).
2019-03-04 11:16 ` [bug#34730] [PATCH 1/4] system: Add (gnu system accounts) Ludovic Courtès
2019-03-04 11:16 ` [bug#34730] [PATCH 2/4] activation: Operate on <user-account> and <user-group> records Ludovic Courtès
2019-03-04 11:16 ` [bug#34730] [PATCH 3/4] Add (gnu build accounts) Ludovic Courtès
@ 2019-03-04 11:16 ` Ludovic Courtès
2 siblings, 0 replies; 6+ messages in thread
From: Ludovic Courtès @ 2019-03-04 11:16 UTC (permalink / raw)
To: 34730
* gnu/build/activation.scm (enumerate, current-users, current-groups)
(add-group, add-user, modify-user, ensure-user): Remove.
(activate-users+groups)[touch, activate-user]: Remove.
[make-home-directory]: New procedure.
Rewrite in terms of 'user+group-databases', 'write-group', etc.
* gnu/build/install.scm (directives): Remove "/root".
* gnu/system/shadow.scm (account-activation): Remove (setenv "PATH" ...)
expression, which is now unneeded.
---
gnu/build/activation.scm | 207 ++++-----------------------------------
gnu/build/install.scm | 3 +-
gnu/system/shadow.scm | 2 -
3 files changed, 21 insertions(+), 191 deletions(-)
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index 820e04d648..aa5b7031f1 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -19,11 +19,13 @@
(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 (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:export (activate-users+groups
activate-user-home
@@ -43,35 +45,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.
@@ -117,172 +90,32 @@ 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 (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 (touch file)
- (close-port (open-file file "a0b")))
-
- (define activate-user
- (lambda (user)
- (let ((name (user-account-name user))
- (uid (user-account-uid user))
- (group (user-account-group user))
- (supplementary-groups
- (user-account-supplementary-groups user))
- (comment (user-account-comment user))
- (home (user-account-home-directory user))
- (create-home? (user-account-create-home-directory? user))
- (shell (user-account-shell user))
- (password (user-account-password user))
- (system? (user-account-system? user)))
- (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")
+ (define (make-home-directory user)
+ (let ((home (user-account-home-directory user))
+ (pwd (getpwnam (user-account-name user))))
+ (mkdir-p home)
+ (chown home (passwd:uid pwd) (passwd:gid pwd))
+ (chmod home #o700)))
;; 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 (compose zero? user-account-uid) users))
+ (let-values (((groups passwd shadow)
+ (user+group-databases users groups)))
+ (write-group groups)
+ (write-passwd passwd)
+ (write-shadow shadow)
- ;; Then create the groups.
- (for-each (lambda (group)
- (let ((name (user-group-name group))
- (password (user-group-password group))
- (gid (user-group-id group))
- (system? (user-group-system? group)))
- (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))
- (map user-account-name users)))
- (for-each delete-group
- (lset-difference string=?
- (map group:name (current-groups))
- (map user-group-name groups))))
+ ;; Home directories of non-system accounts are created by
+ ;; 'activate-user-home'.
+ (for-each make-home-directory
+ (filter (lambda (user)
+ (and (user-account-system? user)
+ (user-account-create-home-directory? user)))
+ users))))
(define (activate-user-home users)
"Create and populate the home directory of USERS, a list of tuples, unless
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)
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index 4e5b6ae5f2..7dc36f4a45 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -302,8 +302,6 @@ group."
#~(begin
(use-modules (gnu system accounts))
- (setenv "PATH"
- (string-append #$(@ (gnu packages admin) shadow) "/sbin"))
(activate-users+groups (map sexp->user-account (list #$@user-specs))
(map sexp->user-group (list #$@group-specs))))))
--
2.21.0
^ permalink raw reply related [flat|nested] 6+ messages in thread