Merge branch 'master' into staging-next

1 files changed, 44 insertions, 2 deletions

diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index a69339bc07..7c57222716 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,44 @@ for a colorful Guile experience.\\n\\n\"))))\n"))
                          (rename-file ".nanorc" ".config/nano/nanorc"))
                        #t))))
 
+(define (find-duplicates list)
+  "Find duplicate entries in @var{list}.
+Two entries are considered duplicates, if they are @code{equal?} to each other.
+This implementation is made asymptotically faster than @code{delete-duplicates}
+through the internal use of hash tables."
+  (let loop ((list list)
+             ;; We actually modify table in-place, but still allocate it here
+             ;; so that we only need one level of indentation.
+             (table (make-hash-table)))
+    (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 rest table)))))
+
+(define (assert-unique-account-names users)
+  (match (find-duplicates (map user-account-name users))
+    (() *unspecified*)
+    (duplicates
+     (warning
+      (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
+     (warning
+      (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))))
@@ -281,17 +321,19 @@ of user '~a' is undeclared")
 <user-group> objects.  Raise an error if a user account refers to a undefined
 group."
   (define accounts
-    (filter user-account? accounts+groups))
+    (delete-duplicates (filter user-account? accounts+groups) eq?))
 
   (define user-specs
     (map user-account->gexp accounts))
 
   (define groups
-    (filter user-group? accounts+groups))
+    (delete-duplicates (filter user-group? accounts+groups) eq?))
 
   (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.