Merge branch 'master' into staging

9 files changed, 72 insertions, 22 deletions

diff --git a/gnu/system/examples/bare-hurd.tmpl b/gnu/system/examples/bare-hurd.tmpl
index e4b795ff27..135ed23cb6 100644
--- a/gnu/system/examples/bare-hurd.tmpl
+++ b/gnu/system/examples/bare-hurd.tmpl
@@ -5,7 +5,7 @@
 
 ;; To build a disk image for a virtual machine, do
 ;;
-;;     ./pre-inst-env guix system disk-image --target=i586-pc-gnu \
+;;     ./pre-inst-env guix system image --target=i586-pc-gnu \
 ;;         gnu/system/examples/bare-hurd.tmpl
 ;;
 ;; You may run it like so
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 67930750d5..1012fa6158 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -70,7 +70,7 @@
             arm64-disk-image
 
             image-with-os
-            raw-image-type
+            efi-raw-image-type
             qcow2-image-type
             iso-image-type
             uncompressed-iso-image-type
@@ -128,21 +128,21 @@
            (label "GUIX_IMAGE")
            (flags '(boot)))))))
 
-(define arm32-disk-image
+(define* (arm32-disk-image #:optional (offset root-offset))
   (image
    (format 'disk-image)
    (target "arm-linux-gnueabihf")
    (partitions
     (list (partition
            (inherit root-partition)
-           (offset root-offset))))
+           (offset offset))))
    ;; FIXME: Deleting and creating "/var/run" and "/tmp" on the overlayfs
    ;; fails.
    (volatile-root? #f)))
 
-(define arm64-disk-image
+(define* (arm64-disk-image #:optional (offset root-offset))
   (image
-   (inherit arm32-disk-image)
+   (inherit (arm32-disk-image offset))
    (target "aarch64-linux-gnu")))
 
 
@@ -157,9 +157,9 @@ set to the given OS."
    (inherit base-image)
    (operating-system os)))
 
-(define raw-image-type
+(define efi-raw-image-type
   (image-type
-   (name 'raw)
+   (name 'efi-raw)
    (constructor (cut image-with-os efi-disk-image <>))))
 
 (define qcow2-image-type
@@ -189,12 +189,12 @@ set to the given OS."
 (define arm32-image-type
   (image-type
    (name 'arm32-raw)
-   (constructor (cut image-with-os arm32-disk-image <>))))
+   (constructor (cut image-with-os (arm32-disk-image) <>))))
 
 (define arm64-image-type
   (image-type
    (name 'arm64-raw)
-   (constructor (cut image-with-os arm64-disk-image <>))))
+   (constructor (cut image-with-os (arm64-disk-image) <>))))
 
 
 ;;
diff --git a/gnu/system/images/novena.scm b/gnu/system/images/novena.scm
index c4d25e850e..dfaf2c60ee 100644
--- a/gnu/system/images/novena.scm
+++ b/gnu/system/images/novena.scm
@@ -52,7 +52,7 @@
 (define novena-image-type
   (image-type
    (name 'novena-raw)
-   (constructor (cut image-with-os arm32-disk-image <>))))
+   (constructor (cut image-with-os (arm32-disk-image) <>))))
 
 (define novena-barebones-raw-image
   (image
diff --git a/gnu/system/images/pine64.scm b/gnu/system/images/pine64.scm
index f0b0c3f50d..63b31399a5 100644
--- a/gnu/system/images/pine64.scm
+++ b/gnu/system/images/pine64.scm
@@ -57,7 +57,7 @@
 (define pine64-image-type
   (image-type
    (name 'pine64-raw)
-   (constructor (cut image-with-os arm64-disk-image <>))))
+   (constructor (cut image-with-os (arm64-disk-image) <>))))
 
 (define pine64-barebones-raw-image
   (image
diff --git a/gnu/system/images/pinebook-pro.scm b/gnu/system/images/pinebook-pro.scm
index b038e262cb..22997fd742 100644
--- a/gnu/system/images/pinebook-pro.scm
+++ b/gnu/system/images/pinebook-pro.scm
@@ -51,13 +51,15 @@
                               (extra-options '("-L")) ; no carrier detect
                               (baud-rate "115200")
                               (term "vt100")
-                              (tty "ttyS0")))
+                              (tty "ttyS2")))
                     %base-services))))
 
 (define pinebook-pro-image-type
   (image-type
    (name 'pinebook-pro-raw)
-   (constructor (cut image-with-os arm64-disk-image <>))))
+   (constructor (cut image-with-os
+                     (arm64-disk-image (* 9 (expt 2 20))) ;9MiB
+                     <>))))
 
 (define pinebook-pro-barebones-raw-image
   (image
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index e753463473..7fa5c15324 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
@@ -212,7 +212,9 @@ the given target.")
                 ;; 'user-processes' doesn't depend on us.  The 'user-file-systems'
                 ;; service will unmount TARGET eventually.
                 (delete-file-recursively
-                 (string-append target #$%backing-directory))))))))
+                 (string-append target #$%backing-directory))))))
+   (description "Make the store copy-on-write, with writes going to \
+the given target.")))
 
 (define (cow-store-service)
   "Return a service that makes the store copy-on-write, such that writes go to
diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm
index 4a9cd0efe2..e6fd0f1315 100644
--- a/gnu/system/linux-container.scm
+++ b/gnu/system/linux-container.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2020 Google LLC
@@ -76,7 +76,10 @@ from OS that are needed on the bare metal and not in a container."
 doing anything.")
            (provision '(loopback networking))
            (start #~(const #t))))
-   #f))
+   #f
+   (description "Provide loopback and networking without actually doing
+anything.  This service is used by guest systems running in containers, where
+networking support is provided by the host.")))
 
 (define %nscd-container-caches
   ;; Similar to %nscd-default-caches but with smaller cache sizes. This allows
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 559c27bb28..518dbc4fe8 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2017, 2018 Mark H Weaver <mhw@netris.org>
 ;;;
@@ -130,7 +130,8 @@ specifications to 'targets'."
        (documentation "Map a device node using Linux's device mapper.")
        (start #~(lambda () #$(open source targets)))
        (stop #~(lambda _ (not #$(close source targets))))
-       (respawn? #f))))))
+       (respawn? #f))))
+   (description "Map a device node using Linux's device mapper.")))
 
 (define (device-mapping-service mapped-device)
   "Return a service that sets up @var{mapped-device}."
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.