summaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/examples/bare-hurd.tmpl2
-rw-r--r--gnu/system/image.scm18
-rw-r--r--gnu/system/images/novena.scm2
-rw-r--r--gnu/system/images/pine64.scm2
-rw-r--r--gnu/system/images/pinebook-pro.scm6
-rw-r--r--gnu/system/install.scm6
-rw-r--r--gnu/system/linux-container.scm7
-rw-r--r--gnu/system/mapped-devices.scm5
-rw-r--r--gnu/system/shadow.scm46
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 8c76bc2b11..59f0a02c8b 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -21,6 +21,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)
@@ -35,6 +36,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)
@@ -228,6 +230,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))))
@@ -287,17 +327,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.