diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/examples/bare-hurd.tmpl | 2 | ||||
| -rw-r--r-- | gnu/system/image.scm | 18 | ||||
| -rw-r--r-- | gnu/system/images/novena.scm | 2 | ||||
| -rw-r--r-- | gnu/system/images/pine64.scm | 2 | ||||
| -rw-r--r-- | gnu/system/images/pinebook-pro.scm | 6 | ||||
| -rw-r--r-- | gnu/system/install.scm | 6 | ||||
| -rw-r--r-- | gnu/system/linux-container.scm | 7 | ||||
| -rw-r--r-- | gnu/system/mapped-devices.scm | 5 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 46 |
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. |