*gnu/system/shadow.scm (find-duplicates): New variable. (assert-unique-account-names, assert-unique-group-names): New variables. (account-activation): Use them here. --- gnu/system/shadow.scm | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+)
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index a69339bc07..4dbd578e1e 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -20,6 +20,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu system shadow) + #:use-module ((guix diagnostics) #:select (formatted-message)) #:use-module (guix records) #:use-module (guix gexp) #:use-module (guix store) @@ -34,6 +35,7 @@ #:use-module ((gnu packages admin) #:select (shadow)) #:use-module (gnu packages bash) + #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -222,6 +224,40 @@ for a colorful Guile experience.\\n\\n\"))))\n")) (rename-file ".nanorc" ".config/nano/nanorc")) #t)))) +(define (find-duplicates list) + (let loop ((table (make-hash-table)) + (list list)) + (match list + (() + (hash-fold (lambda (key value seed) + (if (> value 1) + (cons key seed) + seed)) + '() + table)) + ((first . rest) + (hash-set! table first + (1+ (hash-ref table first 0))) + (loop table rest))))) + +(define (assert-unique-account-names users) + (match (find-duplicates (map user-account-name users)) + (() *unspecified*) + (duplicates + (raise + (formatted-message + (G_ "the following accounts appear more than once:~{ ~a~}~%") + duplicates))))) + +(define (assert-unique-group-names groups) + (match (find-duplicates (map user-group-name groups)) + (() *unspecified*) + (duplicates + (raise + (formatted-message + (G_ "the following groups appear more than once:~{ ~a~}~%") + duplicates))))) + (define (assert-valid-users/groups users groups) "Raise an error if USERS refer to groups not listed in GROUPS." (let ((groups (list->set (map user-group-name groups)))) @@ -292,6 +328,8 @@ group." (define group-specs (map user-group->gexp groups)) + (assert-unique-account-names accounts) + (assert-unique-group-names groups) (assert-valid-users/groups accounts groups) ;; Add users and user groups. -- 2.30.0
