Package: guix-patches;
Reported by: Ludovic Courtès <ludo <at> gnu.org>
Date: Mon, 4 Mar 2019 11:14:01 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 34730 in the body.
You can then email your comments to 34730 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#34730; Package guix-patches.
(Mon, 04 Mar 2019 11:14:01 GMT) Full text and rfc822 format available.Ludovic Courtès <ludo <at> gnu.org>:guix-patches <at> gnu.org.
(Mon, 04 Mar 2019 11:14:02 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: guix-patches <at> gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 0/4] Add (gnu build accounts) and use it to create /etc/passwd & co. Date: Mon, 4 Mar 2019 12:12:13 +0100
Hello Guix!
This patch series adds a new module, (gnu build accounts), and
uses it to create /etc/{passwd,group,shadow} upon system activation.
This replaces functionality currently provided by the Shadow
command-line tools (‘useradd’, ‘usermod’, etc.) and libc (‘getspnam’,
‘putpwent’, and all these wonderful APIs.)
It’s more code on our side, but it’s overall much less code involved
to create those databases. The code makes the UID/GID allocation
strategy and state handling (preserving passwords and UIDs/GIDs, not
reusing currently-used UIDs/GIDs, etc.) much clearer and auditable.
Previously all this was buried in imperative calls to ‘useradd’ & co.,
which in turn have an ID allocation strategy baked deep down into
the Shadow code.
As a side effect the system boots slightly faster and we get PIDs
starting at ~190 instead of ~300 on a bare-bones system. :-)
Feedback welcome!
Ludo’.
Ludovic Courtès (4):
system: Add (gnu system accounts).
activation: Operate on <user-account> and <user-group> records.
Add (gnu build accounts).
activation: Build account databases with (gnu build accounts).
Makefile.am | 1 +
gnu/build/accounts.scm | 561 +++++++++++++++++++++++++++++++++++++++
gnu/build/activation.scm | 245 +++--------------
gnu/build/install.scm | 3 +-
gnu/local.mk | 2 +
gnu/system/accounts.scm | 109 ++++++++
gnu/system/shadow.scm | 92 +++----
tests/accounts.scm | 309 +++++++++++++++++++++
8 files changed, 1061 insertions(+), 261 deletions(-)
create mode 100644 gnu/build/accounts.scm
create mode 100644 gnu/system/accounts.scm
create mode 100644 tests/accounts.scm
--
2.21.0
guix-patches <at> gnu.org:bug#34730; Package guix-patches.
(Mon, 04 Mar 2019 11:17:02 GMT) Full text and rfc822 format available.Message #8 received at 34730 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 34730 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 1/4] system: Add (gnu system accounts). Date: Mon, 4 Mar 2019 12:16:41 +0100
The (gnu system accounts) module is meant to be used both on the build-
and on the host-side.
* gnu/system/shadow.scm <top level>: Call 'default-shell'.
(<user-account>, <user-group>): Move to...
* gnu/system/accounts.scm: ... here. New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add system/accounts.scm.
---
gnu/local.mk | 1 +
gnu/system/accounts.scm | 81 +++++++++++++++++++++++++++++++++++++++++
gnu/system/shadow.scm | 72 +++++++++++++-----------------------
3 files changed, 107 insertions(+), 47 deletions(-)
create mode 100644 gnu/system/accounts.scm
diff --git a/gnu/local.mk b/gnu/local.mk
index 3d59e27e8f..a8915cf36b 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -527,6 +527,7 @@ GNU_SYSTEM_MODULES = \
%D%/services/xorg.scm \
\
%D%/system.scm \
+ %D%/system/accounts.scm \
%D%/system/file-systems.scm \
%D%/system/install.scm \
%D%/system/linux-container.scm \
diff --git a/gnu/system/accounts.scm b/gnu/system/accounts.scm
new file mode 100644
index 0000000000..36ee62e851
--- /dev/null
+++ b/gnu/system/accounts.scm
@@ -0,0 +1,81 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo <at> 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 system accounts)
+ #:use-module (guix records)
+ #:export (user-account
+ user-account?
+ user-account-name
+ user-account-password
+ user-account-uid
+ user-account-group
+ user-account-supplementary-groups
+ user-account-comment
+ user-account-home-directory
+ user-account-create-home-directory?
+ user-account-shell
+ user-account-system?
+
+ user-group
+ user-group?
+ user-group-name
+ user-group-password
+ user-group-id
+ user-group-system?
+
+ default-shell))
+
+
+;;; Commentary:
+;;;
+;;; Data structures representing user accounts and user groups. This is meant
+;;; to be used both on the host side and at run time--e.g., in activation
+;;; snippets.
+;;;
+;;; Code:
+
+(define default-shell
+ ;; Default shell for user accounts (a string or string-valued gexp).
+ (make-parameter "/bin/sh"))
+
+(define-record-type* <user-account>
+ user-account make-user-account
+ user-account?
+ (name user-account-name)
+ (password user-account-password (default #f))
+ (uid user-account-uid (default #f))
+ (group user-account-group) ; number | string
+ (supplementary-groups user-account-supplementary-groups
+ (default '())) ; list of strings
+ (comment user-account-comment (default ""))
+ (home-directory user-account-home-directory)
+ (create-home-directory? user-account-create-home-directory? ;Boolean
+ (default #t))
+ (shell user-account-shell ; gexp
+ (default (default-shell)))
+ (system? user-account-system? ; Boolean
+ (default #f)))
+
+(define-record-type* <user-group>
+ user-group make-user-group
+ user-group?
+ (name user-group-name)
+ (password user-group-password (default #f))
+ (id user-group-id (default #f))
+ (system? user-group-system? ; Boolean
+ (default #f)))
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index 63f544cec9..a9a4afd414 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo <at> gnu.org>
;;; Copyright © 2016 Alex Griffin <a <at> ajgrf.com>
;;;
;;; This file is part of GNU Guix.
@@ -24,6 +24,7 @@
#:use-module (guix modules)
#:use-module (guix sets)
#:use-module (guix ui)
+ #:use-module (gnu system accounts)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module ((gnu system file-systems)
@@ -36,27 +37,29 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
- #:export (user-account
- user-account?
- user-account-name
- user-account-password
- user-account-uid
- user-account-group
- user-account-supplementary-groups
- user-account-comment
- user-account-home-directory
- user-account-create-home-directory?
- user-account-shell
- user-account-system?
- user-group
- user-group?
- user-group-name
- user-group-password
- user-group-id
- user-group-system?
+ ;; Re-export these bindings for backward compatibility.
+ #:re-export (user-account
+ user-account?
+ user-account-name
+ user-account-password
+ user-account-uid
+ user-account-group
+ user-account-supplementary-groups
+ user-account-comment
+ user-account-home-directory
+ user-account-create-home-directory?
+ user-account-shell
+ user-account-system?
- default-skeletons
+ user-group
+ user-group?
+ user-group-name
+ user-group-password
+ user-group-id
+ user-group-system?)
+
+ #:export (default-skeletons
skeleton-directory
%base-groups
%base-user-accounts
@@ -70,33 +73,8 @@
;;;
;;; Code:
-(define-record-type* <user-account>
- user-account make-user-account
- user-account?
- (name user-account-name)
- (password user-account-password (default #f))
- (uid user-account-uid (default #f))
- (group user-account-group) ; number | string
- (supplementary-groups user-account-supplementary-groups
- (default '())) ; list of strings
- (comment user-account-comment (default ""))
- (home-directory user-account-home-directory)
- (create-home-directory? user-account-create-home-directory? ;Boolean
- (default #t))
- (shell user-account-shell ; gexp
- (default (file-append bash "/bin/bash")))
- (system? user-account-system? ; Boolean
- (default #f)))
-
-(define-record-type* <user-group>
- user-group make-user-group
- user-group?
- (name user-group-name)
- (password user-group-password (default #f))
- (id user-group-id (default #f))
- (system? user-group-system? ; Boolean
- (default #f)))
-
+;; Change the default shell used by new <user-account> records.
+(default-shell (file-append bash "/bin/bash"))
(define %base-groups
;; Default set of groups.
--
2.21.0
guix-patches <at> gnu.org:bug#34730; Package guix-patches.
(Mon, 04 Mar 2019 11:17:02 GMT) Full text and rfc822 format available.Message #11 received at 34730 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 34730 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 2/4] activation: Operate on <user-account> and <user-group> records. Date: Mon, 4 Mar 2019 12:16:42 +0100
* 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 <at> gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo <at> gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw <at> 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
guix-patches <at> gnu.org:bug#34730; Package guix-patches.
(Mon, 04 Mar 2019 11:17:03 GMT) Full text and rfc822 format available.Message #14 received at 34730 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 34730 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 4/4] activation: Build account databases with (gnu build accounts). Date: Mon, 4 Mar 2019 12:16:44 +0100
* 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 <at> gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo <at> gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich <at> 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
guix-patches <at> gnu.org:bug#34730; Package guix-patches.
(Mon, 04 Mar 2019 11:17:03 GMT) Full text and rfc822 format available.Message #17 received at 34730 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 34730 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 3/4] Add (gnu build accounts). Date: Mon, 4 Mar 2019 12:16:43 +0100
* 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 <at> 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/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 <at> 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"))
+
+
+(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))))
+
+
+(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
Ludovic Courtès <ludo <at> gnu.org>:Ludovic Courtès <ludo <at> gnu.org>:Message #22 received at 34730-done <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 34730-done <at> debbugs.gnu.org Subject: Re: [bug#34730] [PATCH 0/4] Add (gnu build accounts) and use it to create /etc/passwd & co. Date: Thu, 07 Mar 2019 20:49:29 +0100
Hello! Pushed! I’ve reconfigured and rebooted my system and I confirm I can still log in. :-) 0ae735bcc8 activation: Build account databases with (gnu build accounts). ec600e4544 Add (gnu build accounts). 6061d01512 activation: Operate on <user-account> and <user-group> records. f6f67b87c0 system: Add (gnu system accounts). Ludo’.
Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org.
(Fri, 05 Apr 2019 11:24:04 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.