From f9a8dd053c4e0fd1fc4b64291bb90de36520b3bc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 24 Jul 2020 23:28:11 +0200 Subject: utils: Move '&fix-hint' to (guix diagnostics). * guix/utils.scm (&fix-hint): Move to... * guix/diagnostics.scm (&fix-hint): ... here. * gnu.scm: Adjust imports accordingly. * gnu/system/mapped-devices.scm: Likewise. * guix/channels.scm: Likewise. * guix/profiles.scm: Likewise. * guix/scripts/system/reconfigure.scm: Likewise. * guix/ssh.scm: Likewise. --- gnu/system/mapped-devices.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm index c3f98302ad..00f235e6b6 100644 --- a/gnu/system/mapped-devices.scm +++ b/gnu/system/mapped-devices.scm @@ -23,7 +23,7 @@ #:use-module (guix records) #:use-module ((guix modules) #:hide (file-name->module-name)) #:use-module (guix i18n) - #:use-module ((guix utils) + #:use-module ((guix diagnostics) #:select (source-properties->location &fix-hint &error-location)) -- cgit 1.4.1 From 7a0bf3d5337d2662b0e4cdb8c9f8b5162c401d23 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 25 Jul 2020 15:48:35 +0200 Subject: file-systems: Convey hint via '&fix-hint'. * gnu/system/file-systems.scm (btrfs-store-subvolume-file-name): Use '&fix-hint' for the hint. --- gnu/system/file-systems.scm | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 0f94577760..f6b0d8a964 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2020 Jakub Kądziołka ;;; Copyright © 2020 Maxim Cournoyer ;;; @@ -28,6 +28,8 @@ #:use-module (srfi srfi-35) #:use-module (srfi srfi-9 gnu) #:use-module (guix records) + #:use-module ((guix diagnostics) #:select (&fix-hint)) + #:use-module (guix i18n) #:use-module (gnu system uuid) #:re-export (uuid ;backward compatibility string->uuid @@ -613,12 +615,13 @@ store is located, else #f." ;; XXX: Deriving the subvolume name based from a subvolume ID is not ;; supported, as we'd need to query the actual file system. (or (and=> (assoc-ref options "subvol") prepend-slash/maybe) - ;; FIXME: Use &fix-hint once it no longer pulls in (guix utils). (raise (condition (&message (message "The store is on a Btrfs subvolume, but the \ -subvolume name is unknown. -Hint: Use the \"subvol\" Btrfs file system option."))))))) +subvolume name is unknown.")) + (&fix-hint + (hint + (G_ "Use the @code{subvol} Btrfs file system option.")))))))) ;;; file-systems.scm ends here -- cgit 1.4.1 From d51bfe242fbe6f3f8f71d723e8fe0c7bbe711ba1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 25 Jul 2020 18:26:18 +0200 Subject: Use 'formatted-message' instead of '&message' where appropriate. * gnu.scm (%try-use-modules): Use 'formatted-message' instead of '&message'. * gnu/machine/digital-ocean.scm (maybe-raise-unsupported-configuration-error): Likewise. * gnu/machine/ssh.scm (machine-check-file-system-availability): Likewise. (machine-check-building-for-appropriate-system): Likewise. (deploy-managed-host): Likewise. (maybe-raise-unsupported-configuration-error): Likewise. * gnu/packages.scm (search-patch): Likewise. * gnu/services.scm (%service-with-default-value): Likewise. (files->etc-directory): Likewise. (fold-services): Likewise. * gnu/system.scm (locale-name->definition*): Likewise. * gnu/system/mapped-devices.scm (check-device-initrd-modules): Likewise. (check-luks-device): Likewise. * guix/channels.scm (latest-channel-instance): Likewise. * guix/cve.scm (json->cve-items): Likewise. * guix/git-authenticate.scm (commit-signing-key): Likewise. (commit-authorized-keys): Likewise. (authenticate-commit): Likewise. (verify-introductory-commit): Likewise. * guix/remote.scm (remote-pipe-for-gexp): Likewise. * guix/scripts/graph.scm (assert-package): Likewise. * guix/scripts/offload.scm (private-key-from-file*): Likewise. * guix/ssh.scm (authenticate-server*): Likewise. (open-ssh-session): Likewise. (remote-inferior): Likewise. * guix/ui.scm (matching-generations): Likewise. * guix/upstream.scm (package-update): Likewise. * tests/channels.scm ("latest-channel-instances, missing introduction for 'guix'"): Catch 'formatted-message?'. ("authenticate-channel, wrong first commit signer"): Likewise. * tests/lint.scm ("patches: not found"): Adjust message string. * tests/packages.scm ("patch not found yields a run-time error"): Catch 'formatted-message?'. * guix/lint.scm (check-patch-file-names): Handle 'formatted-message?'. (check-derivation): Ditto. --- gnu.scm | 6 +-- gnu/machine/digital-ocean.scm | 7 ++-- gnu/machine/ssh.scm | 36 ++++++------------ gnu/packages.scm | 6 +-- gnu/services.scm | 32 ++++++++-------- gnu/system.scm | 4 +- gnu/system/mapped-devices.scm | 34 +++++++++-------- guix/channels.scm | 14 +++---- guix/cve.scm | 15 +++----- guix/git-authenticate.scm | 86 +++++++++++++++++++++---------------------- guix/lint.scm | 16 +++++++- guix/remote.scm | 9 ++--- guix/scripts/graph.scm | 9 ++--- guix/scripts/offload.scm | 10 ++--- guix/ssh.scm | 26 +++++-------- guix/ui.scm | 4 +- guix/upstream.scm | 11 +++--- tests/channels.scm | 22 ++++++++--- tests/lint.scm | 2 +- tests/packages.scm | 11 +++--- 20 files changed, 173 insertions(+), 187 deletions(-) (limited to 'gnu/system') diff --git a/gnu.scm b/gnu.scm index b95082f42e..f139531ef3 100644 --- a/gnu.scm +++ b/gnu.scm @@ -78,10 +78,8 @@ (raise (apply make-compound-condition - (condition - (&message - (message (format #f (G_ "module ~a not found") - module)))) + (formatted-message (G_ "module ~a not found") + module) (condition (&error-location (location location))) (or (and=> (make-hint module) list) diff --git a/gnu/machine/digital-ocean.scm b/gnu/machine/digital-ocean.scm index 1a91a3a49b..82383a8c7c 100644 --- a/gnu/machine/digital-ocean.scm +++ b/gnu/machine/digital-ocean.scm @@ -26,6 +26,7 @@ #:use-module (guix base32) #:use-module (guix derivations) #:use-module (guix i18n) + #:use-module ((guix diagnostics) #:select (formatted-message)) #:use-module (guix import json) #:use-module (guix monads) #:use-module (guix records) @@ -414,9 +415,7 @@ one procured from https://cloud.digitalocean.com/account/api/tokens."))))))) (let ((config (machine-configuration machine)) (environment (environment-type-name (machine-environment machine)))) (unless (and config (digital-ocean-configuration? config)) - (raise (condition - (&message - (message (format #f (G_ "unsupported machine configuration '~a' + (raise (formatted-message (G_ "unsupported machine configuration '~a' \ for environment of type '~a'") config - environment)))))))) + environment))))) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index 4148639292..641e871861 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -179,11 +179,9 @@ exist on the machine." (lambda args (system-error-errno args))))) (when (number? errno) - (raise (condition - (&message - (message (format #f (G_ "device '~a' not found: ~a") + (raise (formatted-message (G_ "device '~a' not found: ~a") (file-system-device fs) - (strerror errno))))))))) + (strerror errno)))))) (define (check-labeled-file-system fs) (define remote-exp @@ -196,11 +194,9 @@ exist on the machine." (remote-let ((result remote-exp)) (unless result - (raise (condition - (&message - (message (format #f (G_ "no file system with label '~a'") + (raise (formatted-message (G_ "no file system with label '~a'") (file-system-label->string - (file-system-device fs)))))))))) + (file-system-device fs))))))) (define (check-uuid-file-system fs) (define remote-exp @@ -217,10 +213,8 @@ exist on the machine." (remote-let ((result remote-exp)) (unless result - (raise (condition - (&message - (message (format #f (G_ "no file system with UUID '~a'") - (uuid->string (file-system-device fs)))))))))) + (raise (formatted-message (G_ "no file system with UUID '~a'") + (uuid->string (file-system-device fs))))))) (append (map check-literal-file-system (filter (lambda (fs) @@ -285,12 +279,10 @@ by MACHINE." (system (remote-system (machine-ssh-session machine)))) (when (and (machine-ssh-configuration-build-locally? config) (not (string= system (machine-ssh-configuration-system config)))) - (raise (condition - (&message - (message (format #f (G_ "incorrect target system\ + (raise (formatted-message (G_ "incorrect target system\ ('~a' was given, while the system reports that it is '~a')~%") (machine-ssh-configuration-system config) - system)))))))) + system))))) (define (check-deployment-sanity machine) "Raise a '&message' error condition if it is clear that deploying MACHINE's @@ -402,11 +394,9 @@ environment type of 'managed-host." (when (machine-ssh-configuration-authorize? (machine-configuration machine)) (unless (file-exists? %public-key-file) - (raise (condition - (&message - (message (format #f (G_ "no signing key '~a'. \ + (raise (formatted-message (G_ "no signing key '~a'. \ have you run 'guix archive --generate-key?'") - %public-key-file)))))) + %public-key-file))) (remote-authorize-signing-key (call-with-input-file %public-key-file (lambda (port) (string->canonical-sexp @@ -497,9 +487,7 @@ connection to the host."))) (let ((config (machine-configuration machine)) (environment (environment-type-name (machine-environment machine)))) (unless (and config (machine-ssh-configuration? config)) - (raise (condition - (&message - (message (format #f (G_ "unsupported machine configuration '~a' + (raise (formatted-message (G_ "unsupported machine configuration '~a' for environment of type '~a'") config - environment)))))))) + environment))))) diff --git a/gnu/packages.scm b/gnu/packages.scm index d22c992bb1..4e4282645a 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -24,6 +24,7 @@ #:use-module (guix packages) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix diagnostics) #:use-module (guix discovery) #:use-module (guix memoization) #:use-module ((guix build utils) @@ -92,9 +93,8 @@ (define (search-patch file-name) "Search the patch FILE-NAME. Raise an error if not found." (or (search-path (%patch-path) file-name) - (raise (condition - (&message (message (format #f (G_ "~a: patch not found") - file-name))))))) + (raise (formatted-message (G_ "~a: patch not found") + file-name)))) (define-syntax-rule (search-patches file-name ...) "Return the list of absolute file names corresponding to each diff --git a/gnu/services.scm b/gnu/services.scm index 6509a9014e..399a432e3f 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -30,7 +30,7 @@ #:use-module (guix describe) #:use-module (guix sets) #:use-module (guix ui) - #:use-module ((guix utils) #:select (source-properties->location)) + #:use-module (guix diagnostics) #:autoload (guix openpgp) (openpgp-format-fingerprint) #:use-module (guix modules) #:use-module (gnu packages base) @@ -242,13 +242,13 @@ TYPE does not have a default value, an error is raised." (if (eq? default &no-default-value) (let ((location (source-properties->location location))) (raise - (condition - (&missing-value-service-error (type type) (location location)) - (&message - (message (format #f (G_ "~a: no value specified \ + (make-compound-condition + (condition + (&missing-value-service-error (type type) (location location))) + (formatted-message (G_ "~a: no value specified \ for service of type '~a'") - (location->string location) - (service-type-name type))))))) + (location->string location) + (service-type-name type))))) (service type default)))) (define-condition-type &service-error &error @@ -725,10 +725,8 @@ and FILE could be \"/usr/bin/env\"." (() #t) (((file _) rest ...) (when (set-contains? seen file) - (raise (condition - (&message - (message (format #f (G_ "duplicate '~a' entry for /etc") - file)))))) + (raise (formatted-message (G_ "duplicate '~a' entry for /etc") + file))) (loop rest (set-insert file seen)))))) ;; Detect duplicates early instead of letting them through, eventually @@ -1000,12 +998,12 @@ TARGET-TYPE; return the root service adjusted accordingly." vlist-null)) (() (raise - (condition (&missing-target-service-error - (service #f) - (target-type target-type)) - (&message - (message (format #f (G_ "service of type '~a' not found") - (service-type-name target-type))))))) + (make-compound-condition + (condition (&missing-target-service-error + (service #f) + (target-type target-type))) + (formatted-message (G_ "service of type '~a' not found") + (service-type-name target-type))))) (x (raise (condition (&ambiguous-target-service-error diff --git a/gnu/system.scm b/gnu/system.scm index 6ae15ab23b..c8ef641695 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -1113,9 +1113,7 @@ TYPE (one of 'iso9660 or 'dce). Return a UUID object." "Variant of 'locale-name->definition' that raises an error upon failure." (match (locale-name->definition name) (#f - (raise (condition - (&message - (message (format #f (G_ "~a: invalid locale name") name)))))) + (raise (formatted-message (G_ "~a: invalid locale name") name))) (def def))) (define (operating-system-locale-directory os) diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm index 00f235e6b6..31c50c4e40 100644 --- a/gnu/system/mapped-devices.scm +++ b/gnu/system/mapped-devices.scm @@ -25,6 +25,7 @@ #:use-module (guix i18n) #:use-module ((guix diagnostics) #:select (source-properties->location + formatted-message &fix-hint &error-location)) #:use-module (gnu services) @@ -132,13 +133,13 @@ DEVICE must be a \"/dev\" file name." ;; "usb_storage"), not file names (e.g., "usb-storage.ko"). This is ;; OK because we have machinery that accepts both the hyphen and the ;; underscore version. - (raise (condition - (&message - (message (format #f (G_ "you may need these modules \ + (raise (make-compound-condition + (formatted-message (G_ "you may need these modules \ in the initrd for ~a:~{ ~a~}") - device missing))) - (&fix-hint - (hint (format #f (G_ "Try adding them to the + device missing) + (condition + (&fix-hint + (hint (format #f (G_ "Try adding them to the @code{initrd-modules} field of your @code{operating-system} declaration, along these lines: @@ -151,9 +152,10 @@ these lines: If you think this diagnostic is inaccurate, use the @option{--skip-checks} option of @command{guix system}.\n") - missing))) - (&error-location - (location (source-properties->location location))))))) + missing)))) + (condition + (&error-location + (location (source-properties->location location)))))))) ;;; @@ -215,13 +217,13 @@ option of @command{guix system}.\n") (if (uuid? source) (match (find-partition-by-luks-uuid (uuid-bytevector source)) (#f - (raise (condition - (&message - (message (format #f (G_ "no LUKS partition with UUID '~a'") - (uuid->string source)))) - (&error-location - (location (source-properties->location - (mapped-device-location md))))))) + (raise (make-compound-condition + (formatted-message (G_ "no LUKS partition with UUID '~a'") + (uuid->string source)) + (condition + (&error-location + (location (source-properties->location + (mapped-device-location md)))))))) ((? string? device) (check-device-initrd-modules device initrd-modules location))) (check-device-initrd-modules source initrd-modules location))))) diff --git a/guix/channels.scm b/guix/channels.scm index 21a2fdb631..ad2442f50e 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -378,16 +378,16 @@ their relation. When AUTHENTICATE? is false, CHANNEL is not authenticated." ;; TODO: Warn for all the channels once the authentication interface ;; is public. (when (guix-channel? channel) - (raise (condition - (&message - (message (format #f (G_ "channel '~a' lacks an \ + (raise (make-compound-condition + (formatted-message (G_ "channel '~a' lacks an \ introduction and cannot be authenticated~%") - (channel-name channel)))) - (&fix-hint - (hint (G_ "Add the missing introduction to your + (channel-name channel)) + (condition + (&fix-hint + (hint (G_ "Add the missing introduction to your channels file to address the issue. Alternatively, you can pass @option{--disable-authentication}, at the risk of running unauthenticated and -thus potentially malicious code."))))))) +thus potentially malicious code.")))))))) (warning (G_ "channel authentication disabled~%"))) (when (guix-channel? channel) diff --git a/guix/cve.scm b/guix/cve.scm index 7dd9005f09..ae9cca2341 100644 --- a/guix/cve.scm +++ b/guix/cve.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +21,7 @@ #:use-module (guix http-client) #:use-module (guix json) #:use-module (guix i18n) + #:use-module ((guix diagnostics) #:select (formatted-message)) #:use-module (json) #:use-module (web uri) #:use-module (srfi srfi-1) @@ -194,15 +195,11 @@ records." (raise (condition (&message (message "invalid CVE feed"))))) (unless (equal? format "MITRE") - (raise (condition - (&message - (message (format #f (G_ "unsupported CVE format: '~a'") - format)))))) + (raise (formatted-message (G_ "unsupported CVE format: '~a'") + format))) (unless (equal? version "4.0") - (raise (condition - (&message - (message (format #f (G_ "unsupported CVE data version: '~a'") - version)))))) + (raise (formatted-message (G_ "unsupported CVE data version: '~a'") + version))) (map json->cve-item (vector->list (assoc-ref alist "CVE_Items"))))) diff --git a/guix/git-authenticate.scm b/guix/git-authenticate.scm index 6cfc7fabe1..4ab5419bd6 100644 --- a/guix/git-authenticate.scm +++ b/guix/git-authenticate.scm @@ -24,6 +24,7 @@ #:use-module ((guix git) #:select (commit-difference false-if-git-not-found)) #:use-module (guix i18n) + #:use-module ((guix diagnostics) #:select (formatted-message)) #:use-module (guix openpgp) #:use-module ((guix utils) #:select (cache-directory with-atomic-file-output)) @@ -105,23 +106,21 @@ not in KEYRING." (lambda _ (values #f #f))))) (unless signature - (raise (condition - (&unsigned-commit-error (commit commit-id)) - (&message - (message (format #f (G_ "commit ~a lacks a signature") - (oid->string commit-id))))))) + (raise (make-compound-condition + (condition (&unsigned-commit-error (commit commit-id))) + (formatted-message (G_ "commit ~a lacks a signature") + (oid->string commit-id))))) (let ((signature (string->openpgp-packet signature))) (when (memq (openpgp-signature-hash-algorithm signature) `(,@disallowed-hash-algorithms md5)) - (raise (condition - (&unsigned-commit-error (commit commit-id)) - (&message - (message (format #f (G_ "commit ~a has a ~a signature, \ + (raise (make-compound-condition + (condition (&unsigned-commit-error (commit commit-id))) + (formatted-message (G_ "commit ~a has a ~a signature, \ which is not permitted") - (oid->string commit-id) - (openpgp-signature-hash-algorithm - signature))))))) + (oid->string commit-id) + (openpgp-signature-hash-algorithm + signature))))) (with-fluids ((%default-port-encoding "UTF-8")) (let-values (((status data) @@ -130,23 +129,22 @@ which is not permitted") (match status ('bad-signature ;; There's a signature but it's invalid. - (raise (condition - (&signature-verification-error (commit commit-id) - (signature signature) - (keyring keyring)) - (&message - (message (format #f (G_ "signature verification failed \ + (raise (make-compound-condition + (condition + (&signature-verification-error (commit commit-id) + (signature signature) + (keyring keyring))) + (formatted-message (G_ "signature verification failed \ for commit ~a") - (oid->string commit-id))))))) + (oid->string commit-id))))) ('missing-key - (raise (condition - (&missing-key-error (commit commit-id) - (signature signature)) - (&message - (message (format #f (G_ "could not authenticate \ + (raise (make-compound-condition + (condition (&missing-key-error (commit commit-id) + (signature signature))) + (formatted-message (G_ "could not authenticate \ commit ~a: key ~a is missing") - (oid->string commit-id) - (openpgp-format-fingerprint data))))))) + (oid->string commit-id) + (openpgp-format-fingerprint data))))) ('good-signature data))))))) (define (read-authorizations port) @@ -179,13 +177,13 @@ does not specify anything, fall back to DEFAULT-AUTHORIZATIONS." ;; If COMMIT removes the '.guix-authorizations' file found in one of its ;; parents, raise an error. (when (parents-have-authorizations-file? commit) - (raise (condition - (&unauthorized-commit-error (commit (commit-id commit)) - (signing-key #f)) - (&message - (message (format #f (G_ "commit ~a attempts \ + (raise (make-compound-condition + (condition + (&unauthorized-commit-error (commit (commit-id commit)) + (signing-key #f))) + (formatted-message (G_ "commit ~a attempts \ to remove '.guix-authorizations' file") - (oid->string (commit-id commit))))))))) + (oid->string (commit-id commit))))))) (define (commit-authorizations commit) (catch 'git-error @@ -234,16 +232,16 @@ not specify anything, fall back to DEFAULT-AUTHORIZATIONS." (unless (member (openpgp-public-key-fingerprint signing-key) (commit-authorized-keys repository commit default-authorizations)) - (raise (condition - (&unauthorized-commit-error (commit id) - (signing-key signing-key)) - (&message - (message (format #f (G_ "commit ~a not signed by an authorized \ + (raise (make-compound-condition + (condition + (&unauthorized-commit-error (commit id) + (signing-key signing-key))) + (formatted-message (G_ "commit ~a not signed by an authorized \ key: ~a") - (oid->string id) - (openpgp-format-fingerprint - (openpgp-public-key-fingerprint - signing-key)))))))) + (oid->string id) + (openpgp-format-fingerprint + (openpgp-public-key-fingerprint + signing-key)))))) signing-key) @@ -366,13 +364,11 @@ EXPECTED-SIGNER." (commit-signing-key repository (commit-id commit) keyring))) (unless (bytevector=? expected-signer actual-signer) - (raise (condition - (&message - (message (format #f (G_ "initial commit ~a is signed by '~a' \ + (raise (formatted-message (G_ "initial commit ~a is signed by '~a' \ instead of '~a'") (oid->string (commit-id commit)) (openpgp-format-fingerprint actual-signer) - (openpgp-format-fingerprint expected-signer)))))))) + (openpgp-format-fingerprint expected-signer))))) (define* (authenticate-repository repository start signer #:key diff --git a/guix/lint.scm b/guix/lint.scm index e7855678ca..8a55f3e744 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -668,7 +668,12 @@ patch could not be found." ;; Use %make-warning, as condition-mesasge is already ;; translated. (%make-warning package (condition-message c) - #:field 'patch-file-names)))) + #:field 'patch-file-names))) + ((formatted-message? c) + (list (%make-warning package + (apply format #f + (G_ (formatted-message-string c)) + (formatted-message-arguments c)))))) (define patches (match (package-source package) ((? origin? origin) (origin-patches origin)) @@ -955,7 +960,14 @@ descriptions maintained upstream." (make-warning package (G_ "failed to create ~a derivation: ~a") (list system - (condition-message c))))) + (condition-message c)))) + ((formatted-message? c) + (let ((str (apply format #f + (formatted-message-string c) + (formatted-message-arguments c)))) + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system str))))) (parameterize ((%graft? #f)) (package-derivation store package system #:graft? #f) diff --git a/guix/remote.scm b/guix/remote.scm index a227540728..f6adb22846 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Ludovic Courtès +;;; Copyright © 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ #:use-module (guix ssh) #:use-module (guix gexp) #:use-module (guix i18n) + #:use-module ((guix diagnostics) #:select (formatted-message)) #:use-module (guix inferior) #:use-module (guix store) #:use-module (guix monads) @@ -72,11 +73,9 @@ BECOME-COMMAND is given, use that to invoke the remote Guile REPL." (when (eof-object? (peek-char pipe)) (let ((status (channel-get-exit-status pipe))) (close-port pipe) - (raise (condition - (&message - (message (format #f (G_ "remote command '~{~a~^ ~}' failed \ + (raise (formatted-message (G_ "remote command '~{~a~^ ~}' failed \ with status ~a") - repl-command status))))))) + repl-command status)))) pipe)) (define* (%remote-eval lowered session #:optional become-command) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 489931d5bb..73d9269de2 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -32,7 +32,8 @@ #:use-module ((guix build-system gnu) #:select (standard-packages)) #:use-module (gnu packages) #:use-module (guix sets) - #:use-module ((guix utils) #:select (location-file)) + #:use-module ((guix diagnostics) + #:select (location-file formatted-message)) #:use-module ((guix scripts build) #:select (show-transformation-options-help options->transformation @@ -90,10 +91,8 @@ name." package) (x (raise - (condition - (&message - (message (format #f (G_ "~a: invalid argument (package name expected)") - x)))))))) + (formatted-message (G_ "~a: invalid argument (package name expected)") + x))))) (define nodes-from-package ;; The default conversion method. diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index e81b6c25f2..77ff3d2694 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2017 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -33,11 +33,12 @@ #:use-module ((guix serialization) #:select (nar-error? nar-error-file)) #:use-module (guix nar) - #:use-module (guix utils) + #:use-module ((guix utils) #:select (%current-system)) #:use-module ((guix build syscalls) #:select (fcntl-flock set-thread-name)) #:use-module ((guix build utils) #:select (which mkdir-p)) #:use-module (guix ui) + #:use-module (guix diagnostics) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -156,10 +157,9 @@ can interpret meaningfully." (lambda () (private-key-from-file file)) (lambda (key proc str . rest) - (raise (condition - (&message (message (format #f (G_ "failed to load SSH \ + (raise (formatted-message (G_ "failed to load SSH \ private key from '~a': ~a") - file str)))))))) + file str))))) (define* (open-ssh-session machine #:optional (max-silent-time -1)) "Open an SSH session for MACHINE and return it. Throw an error on failure." diff --git a/guix/ssh.scm b/guix/ssh.scm index 418443992b..a36f72bb67 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -20,7 +20,7 @@ #:use-module (guix store) #:use-module (guix inferior) #:use-module (guix i18n) - #:use-module ((guix diagnostics) #:select (&fix-hint)) + #:use-module ((guix diagnostics) #:select (&fix-hint formatted-message)) #:use-module (gcrypt pk-crypto) #:use-module (ssh session) #:use-module (ssh auth) @@ -88,14 +88,12 @@ actual key does not match." ;; provided its Ed25519 key when we where expecting its RSA key. XXX: ;; Guile-SSH 0.10.1 doesn't know about ed25519 keys and 'get-key-type' ;; returns #f in that case. - (raise (condition - (&message - (message (format #f (G_ "server at '~a' returned host key \ + (raise (formatted-message (G_ "server at '~a' returned host key \ '~a' of type '~a' instead of '~a' of type '~a'~%") (session-get session 'host) (public-key->string server) (get-key-type server) - key type)))))))) + key type))))) (define* (open-ssh-session host #:key user port identity host-key @@ -148,12 +146,10 @@ Throw an error on failure." (match (authenticate-server session) ('ok #f) (reason - (raise (condition - (&message - (message (format #f (G_ "failed to authenticate \ + (raise (formatted-message (G_ "failed to authenticate \ server at '~a': ~a") (session-get session 'host) - reason)))))))) + reason))))) ;; Use public key authentication, via the SSH agent if it's available. (match (userauth-public-key/auto! session) @@ -173,10 +169,8 @@ server at '~a': ~a") host (get-error session))))))))))) (x ;; Connection failed or timeout expired. - (raise (condition - (&message - (message (format #f (G_ "SSH connection to '~a' failed: ~a~%") - host (get-error session)))))))))) + (raise (formatted-message (G_ "SSH connection to '~a' failed: ~a~%") + host (get-error session))))))) (define* (remote-inferior session #:optional become-command) "Return a remote inferior for the given SESSION. If BECOME-COMMAND is @@ -187,11 +181,9 @@ given, use that to invoke the remote Guile REPL." (when (eof-object? (peek-char pipe)) (let ((status (channel-get-exit-status pipe))) (close-port pipe) - (raise (condition - (&message - (message (format #f (G_ "remote command '~{~a~^ ~}' failed \ + (raise (formatted-message (G_ "remote command '~{~a~^ ~}' failed \ with status ~a") - repl-command status))))))) + repl-command status)))) (port->inferior pipe))) (define* (inferior-remote-eval exp session #:optional become-command) diff --git a/guix/ui.scm b/guix/ui.scm index 162eb35d26..420c9689ae 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1796,9 +1796,7 @@ DURATION-RELATION with the current time." filter-by-duration) (else (raise - (condition (&message - (message (format #f (G_ "invalid syntax: ~a~%") - str)))))))) + (formatted-message (G_ "invalid syntax: ~a~%") str))))) (define (display-generation profile number) "Display a one-line summary of generation NUMBER of PROFILE." diff --git a/guix/upstream.scm b/guix/upstream.scm index 70cbfb45e8..ca184601b2 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -417,12 +417,13 @@ values: 'always', 'never', and 'interactive' (default)." #f)))) (match (assq method %method-updates) (#f - (raise (condition (&message - (message (format #f (G_ "cannot download for \ + (raise (make-compound-condition + (formatted-message (G_ "cannot download for \ this method: ~s") - method))) - (&error-location - (location (package-location package)))))) + method) + (condition + (&error-location + (location (package-location package))))))) ((_ . update) (update store package source #:key-download key-download))))) diff --git a/tests/channels.scm b/tests/channels.scm index 55a0537e0f..1b6f640c4a 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -27,7 +27,11 @@ #:use-module (guix sets) #:use-module (guix gexp) #:use-module ((guix diagnostics) - #:select (error-location? error-location location-line)) + #:select (error-location? + error-location location-line + formatted-message? + formatted-message-string + formatted-message-arguments)) #:use-module ((guix build utils) #:select (which)) #:use-module (git) #:use-module (guix git) @@ -415,8 +419,8 @@ (channel (channel (url (string-append "file://" directory)) (name 'guix)))) - (guard (c ((message-condition? c) - (->bool (string-contains (condition-message c) + (guard (c ((formatted-message? c) + (->bool (string-contains (formatted-message-string c) "introduction")))) (with-store store ;; Attempt a downgrade from NEW to OLD. @@ -459,9 +463,15 @@ (channel (channel (name 'example) (url (string-append "file://" directory)) (introduction intro)))) - (guard (c ((message-condition? c) - (->bool (string-contains (condition-message c) - "initial commit")))) + (guard (c ((formatted-message? c) + (and (string-contains (formatted-message-string c) + "initial commit") + (equal? (formatted-message-arguments c) + (list + (oid->string (commit-id commit1)) + (key-fingerprint %ed25519-public-key-file) + (key-fingerprint + %ed25519bis-public-key-file)))))) (authenticate-channel channel directory (commit-id-string commit2) #:keyring-reference-prefix "") diff --git a/tests/lint.scm b/tests/lint.scm index 2f5e5623c1..95abd71378 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -334,7 +334,7 @@ (check-patch-file-names pkg)))) (test-equal "patches: not found" - "this-patch-does-not-exist!: patch not found" + "this-patch-does-not-exist!: patch not found\n" (single-lint-warning-message (let ((pkg (dummy-package "x" diff --git a/tests/packages.scm b/tests/packages.scm index 0a4bf83c40..596a2d1f83 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -618,12 +618,11 @@ (string=? (derivation->output-path drv) (package-output %store package "out"))))) -(test-assert "patch not found yields a run-time error" - (guard (c ((condition-has-type? c &message) - (and (string-contains (condition-message c) - "does-not-exist.patch") - (string-contains (condition-message c) - "not found")))) +(test-equal "patch not found yields a run-time error" + '("~a: patch not found\n" "does-not-exist.patch") + (guard (c ((formatted-message? c) + (cons (formatted-message-string c) + (formatted-message-arguments c)))) (let ((p (package (inherit (dummy-package "p")) (source (origin -- cgit 1.4.1 From 675e56221e3dfc58cac94bf30835f16a9c41d530 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 26 Jul 2020 15:34:33 +0200 Subject: file-systems: Add NTFS support. * gnu/system/uuid.scm (%ntfs-endianness): New macro, (ntfs-uuid->string): new procedure, (%ntfs-endianness): new variable, (string->ntfs-uuid): new exported procedure, (%uuid-parsers): add NTFS support, (%uuid-printers): add NTFS support. * gnu/build/file-systems.scm (%ntfs-endianness): New macro, (ntfs-superblock?, read-ntfs-superblock, ntfs-superblock-uuid, check-ntfs-file-system): new procedure, (%partition-uuid-readers): add NTFS support, (check-file-system): add NTFS support. --- gnu/build/file-systems.scm | 41 ++++++++++++++++++++++++++++++++++++++++- gnu/system/uuid.scm | 37 ++++++++++++++++++++++++++++++++++++- 2 files changed, 76 insertions(+), 2 deletions(-) (limited to 'gnu/system') diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index ad92d8a496..478c71a4e1 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -476,6 +476,42 @@ not valid header was found." (let ((uuid (sub-bytevector header 168 36))) (string->uuid (utf8->string uuid)))) + +;;; +;;; NTFS file systems. +;;; + +;; Taken from /fs/ntfs/layout.h + +(define-syntax %ntfs-endianness + ;; Endianness of NTFS file systems. + (identifier-syntax (endianness little))) + +(define (ntfs-superblock? sblock) + "Return #t when SBLOCK is a NTFS superblock." + (bytevector=? (sub-bytevector sblock 3 8) + (string->utf8 "NTFS "))) + +(define (read-ntfs-superblock device) + "Return the raw contents of DEVICE's NTFS superblock as a bytevector, or #f +if DEVICE does not contain a NTFS file system." + (read-superblock device 0 511 ntfs-superblock?)) + +(define (ntfs-superblock-uuid sblock) + "Return the UUID of NTFS superblock SBLOCK as a 8-byte bytevector." + (sub-bytevector sblock 72 8)) + +;; TODO: Add ntfs-superblock-volume-name. The partition label is not stored +;; in the BOOT SECTOR like the UUID, but in the MASTER FILE TABLE, which seems +;; way harder to access. + +(define (check-ntfs-file-system device) + "Return the health of a NTFS file system on DEVICE." + (match (status:exit-val + (system* "ntfsfix" device)) + (0 'pass) + (_ 'fatal-error))) + ;;; ;;; Partition lookup. @@ -585,7 +621,9 @@ partition field reader that returned a value." (partition-field-reader read-jfs-superblock jfs-superblock-uuid) (partition-field-reader read-f2fs-superblock - f2fs-superblock-uuid))) + f2fs-superblock-uuid) + (partition-field-reader read-ntfs-superblock + ntfs-superblock-uuid))) (define read-partition-label (cut read-partition-field <> %partition-label-readers)) @@ -684,6 +722,7 @@ were found." ((string-suffix? "fat" type) check-fat-file-system) ((string-prefix? "jfs" type) check-jfs-file-system) ((string-prefix? "f2fs" type) check-f2fs-file-system) + ((string-prefix? "ntfs" type) check-ntfs-file-system) ((string-prefix? "nfs" type) (const 'pass)) (else #f))) diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm index bc3af69610..c8352f4933 100644 --- a/gnu/system/uuid.scm +++ b/gnu/system/uuid.scm @@ -45,6 +45,7 @@ string->btrfs-uuid string->fat-uuid string->jfs-uuid + string->ntfs-uuid iso9660-uuid->string ;; XXX: For lack of a better place. @@ -195,6 +196,38 @@ ISO9660 UUID representation." %fat-endianness 2)))) + +;;; +;;; NTFS. +;;; + +(define-syntax %ntfs-endianness + ;; Endianness of NTFS file system. + (identifier-syntax (endianness little))) + +(define (ntfs-uuid->string uuid) + "Convert NTFS UUID, a 8-byte bytevector, to its string representation." + (format #f "~{~:@(~x~)~}" (reverse (bytevector->u8-list uuid)))) + +(define %ntfs-uuid-rx + (make-regexp "^([[:xdigit:]]{16})$")) + +(define (string->ntfs-uuid str) + "Parse STR, which is in NTFS format, and return a bytevector or #f." + (match (regexp-exec %ntfs-uuid-rx str) + (#f + #f) + (rx-match + (u8-list->bytevector + (let loop ((str str) + (res '())) + (if (string=? str "") + res + (loop (string-drop str 2) + (cons + (string->number (string-take str 2) 16) + res)))))))) + ;;; ;;; Generic interface. @@ -220,13 +253,15 @@ ISO9660 UUID representation." (vhashq ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => string->dce-uuid) ('fat32 'fat16 'fat => string->fat-uuid) + ('ntfs => string->ntfs-uuid) ('iso9660 => string->iso9660-uuid))) (define %uuid-printers (vhashq ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => dce-uuid->string) ('iso9660 => iso9660-uuid->string) - ('fat32 'fat16 'fat => fat-uuid->string))) + ('fat32 'fat16 'fat => fat-uuid->string) + ('ntfs => ntfs-uuid->string))) (define* (string->uuid str #:optional (type 'dce)) "Parse STR as a UUID of the given TYPE. On success, return the -- cgit 1.4.1 From 03914b9d8cc5918f495d1abeb97d783c8fc25fd7 Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Sun, 26 Jul 2020 01:01:02 +0300 Subject: examples: Add password for Alice's brother. * gnu/system/examples/desktop.tmpl (users)[bob]: Add password. --- gnu/system/examples/desktop.tmpl | 2 ++ 1 file changed, 2 insertions(+) (limited to 'gnu/system') diff --git a/gnu/system/examples/desktop.tmpl b/gnu/system/examples/desktop.tmpl index 3931bad60d..716b9feb8d 100644 --- a/gnu/system/examples/desktop.tmpl +++ b/gnu/system/examples/desktop.tmpl @@ -42,9 +42,11 @@ (type "vfat"))) %base-file-systems)) + ;; Create user `bob' with `alice' as its initial password. (users (cons (user-account (name "bob") (comment "Alice's brother") + (password (crypt "alice" "$6$abc")) (group "users") (supplementary-groups '("wheel" "netdev" "audio" "video"))) -- cgit 1.4.1 From 6bb07e91e1ab9367f636a3a5e9d52a9e0772aa89 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 31 Jul 2020 12:58:16 +0200 Subject: file-systems: Add %debug-file-system. * gnu/system/file-systems.scm (%debug-file-system): New variable, (%base-file-systems): add it. --- gnu/system/file-systems.scm | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'gnu/system') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index f6b0d8a964..660f9942b0 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -68,6 +68,7 @@ %pseudo-file-system-types %fuse-control-file-system %binary-format-file-system + %debug-file-system %shared-memory-file-system %pseudo-terminal-file-system %tty-gid @@ -368,6 +369,14 @@ TARGET in the other system." (type "binfmt_misc") (check? #f))) +(define %debug-file-system + (file-system + (type "debugfs") + (device "none") + (mount-point "/sys/kernel/debug") + (check? #f) + (create-mount-point? #t))) + (define %tty-gid ;; ID of the 'tty' group. Allocate it statically to make it easy to refer ;; to it from here and from the 'tty' group definitions. @@ -467,6 +476,7 @@ TARGET in the other system." ;; List of basic file systems to be mounted. Note that /proc and /sys are ;; currently mounted by the initrd. (list %pseudo-terminal-file-system + %debug-file-system %shared-memory-file-system %immutable-store)) -- cgit 1.4.1 From 7c27bd115b14afd142da7684cc349369965f9eab Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 31 Jul 2020 13:43:20 +0200 Subject: file-system: Add mount-may-fail? option. * gnu/system/file-systems.scm (): Add a mount-may-fail? field. (file-system->spec): adapt accordingly, (spec->file-system): ditto. * gnu/build/file-systems.scm (mount-file-system): If 'system-error is raised and mount-may-fail? is true, ignore it. Otherwise, re-raise the exception. Signed-off-by: Mathieu Othacehe --- gnu/build/file-systems.scm | 49 ++++++++++++++++++++++++++------------------- gnu/system/file-systems.scm | 11 +++++++--- 2 files changed, 36 insertions(+), 24 deletions(-) (limited to 'gnu/system') diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 478c71a4e1..4ba1503b9f 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -814,26 +814,33 @@ corresponds to the symbols listed in FLAGS." (when (file-system-check? fs) (check-file-system source type)) - ;; Create the mount point. Most of the time this is a directory, but - ;; in the case of a bind mount, a regular file or socket may be needed. - (if (and (= MS_BIND (logand flags MS_BIND)) - (not (file-is-directory? source))) - (unless (file-exists? mount-point) - (mkdir-p (dirname mount-point)) - (call-with-output-file mount-point (const #t))) - (mkdir-p mount-point)) - - (cond - ((string-prefix? "nfs" type) - (mount-nfs source mount-point type flags options)) - (else - (mount source mount-point type flags options))) - - ;; For read-only bind mounts, an extra remount is needed, as per - ;; , which still applies to Linux 4.0. - (when (and (= MS_BIND (logand flags MS_BIND)) - (= MS_RDONLY (logand flags MS_RDONLY))) - (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) - (mount source mount-point type flags #f))))) + (catch 'system-error + (lambda () + ;; Create the mount point. Most of the time this is a directory, but + ;; in the case of a bind mount, a regular file or socket may be + ;; needed. + (if (and (= MS_BIND (logand flags MS_BIND)) + (not (file-is-directory? source))) + (unless (file-exists? mount-point) + (mkdir-p (dirname mount-point)) + (call-with-output-file mount-point (const #t))) + (mkdir-p mount-point)) + + (cond + ((string-prefix? "nfs" type) + (mount-nfs source mount-point type flags options)) + (else + (mount source mount-point type flags options))) + + ;; For read-only bind mounts, an extra remount is needed, as per + ;; , which still applies to Linux + ;; 4.0. + (when (and (= MS_BIND (logand flags MS_BIND)) + (= MS_RDONLY (logand flags MS_RDONLY))) + (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) + (mount source mount-point type flags #f)))) + (lambda args + (or (file-system-mount-may-fail? fs) + (apply throw args)))))) ;;; file-systems.scm ends here diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 660f9942b0..9c5cbc9b4e 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -48,6 +48,7 @@ alist->file-system-options file-system-mount? + file-system-mount-may-fail? file-system-check? file-system-create-mount-point? file-system-dependencies @@ -114,6 +115,8 @@ (default #f)) (mount? file-system-mount? ; Boolean (default #t)) + (mount-may-fail? file-system-mount-may-fail? ; Boolean + (default #f)) (needed-for-boot? %file-system-needed-for-boot? ; Boolean (default #f)) (check? file-system-check? ; Boolean @@ -301,18 +304,19 @@ store--e.g., if FS is the root file system." "Return a list corresponding to file-system FS that can be passed to the initrd code." (match fs - (($ device mount-point type flags options _ _ check?) + (($ device mount-point type flags options mount? + mount-may-fail? needed-for-boot? check?) (list (cond ((uuid? device) `(uuid ,(uuid-type device) ,(uuid-bytevector device))) ((file-system-label? device) `(file-system-label ,(file-system-label->string device))) (else device)) - mount-point type flags options check?)))) + mount-point type flags options mount-may-fail? check?)))) (define (spec->file-system sexp) "Deserialize SEXP, a list, to the corresponding object." (match sexp - ((device mount-point type flags options check?) + ((device mount-point type flags options mount-may-fail? check?) (file-system (device (match device (('uuid (? symbol? type) (? bytevector? bv)) @@ -323,6 +327,7 @@ initrd code." device))) (mount-point mount-point) (type type) (flags flags) (options options) + (mount-may-fail? mount-may-fail?) (check? check?))))) (define (specification->file-system-mapping spec writable?) -- cgit 1.4.1 From f94835a917cf78675eb597fecd222b6c6d1fb1ae Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 31 Jul 2020 13:43:36 +0200 Subject: file-system: Add efivarfs support. Tools such as efibootmgr rely on the deprecated /sys/firmware/efi/vars API as well as on the new /sys/firmware/efi/efivars API. The latter needs to be mounted. Reported by Keyhenge here: https://lists.gnu.org/archive/html/bug-guix/2020-04/msg00274.html Here is the efivarfs documentation: https://www.kernel.org/doc/Documentation/filesystems/efivarfs.txt. * gnu/system/file-systems.scm (%efivars-file-system): New exported variable, (%base-file-systems): add it. * gnu/system/install.scm (%efivars-file-system): Add it. Signed-off-by: Mathieu Othacehe --- gnu/system/file-systems.scm | 12 ++++++++++++ gnu/system/install.scm | 1 + 2 files changed, 13 insertions(+) (limited to 'gnu/system') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 9c5cbc9b4e..a62cf902bf 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -70,6 +70,7 @@ %fuse-control-file-system %binary-format-file-system %debug-file-system + %efivars-file-system %shared-memory-file-system %pseudo-terminal-file-system %tty-gid @@ -382,6 +383,16 @@ TARGET in the other system." (check? #f) (create-mount-point? #t))) +(define %efivars-file-system + ;; Support for EFI variables file system. + (file-system + (device "efivarfs") + (mount-point "/sys/firmware/efi/efivars") + (type "efivarfs") + (mount-may-fail? #t) + (needed-for-boot? #f) + (check? #f))) + (define %tty-gid ;; ID of the 'tty' group. Allocate it statically to make it easy to refer ;; to it from here and from the 'tty' group definitions. @@ -483,6 +494,7 @@ TARGET in the other system." (list %pseudo-terminal-file-system %debug-file-system %shared-memory-file-system + %efivars-file-system %immutable-store)) ;; File systems for Linux containers differ from %base-file-systems in that diff --git a/gnu/system/install.scm b/gnu/system/install.scm index d0ff2e7c52..a87c2f4207 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -497,6 +497,7 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m ;; elogind's cgroup file systems. (list %pseudo-terminal-file-system %shared-memory-file-system + %efivars-file-system %immutable-store))) (users (list (user-account -- cgit 1.4.1 From 86c926d7f2dd4906d51dbcd7d39474116768a68d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Aug 2020 17:44:38 +0200 Subject: file-systems: Leave room for extension in serialized specs. * gnu/system/file-systems.scm (spec->file-system): Ignore extra fields. (file-system->spec): Add comment. --- gnu/system/file-systems.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index a62cf902bf..5c02dfac93 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -307,6 +307,7 @@ initrd code." (match fs (($ device mount-point type flags options mount? mount-may-fail? needed-for-boot? check?) + ;; Note: Add new fields towards the end for compatibility. (list (cond ((uuid? device) `(uuid ,(uuid-type device) ,(uuid-bytevector device))) ((file-system-label? device) @@ -317,7 +318,8 @@ initrd code." (define (spec->file-system sexp) "Deserialize SEXP, a list, to the corresponding object." (match sexp - ((device mount-point type flags options mount-may-fail? check?) + ((device mount-point type flags options mount-may-fail? check? + _ ...) ;placeholder for new fields (file-system (device (match device (('uuid (? symbol? type) (? bytevector? bv)) -- cgit 1.4.1 From 755f365b02b42a5d1e8ef3000dadef069553a478 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 5 Jul 2020 12:23:21 +0200 Subject: linux-libre: Support module compression. This commit adds support for GZIP compression for linux-libre kernel modules. The initrd modules are kept uncompressed as the initrd is already compressed as a whole. The linux-libre kernel also supports XZ compression, but as Guix does not have any available bindings for now, and the compression time is far more significant, GZIP seems to be a better option. * gnu/build/linux-modules.scm (modinfo-section-contents): Use 'call-with-gzip-input-port' to read from a module file using '.gz' extension, (strip-extension): new procedure, (dot-ko): adapt to support compression, (ensure-dot-ko): ditto, (file-name->module-name): ditto, (find-module-file): ditto, (load-linux-module*): ditto, (module-name->file-name/guess): ditto, (module-name-lookup): ditto, (write-module-name-database): ditto, (write-module-alias-database): ditto, (write-module-device-database): ditto. * gnu/installer.scm (installer-program): Add "guile-zlib" to the extensions. * gnu/machine/ssh.scm (machine-check-initrd-modules): Ditto. * gnu/services.scm (activation-script): Ditto. * gnu/services/base.scm (default-serial-port): Ditto, (agetty-shepherd-service): ditto, (udev-service-type): ditto. * gnu/system/image.scm (gcrypt-sqlite3&co): Ditto. * gnu/system/linux-initrd.scm (flat-linux-module-directory): Add "guile-zlib" to the extensions and make sure that the initrd only contains uncompressed module files. * gnu/system/shadow.scm (account-shepherd-service): Add "guile-zlib" to the extensions. * guix/profiles.scm (linux-module-database): Ditto. --- gnu/build/linux-modules.scm | 115 ++++++++---- gnu/installer.scm | 3 +- gnu/machine/ssh.scm | 35 ++-- gnu/services.scm | 46 ++--- gnu/services/base.scm | 428 ++++++++++++++++++++++---------------------- gnu/system/image.scm | 2 +- gnu/system/linux-initrd.scm | 72 +++++--- gnu/system/shadow.scm | 12 +- guix/profiles.scm | 71 ++++---- 9 files changed, 433 insertions(+), 351 deletions(-) (limited to 'gnu/system') diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm index aa1c7cfeae..3a47322065 100644 --- a/gnu/build/linux-modules.scm +++ b/gnu/build/linux-modules.scm @@ -24,6 +24,7 @@ #:use-module (guix build syscalls) #:use-module ((guix build utils) #:select (find-files invoke)) #:use-module (guix build union) + #:autoload (zlib) (call-with-gzip-input-port) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) @@ -94,10 +95,28 @@ string list." (cons (string->symbol (string-take str =)) (string-drop str (+ 1 =))))) +;; Matches kernel modules, without compression, with GZIP compression or with +;; XZ compression. +(define module-regex "\\.ko(\\.gz|\\.xz)?$") + (define (modinfo-section-contents file) "Return the contents of the '.modinfo' section of FILE as a list of key/value pairs.." - (let* ((bv (call-with-input-file file get-bytevector-all)) + (define (get-bytevector file) + (cond + ((string-suffix? ".ko.gz" file) + (let ((port (open-file file "r0"))) + (dynamic-wind + (lambda () + #t) + (lambda () + (call-with-gzip-input-port port get-bytevector-all)) + (lambda () + (close-port port))))) + (else + (call-with-input-file file get-bytevector-all)))) + + (let* ((bv (get-bytevector file)) (elf (parse-elf bv)) (section (elf-section-by-name elf ".modinfo")) (modinfo (section-contents elf section))) @@ -110,7 +129,7 @@ key/value pairs.." (define (module-formal-name file) "Return the module name of FILE as it appears in its info section. Usually the module name is the same as the base name of FILE, modulo hyphens and minus -the \".ko\" extension." +the \".ko[.gz|.xz]\" extension." (match (assq 'name (modinfo-section-contents file)) (('name . name) name) (#f #f))) @@ -171,14 +190,25 @@ modules that can be postloaded, of the soft dependencies of module FILE." (_ #f)) (modinfo-section-contents file)))) -(define dot-ko - (cut string-append <> ".ko")) - -(define (ensure-dot-ko name) - "Return NAME with a '.ko' prefix appended, unless it already has it." - (if (string-suffix? ".ko" name) +(define (strip-extension filename) + (let ((extension (string-index filename #\.))) + (if extension + (string-take filename extension) + filename))) + +(define (dot-ko name compression) + (let ((suffix (match compression + ('xz ".ko.xz") + ('gzip ".ko.gz") + (else ".ko")))) + (string-append name suffix))) + +(define (ensure-dot-ko name compression) + "Return NAME with a '.ko[.gz|.xz]' suffix appended, unless it already has +it." + (if (string-contains name ".ko") name - (dot-ko name))) + (dot-ko name compression))) (define (normalize-module-name module) "Return the \"canonical\" name for MODULE, replacing hyphens with @@ -191,9 +221,9 @@ underscores." module)) (define (file-name->module-name file) - "Return the module name corresponding to FILE, stripping the trailing '.ko' -and normalizing it." - (normalize-module-name (basename file ".ko"))) + "Return the module name corresponding to FILE, stripping the trailing +'.ko[.gz|.xz]' and normalizing it." + (normalize-module-name (strip-extension (basename file)))) (define (find-module-file directory module) "Lookup module NAME under DIRECTORY, and return its absolute file name. @@ -208,19 +238,19 @@ whereas file names often, but not always, use hyphens. Examples: ;; List of possible file names. XXX: It would of course be cleaner to ;; have a database that maps module names to file names and vice versa, ;; but everyone seems to be doing hacks like this one. Oh well! - (map ensure-dot-ko - (delete-duplicates - (list module - (normalize-module-name module) - (string-map (lambda (chr) ;converse of 'normalize-module-name' - (case chr - ((#\_) #\-) - (else chr))) - module))))) + (delete-duplicates + (list module + (normalize-module-name module) + (string-map (lambda (chr) ;converse of 'normalize-module-name' + (case chr + ((#\_) #\-) + (else chr))) + module)))) (match (find-files directory (lambda (file stat) - (member (basename file) names))) + (member (strip-extension + (basename file)) names))) ((file) file) (() @@ -290,8 +320,8 @@ not a file name." (recursive? #t) (lookup-module dot-ko) (black-list (module-black-list))) - "Load Linux module from FILE, the name of a '.ko' file; return true on -success, false otherwise. When RECURSIVE? is true, load its dependencies + "Load Linux module from FILE, the name of a '.ko[.gz|.xz]' file; return true +on success, false otherwise. When RECURSIVE? is true, load its dependencies first (à la 'modprobe'.) The actual files containing modules depended on are obtained by calling LOOKUP-MODULE with the module name. Modules whose name appears in BLACK-LIST are not loaded." @@ -523,16 +553,29 @@ are required to access DEVICE." ;;; Module databases. ;;; -(define (module-name->file-name/guess directory name) +(define* (module-name->file-name/guess directory name + #:key compression) "Guess the file name corresponding to NAME, a module name. That doesn't always work because sometimes underscores in NAME map to hyphens (e.g., -\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\")." - (string-append directory "/" (ensure-dot-ko name))) +\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\"). If the module is +compressed then COMPRESSED can be set to 'xz or 'gzip, depending on the +compression type." + (string-append directory "/" (ensure-dot-ko name compression))) (define (module-name-lookup directory) "Return a one argument procedure that takes a module name (e.g., \"input_leds\") and returns its absolute file name (e.g., \"/.../input-leds.ko\")." + (define (guess-file-name name) + (let ((names (list + (module-name->file-name/guess directory name) + (module-name->file-name/guess directory name + #:compression 'xz) + (module-name->file-name/guess directory name + #:compression 'gzip)))) + (or (find file-exists? names) + (first names)))) + (catch 'system-error (lambda () (define mapping @@ -541,23 +584,23 @@ always work because sometimes underscores in NAME map to hyphens (e.g., (lambda (name) (or (assoc-ref mapping name) - (module-name->file-name/guess directory name)))) + (guess-file-name name)))) (lambda args (if (= ENOENT (system-error-errno args)) - (cut module-name->file-name/guess directory <>) + (cut guess-file-name <>) (apply throw args))))) (define (write-module-name-database directory) "Write a database that maps \"module names\" as they appear in the relevant -ELF section of '.ko' files, to actual file names. This format is +ELF section of '.ko[.gz|.xz]' files, to actual file names. This format is Guix-specific. It aims to deal with inconsistent naming, in particular hyphens vs. underscores." (define mapping (map (lambda (file) (match (module-formal-name file) - (#f (cons (basename file ".ko") file)) + (#f (cons (strip-extension (basename file)) file)) (name (cons name file)))) - (find-files directory "\\.ko$"))) + (find-files directory module-regex))) (call-with-output-file (string-append directory "/modules.name") (lambda (port) @@ -569,12 +612,12 @@ hyphens vs. underscores." (pretty-print mapping port)))) (define (write-module-alias-database directory) - "Traverse the '.ko' files in DIRECTORY and create the corresponding + "Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding 'modules.alias' file." (define aliases (map (lambda (file) (cons (file-name->module-name file) (module-aliases file))) - (find-files directory "\\.ko$"))) + (find-files directory module-regex))) (call-with-output-file (string-append directory "/modules.alias") (lambda (port) @@ -616,7 +659,7 @@ are found, return a tuple (DEVNAME TYPE MAJOR MINOR), otherwise return #f." (char-set-complement (char-set #\-))) (define (write-module-device-database directory) - "Traverse the '.ko' files in DIRECTORY and create the corresponding + "Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding 'modules.devname' file. This file contains information about modules that can be loaded on-demand, such as file system modules." (define aliases @@ -624,7 +667,7 @@ be loaded on-demand, such as file system modules." (match (aliases->device-tuple (module-aliases file)) (#f #f) (tuple (cons (file-name->module-name file) tuple)))) - (find-files directory "\\.ko$"))) + (find-files directory module-regex))) (call-with-output-file (string-append directory "/modules.devname") (lambda (port) diff --git a/gnu/installer.scm b/gnu/installer.scm index 5c3192d7a6..576ac90a4b 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -342,7 +342,8 @@ selected keymap." ;; packages …), etc. modules. (with-extensions (list guile-gcrypt guile-newt guile-parted guile-bytestructures - guile-json-3 guile-git guix) + guile-json-3 guile-git guile-zlib + guix) (with-imported-modules `(,@(source-module-closure `(,@modules (gnu services herd) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index 4e31baa4b9..ee5032e281 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -21,6 +21,7 @@ #:use-module (gnu bootloader) #:use-module (gnu machine) #:autoload (gnu packages gnupg) (guile-gcrypt) + #:autoload (gnu packages guile) (guile-zlib) #:use-module (gnu system) #:use-module (gnu system file-systems) #:use-module (gnu system uuid) @@ -248,22 +249,24 @@ not available in the initrd." '((gnu build file-systems) (gnu build linux-modules) (gnu system uuid))) - #~(begin - (use-modules (gnu build file-systems) - (gnu build linux-modules) - (gnu system uuid)) - - (define dev - #$(cond ((string? device) device) - ((uuid? device) #~(find-partition-by-uuid - (string->uuid - #$(uuid->string device)))) - ((file-system-label? device) - #~(find-partition-by-label - #$(file-system-label->string device))))) - - (missing-modules dev '#$(operating-system-initrd-modules - (machine-operating-system machine))))))) + (with-extensions (list guile-zlib) + #~(begin + (use-modules (gnu build file-systems) + (gnu build linux-modules) + (gnu system uuid)) + + (define dev + #$(cond ((string? device) device) + ((uuid? device) #~(find-partition-by-uuid + (string->uuid + #$(uuid->string device)))) + ((file-system-label? device) + #~(find-partition-by-label + #$(file-system-label->string device))))) + + (missing-modules dev + '#$(operating-system-initrd-modules + (machine-operating-system machine)))))))) (remote-let ((missing remote-exp)) (unless (null? missing) diff --git a/gnu/services.scm b/gnu/services.scm index 11ba21e824..3e59c6401f 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -35,6 +35,7 @@ #:use-module (guix modules) #:use-module (gnu packages base) #:use-module (gnu packages bash) + #:use-module (gnu packages guile) #:use-module (gnu packages hurd) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -585,28 +586,29 @@ ACTIVATION-SCRIPT-TYPE." (with-imported-modules (source-module-closure '((gnu build activation) (guix build utils))) - #~(begin - (use-modules (gnu build activation) - (guix build utils)) - - ;; Make sure the user accounting database exists. If it - ;; does not exist, 'setutxent' does not create it and - ;; thus there is no accounting at all. - (close-port (open-file "/var/run/utmpx" "a0")) - - ;; Same for 'wtmp', which is populated by mingetty et - ;; al. - (mkdir-p "/var/log") - (close-port (open-file "/var/log/wtmp" "a0")) - - ;; Set up /run/current-system. Among other things this - ;; sets up locales, which the activation snippets - ;; executed below may expect. - (activate-current-system) - - ;; Run the services' activation snippets. - ;; TODO: Use 'load-compiled'. - (for-each primitive-load '#$actions))))) + (with-extensions (list guile-zlib) + #~(begin + (use-modules (gnu build activation) + (guix build utils)) + + ;; Make sure the user accounting database exists. If + ;; it does not exist, 'setutxent' does not create it + ;; and thus there is no accounting at all. + (close-port (open-file "/var/run/utmpx" "a0")) + + ;; Same for 'wtmp', which is populated by mingetty et + ;; al. + (mkdir-p "/var/log") + (close-port (open-file "/var/log/wtmp" "a0")) + + ;; Set up /run/current-system. Among other things + ;; this sets up locales, which the activation snippets + ;; executed below may expect. + (activate-current-system) + + ;; Run the services' activation snippets. + ;; TODO: Use 'load-compiled'. + (for-each primitive-load '#$actions)))))) (define (gexps->activation-gexp gexps) "Return a gexp that runs the activation script containing GEXPS." diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 491f35702a..966e7fe024 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -50,6 +50,7 @@ #:select (coreutils glibc glibc-utf8-locales)) #:use-module (gnu packages package-management) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) + #:use-module ((gnu packages guile) #:select (guile-zlib)) #:use-module (gnu packages linux) #:use-module (gnu packages terminals) #:use-module ((gnu build file-systems) @@ -836,36 +837,38 @@ the message of the day, among other things." to use as the tty. This is primarily useful for headless systems." (with-imported-modules (source-module-closure '((gnu build linux-boot))) ;for 'find-long-options' - #~(begin - ;; console=device,options - ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). - ;; options: BBBBPNF. P n|o|e, N number of bits, - ;; F flow control (r RTS) - (let* ((not-comma (char-set-complement (char-set #\,))) - (command (linux-command-line)) - (agetty-specs (find-long-options "agetty.tty" command)) - (console-specs (filter (lambda (spec) - (and (string-prefix? "tty" spec) - (not (or - (string-prefix? "tty0" spec) - (string-prefix? "tty1" spec) - (string-prefix? "tty2" spec) - (string-prefix? "tty3" spec) - (string-prefix? "tty4" spec) - (string-prefix? "tty5" spec) - (string-prefix? "tty6" spec) - (string-prefix? "tty7" spec) - (string-prefix? "tty8" spec) - (string-prefix? "tty9" spec))))) - (find-long-options "console" command))) - (specs (append agetty-specs console-specs))) - (match specs - (() #f) - ((spec _ ...) - ;; Extract device name from first spec. - (match (string-tokenize spec not-comma) - ((device-name _ ...) - device-name)))))))) + (with-extensions (list guile-zlib) + #~(begin + ;; console=device,options + ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). + ;; options: BBBBPNF. P n|o|e, N number of bits, + ;; F flow control (r RTS) + (let* ((not-comma (char-set-complement (char-set #\,))) + (command (linux-command-line)) + (agetty-specs (find-long-options "agetty.tty" command)) + (console-specs + (filter (lambda (spec) + (and (string-prefix? "tty" spec) + (not (or + (string-prefix? "tty0" spec) + (string-prefix? "tty1" spec) + (string-prefix? "tty2" spec) + (string-prefix? "tty3" spec) + (string-prefix? "tty4" spec) + (string-prefix? "tty5" spec) + (string-prefix? "tty6" spec) + (string-prefix? "tty7" spec) + (string-prefix? "tty8" spec) + (string-prefix? "tty9" spec))))) + (find-long-options "console" command))) + (specs (append agetty-specs console-specs))) + (match specs + (() #f) + ((spec _ ...) + ;; Extract device name from first spec. + (match (string-tokenize spec not-comma) + ((device-name _ ...) + device-name))))))))) (define agetty-shepherd-service (match-lambda @@ -890,122 +893,124 @@ to use as the tty. This is primarily useful for headless systems." (start (with-imported-modules (source-module-closure '((gnu build linux-boot))) - #~(lambda args - (let ((defaulted-tty #$(or tty (default-serial-port)))) - (apply - (if defaulted-tty - (make-forkexec-constructor - (list #$(file-append util-linux "/sbin/agetty") - #$@extra-options - #$@(if eight-bits? - #~("--8bits") - #~()) - #$@(if no-reset? - #~("--noreset") - #~()) - #$@(if remote? - #~("--remote") - #~()) - #$@(if flow-control? - #~("--flow-control") - #~()) - #$@(if host - #~("--host" #$host) - #~()) - #$@(if no-issue? - #~("--noissue") - #~()) - #$@(if init-string - #~("--init-string" #$init-string) - #~()) - #$@(if no-clear? - #~("--noclear") - #~()) -;;; FIXME This doesn't work as expected. According to agetty(8), if this option -;;; is not passed, then the default is 'auto'. However, in my tests, when that -;;; option is selected, agetty never presents the login prompt, and the -;;; term-ttyS0 service respawns every few seconds. - #$@(if local-line - #~(#$(match local-line - ('auto "--local-line=auto") - ('always "--local-line=always") - ('never "-local-line=never"))) - #~()) - #$@(if tty - #~() - #~("--keep-baud")) - #$@(if extract-baud? - #~("--extract-baud") - #~()) - #$@(if skip-login? - #~("--skip-login") - #~()) - #$@(if no-newline? - #~("--nonewline") - #~()) - #$@(if login-options - #~("--login-options" #$login-options) - #~()) - #$@(if chroot - #~("--chroot" #$chroot) - #~()) - #$@(if hangup? - #~("--hangup") - #~()) - #$@(if keep-baud? - #~("--keep-baud") - #~()) - #$@(if timeout - #~("--timeout" #$(number->string timeout)) - #~()) - #$@(if detect-case? - #~("--detect-case") - #~()) - #$@(if wait-cr? - #~("--wait-cr") - #~()) - #$@(if no-hints? - #~("--nohints?") - #~()) - #$@(if no-hostname? - #~("--nohostname") - #~()) - #$@(if long-hostname? - #~("--long-hostname") - #~()) - #$@(if erase-characters - #~("--erase-chars" #$erase-characters) - #~()) - #$@(if kill-characters - #~("--kill-chars" #$kill-characters) - #~()) - #$@(if chdir - #~("--chdir" #$chdir) - #~()) - #$@(if delay - #~("--delay" #$(number->string delay)) - #~()) - #$@(if nice - #~("--nice" #$(number->string nice)) - #~()) - #$@(if auto-login - (list "--autologin" auto-login) - '()) - #$@(if login-program - #~("--login-program" #$login-program) - #~()) - #$@(if login-pause? - #~("--login-pause") - #~()) - defaulted-tty - #$@(if baud-rate - #~(#$baud-rate) - #~()) - #$@(if term - #~(#$term) - #~()))) - (const #f)) ; never start. - args))))) + (with-extensions (list guile-zlib) + #~(lambda args + (let ((defaulted-tty #$(or tty (default-serial-port)))) + (apply + (if defaulted-tty + (make-forkexec-constructor + (list #$(file-append util-linux "/sbin/agetty") + #$@extra-options + #$@(if eight-bits? + #~("--8bits") + #~()) + #$@(if no-reset? + #~("--noreset") + #~()) + #$@(if remote? + #~("--remote") + #~()) + #$@(if flow-control? + #~("--flow-control") + #~()) + #$@(if host + #~("--host" #$host) + #~()) + #$@(if no-issue? + #~("--noissue") + #~()) + #$@(if init-string + #~("--init-string" #$init-string) + #~()) + #$@(if no-clear? + #~("--noclear") + #~()) +;;; FIXME This doesn't work as expected. According to agetty(8), if this +;;; option is not passed, then the default is 'auto'. However, in my tests, +;;; when that option is selected, agetty never presents the login prompt, and +;;; the term-ttyS0 service respawns every few seconds. + #$@(if local-line + #~(#$(match local-line + ('auto "--local-line=auto") + ('always "--local-line=always") + ('never "-local-line=never"))) + #~()) + #$@(if tty + #~() + #~("--keep-baud")) + #$@(if extract-baud? + #~("--extract-baud") + #~()) + #$@(if skip-login? + #~("--skip-login") + #~()) + #$@(if no-newline? + #~("--nonewline") + #~()) + #$@(if login-options + #~("--login-options" #$login-options) + #~()) + #$@(if chroot + #~("--chroot" #$chroot) + #~()) + #$@(if hangup? + #~("--hangup") + #~()) + #$@(if keep-baud? + #~("--keep-baud") + #~()) + #$@(if timeout + #~("--timeout" + #$(number->string timeout)) + #~()) + #$@(if detect-case? + #~("--detect-case") + #~()) + #$@(if wait-cr? + #~("--wait-cr") + #~()) + #$@(if no-hints? + #~("--nohints?") + #~()) + #$@(if no-hostname? + #~("--nohostname") + #~()) + #$@(if long-hostname? + #~("--long-hostname") + #~()) + #$@(if erase-characters + #~("--erase-chars" #$erase-characters) + #~()) + #$@(if kill-characters + #~("--kill-chars" #$kill-characters) + #~()) + #$@(if chdir + #~("--chdir" #$chdir) + #~()) + #$@(if delay + #~("--delay" #$(number->string delay)) + #~()) + #$@(if nice + #~("--nice" #$(number->string nice)) + #~()) + #$@(if auto-login + (list "--autologin" auto-login) + '()) + #$@(if login-program + #~("--login-program" #$login-program) + #~()) + #$@(if login-pause? + #~("--login-pause") + #~()) + defaulted-tty + #$@(if baud-rate + #~(#$baud-rate) + #~()) + #$@(if term + #~(#$term) + #~()))) + (const #f)) ; never start. + args)))))) (stop #~(make-kill-destructor))))))) (define agetty-service-type @@ -1939,70 +1944,73 @@ item of @var{packages}." (start (with-imported-modules (source-module-closure '((gnu build linux-boot))) - #~(lambda () - (define udevd - ;; 'udevd' from eudev. - #$(file-append udev "/sbin/udevd")) - - (define (wait-for-udevd) - ;; Wait until someone's listening on udevd's control - ;; socket. - (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) - (let try () - (catch 'system-error - (lambda () - (connect sock PF_UNIX "/run/udev/control") - (close-port sock)) - (lambda args - (format #t "waiting for udevd...~%") - (usleep 500000) - (try)))))) - - ;; Allow udev to find the modules. - (setenv "LINUX_MODULE_DIRECTORY" - "/run/booted-system/kernel/lib/modules") - - (let* ((kernel-release - (utsname:release (uname))) - (linux-module-directory - (getenv "LINUX_MODULE_DIRECTORY")) - (directory - (string-append linux-module-directory "/" - kernel-release)) - (old-umask (umask #o022))) - ;; If we're in a container, DIRECTORY might not exist, - ;; for instance because the host runs a different - ;; kernel. In that case, skip it; we'll just miss a few - ;; nodes like /dev/fuse. - (when (file-exists? directory) - (make-static-device-nodes directory)) - (umask old-umask)) - - (let ((pid (fork+exec-command (list udevd) - #:environment-variables - (cons* - ;; The first one is for udev, the second one for - ;; eudev. - (string-append "UDEV_CONFIG_FILE=" #$udev.conf) - (string-append "EUDEV_RULES_DIRECTORY=" - #$(file-append - rules "/lib/udev/rules.d")) - (string-append "LINUX_MODULE_DIRECTORY=" - (getenv "LINUX_MODULE_DIRECTORY")) - (default-environment-variables))))) - ;; Wait until udevd is up and running. This appears to - ;; be needed so that the events triggered below are - ;; actually handled. - (wait-for-udevd) - - ;; Trigger device node creation. - (system* #$(file-append udev "/bin/udevadm") - "trigger" "--action=add") - - ;; Wait for things to settle down. - (system* #$(file-append udev "/bin/udevadm") - "settle") - pid)))) + (with-extensions (list guile-zlib) + #~(lambda () + (define udevd + ;; 'udevd' from eudev. + #$(file-append udev "/sbin/udevd")) + + (define (wait-for-udevd) + ;; Wait until someone's listening on udevd's control + ;; socket. + (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) + (let try () + (catch 'system-error + (lambda () + (connect sock PF_UNIX "/run/udev/control") + (close-port sock)) + (lambda args + (format #t "waiting for udevd...~%") + (usleep 500000) + (try)))))) + + ;; Allow udev to find the modules. + (setenv "LINUX_MODULE_DIRECTORY" + "/run/booted-system/kernel/lib/modules") + + (let* ((kernel-release + (utsname:release (uname))) + (linux-module-directory + (getenv "LINUX_MODULE_DIRECTORY")) + (directory + (string-append linux-module-directory "/" + kernel-release)) + (old-umask (umask #o022))) + ;; If we're in a container, DIRECTORY might not exist, + ;; for instance because the host runs a different + ;; kernel. In that case, skip it; we'll just miss a few + ;; nodes like /dev/fuse. + (when (file-exists? directory) + (make-static-device-nodes directory)) + (umask old-umask)) + + (let ((pid + (fork+exec-command + (list udevd) + #:environment-variables + (cons* + ;; The first one is for udev, the second one for + ;; eudev. + (string-append "UDEV_CONFIG_FILE=" #$udev.conf) + (string-append "EUDEV_RULES_DIRECTORY=" + #$(file-append + rules "/lib/udev/rules.d")) + (string-append "LINUX_MODULE_DIRECTORY=" + (getenv "LINUX_MODULE_DIRECTORY")) + (default-environment-variables))))) + ;; Wait until udevd is up and running. This appears to + ;; be needed so that the events triggered below are + ;; actually handled. + (wait-for-udevd) + + ;; Trigger device node creation. + (system* #$(file-append udev "/bin/udevadm") + "trigger" "--action=add") + + ;; Wait for things to settle down. + (system* #$(file-append udev "/bin/udevadm") + "settle") + pid))))) (stop #~(make-kill-destructor)) ;; When halting the system, 'udev' is actually killed by diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 36f56e237d..19c99a3dfa 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -141,7 +141,7 @@ (match (package-transitive-propagated-inputs package) (((labels packages) ...) packages)))) - (list guile-gcrypt guile-sqlite3))) + (list guile-gcrypt guile-sqlite3 guile-zlib))) (define-syntax-rule (with-imported-modules* gexp* ...) (with-extensions gcrypt-sqlite3&co diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 0971ec29e2..b8a30c0abc 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -77,6 +77,9 @@ the derivations referenced by EXP are automatically copied to the initrd." (program-file "init" exp #:guile guile)) (define builder + ;; Do not use "guile-zlib" extension here, otherwise it would drag the + ;; non-static "zlib" package to the initrd closure. It is not needed + ;; anyway because the modules are stored uncompressed within the initrd. (with-imported-modules (source-module-closure '((gnu build linux-initrd))) #~(begin @@ -111,34 +114,49 @@ the derivations referenced by EXP are automatically copied to the initrd." (define (flat-linux-module-directory linux modules) "Return a flat directory containing the Linux kernel modules listed in MODULES and taken from LINUX." - (define build-exp - (with-imported-modules (source-module-closure - '((gnu build linux-modules))) - #~(begin - (use-modules (gnu build linux-modules) - (srfi srfi-1) - (srfi srfi-26)) - - (define module-dir - (string-append #$linux "/lib/modules")) + (define imported-modules + (source-module-closure '((gnu build linux-modules) + (guix build utils)))) - (define modules - (let* ((lookup (cut find-module-file module-dir <>)) - (modules (map lookup '#$modules))) - (append modules - (recursive-module-dependencies modules - #:lookup-module lookup)))) - - (mkdir #$output) - (for-each (lambda (module) - (format #t "copying '~a'...~%" module) - (copy-file module - (string-append #$output "/" - (basename module)))) - (delete-duplicates modules)) - - ;; Hyphen or underscore? This database tells us. - (write-module-name-database #$output)))) + (define build-exp + (with-imported-modules imported-modules + (with-extensions (list guile-zlib) + #~(begin + (use-modules (gnu build linux-modules) + (guix build utils) + (srfi srfi-1) + (srfi srfi-26)) + + (define module-dir + (string-append #$linux "/lib/modules")) + + (define modules + (let* ((lookup (cut find-module-file module-dir <>)) + (modules (map lookup '#$modules))) + (append modules + (recursive-module-dependencies + modules + #:lookup-module lookup)))) + + (define (maybe-uncompress file) + ;; If FILE is a compressed module, uncompress it, as the initrd + ;; is already gzipped as a whole. + (cond + ((string-contains file ".ko.gz") + (invoke #+(file-append gzip "/bin/gunzip") file)))) + + (mkdir #$output) + (for-each (lambda (module) + (let ((out-module + (string-append #$output "/" + (basename module)))) + (format #t "copying '~a'...~%" module) + (copy-file module out-module) + (maybe-uncompress out-module))) + (delete-duplicates modules)) + + ;; Hyphen or underscore? This database tells us. + (write-module-name-database #$output))))) (computed-file "linux-modules" build-exp)) diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index a69339bc07..f642d250b0 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -34,6 +34,7 @@ #:use-module ((gnu packages admin) #:select (shadow)) #:use-module (gnu packages bash) + #:use-module (gnu packages guile) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -324,11 +325,12 @@ accounts among ACCOUNTS+GROUPS." (start (with-imported-modules (source-module-closure '((gnu build activation) (gnu system accounts))) - #~(lambda () - (activate-user-home - (map sexp->user-account - (list #$@(map user-account->gexp accounts)))) - #t))) ;success + (with-extensions (list guile-zlib) + #~(lambda () + (activate-user-home + (map sexp->user-account + (list #$@(map user-account->gexp accounts)))) + #t)))) ;success (documentation "Create user home directories.")))) (define (shells-file shells) diff --git a/guix/profiles.scm b/guix/profiles.scm index 6b2344270e..856a05eed1 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1205,43 +1205,48 @@ and creates the dependency graph of all these kernel modules. This is meant to be used as a profile hook." (define kmod ; lazy reference (module-ref (resolve-interface '(gnu packages linux)) 'kmod)) + + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) + (define build (with-imported-modules (source-module-closure '((guix build utils) (gnu build linux-modules))) - #~(begin - (use-modules (ice-9 ftw) - (ice-9 match) - (srfi srfi-1) ; append-map - (gnu build linux-modules)) - - (let* ((inputs '#$(manifest-inputs manifest)) - (module-directories - (map (lambda (directory) - (string-append directory "/lib/modules")) - inputs)) - (directory-entries - (lambda (directory) - (or (scandir directory - (lambda (basename) - (not (string-prefix? "." basename)))) - '()))) - ;; Note: Should usually result in one entry. - (versions (delete-duplicates - (append-map directory-entries - module-directories)))) - (match versions - ((version) - (let ((old-path (getenv "PATH"))) - (setenv "PATH" #+(file-append kmod "/bin")) - (make-linux-module-directory inputs version #$output) - (setenv "PATH" old-path))) - (() - ;; Nothing here, maybe because this is a kernel with - ;; CONFIG_MODULES=n. - (mkdir #$output)) - (_ (error "Specified Linux kernel and Linux kernel modules -are not all of the same version"))))))) + (with-extensions (list guile-zlib) + #~(begin + (use-modules (ice-9 ftw) + (ice-9 match) + (srfi srfi-1) ; append-map + (gnu build linux-modules)) + + (let* ((inputs '#$(manifest-inputs manifest)) + (module-directories + (map (lambda (directory) + (string-append directory "/lib/modules")) + inputs)) + (directory-entries + (lambda (directory) + (or (scandir directory + (lambda (basename) + (not (string-prefix? "." basename)))) + '()))) + ;; Note: Should usually result in one entry. + (versions (delete-duplicates + (append-map directory-entries + module-directories)))) + (match versions + ((version) + (let ((old-path (getenv "PATH"))) + (setenv "PATH" #+(file-append kmod "/bin")) + (make-linux-module-directory inputs version #$output) + (setenv "PATH" old-path))) + (() + ;; Nothing here, maybe because this is a kernel with + ;; CONFIG_MODULES=n. + (mkdir #$output)) + (_ (error "Specified Linux kernel and Linux kernel modules +are not all of the same version")))))))) (gexp->derivation "linux-module-database" build #:local-build? #t #:substitutable? #f -- cgit 1.4.1 From dac7dd1b0b40c9f8c81b5147c68f6387c2b16bfd Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 25 Aug 2020 12:39:11 +0200 Subject: Remove "guile-zlib" extension when unused. This is a follow-up of 755f365b02b42a5d1e8ef3000dadef069553a478. As (zlib) is autoloaded in (gnu build linux-modules), "guile-zlib" is needed as an extension only when it is effectively used. * gnu/installer.scm (installer-program): Remove "guile-zlib" from the extensions. * gnu/machine/ssh.scm (machine-check-initrd-modules): Ditto. * gnu/services.scm (activation-script): Ditto. * gnu/services/base.scm (default-serial-port): Ditto, (agetty-shepherd-service): ditto, (udev-service-type): ditto. * gnu/system/image.scm (gcrypt-sqlite3&co): Ditto. * gnu/system/shadow.scm (account-shepherd-service): Ditto. --- gnu/installer.scm | 3 +- gnu/machine/ssh.scm | 35 ++--- gnu/services.scm | 46 +++--- gnu/services/base.scm | 428 +++++++++++++++++++++++++------------------------- gnu/system/image.scm | 2 +- gnu/system/shadow.scm | 12 +- 6 files changed, 255 insertions(+), 271 deletions(-) (limited to 'gnu/system') diff --git a/gnu/installer.scm b/gnu/installer.scm index 576ac90a4b..5c3192d7a6 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -342,8 +342,7 @@ selected keymap." ;; packages …), etc. modules. (with-extensions (list guile-gcrypt guile-newt guile-parted guile-bytestructures - guile-json-3 guile-git guile-zlib - guix) + guile-json-3 guile-git guix) (with-imported-modules `(,@(source-module-closure `(,@modules (gnu services herd) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index ee5032e281..4e31baa4b9 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -21,7 +21,6 @@ #:use-module (gnu bootloader) #:use-module (gnu machine) #:autoload (gnu packages gnupg) (guile-gcrypt) - #:autoload (gnu packages guile) (guile-zlib) #:use-module (gnu system) #:use-module (gnu system file-systems) #:use-module (gnu system uuid) @@ -249,24 +248,22 @@ not available in the initrd." '((gnu build file-systems) (gnu build linux-modules) (gnu system uuid))) - (with-extensions (list guile-zlib) - #~(begin - (use-modules (gnu build file-systems) - (gnu build linux-modules) - (gnu system uuid)) - - (define dev - #$(cond ((string? device) device) - ((uuid? device) #~(find-partition-by-uuid - (string->uuid - #$(uuid->string device)))) - ((file-system-label? device) - #~(find-partition-by-label - #$(file-system-label->string device))))) - - (missing-modules dev - '#$(operating-system-initrd-modules - (machine-operating-system machine)))))))) + #~(begin + (use-modules (gnu build file-systems) + (gnu build linux-modules) + (gnu system uuid)) + + (define dev + #$(cond ((string? device) device) + ((uuid? device) #~(find-partition-by-uuid + (string->uuid + #$(uuid->string device)))) + ((file-system-label? device) + #~(find-partition-by-label + #$(file-system-label->string device))))) + + (missing-modules dev '#$(operating-system-initrd-modules + (machine-operating-system machine))))))) (remote-let ((missing remote-exp)) (unless (null? missing) diff --git a/gnu/services.scm b/gnu/services.scm index 3e59c6401f..11ba21e824 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -35,7 +35,6 @@ #:use-module (guix modules) #:use-module (gnu packages base) #:use-module (gnu packages bash) - #:use-module (gnu packages guile) #:use-module (gnu packages hurd) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -586,29 +585,28 @@ ACTIVATION-SCRIPT-TYPE." (with-imported-modules (source-module-closure '((gnu build activation) (guix build utils))) - (with-extensions (list guile-zlib) - #~(begin - (use-modules (gnu build activation) - (guix build utils)) - - ;; Make sure the user accounting database exists. If - ;; it does not exist, 'setutxent' does not create it - ;; and thus there is no accounting at all. - (close-port (open-file "/var/run/utmpx" "a0")) - - ;; Same for 'wtmp', which is populated by mingetty et - ;; al. - (mkdir-p "/var/log") - (close-port (open-file "/var/log/wtmp" "a0")) - - ;; Set up /run/current-system. Among other things - ;; this sets up locales, which the activation snippets - ;; executed below may expect. - (activate-current-system) - - ;; Run the services' activation snippets. - ;; TODO: Use 'load-compiled'. - (for-each primitive-load '#$actions)))))) + #~(begin + (use-modules (gnu build activation) + (guix build utils)) + + ;; Make sure the user accounting database exists. If it + ;; does not exist, 'setutxent' does not create it and + ;; thus there is no accounting at all. + (close-port (open-file "/var/run/utmpx" "a0")) + + ;; Same for 'wtmp', which is populated by mingetty et + ;; al. + (mkdir-p "/var/log") + (close-port (open-file "/var/log/wtmp" "a0")) + + ;; Set up /run/current-system. Among other things this + ;; sets up locales, which the activation snippets + ;; executed below may expect. + (activate-current-system) + + ;; Run the services' activation snippets. + ;; TODO: Use 'load-compiled'. + (for-each primitive-load '#$actions))))) (define (gexps->activation-gexp gexps) "Return a gexp that runs the activation script containing GEXPS." diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 966e7fe024..491f35702a 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -50,7 +50,6 @@ #:select (coreutils glibc glibc-utf8-locales)) #:use-module (gnu packages package-management) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) - #:use-module ((gnu packages guile) #:select (guile-zlib)) #:use-module (gnu packages linux) #:use-module (gnu packages terminals) #:use-module ((gnu build file-systems) @@ -837,38 +836,36 @@ the message of the day, among other things." to use as the tty. This is primarily useful for headless systems." (with-imported-modules (source-module-closure '((gnu build linux-boot))) ;for 'find-long-options' - (with-extensions (list guile-zlib) - #~(begin - ;; console=device,options - ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). - ;; options: BBBBPNF. P n|o|e, N number of bits, - ;; F flow control (r RTS) - (let* ((not-comma (char-set-complement (char-set #\,))) - (command (linux-command-line)) - (agetty-specs (find-long-options "agetty.tty" command)) - (console-specs - (filter (lambda (spec) - (and (string-prefix? "tty" spec) - (not (or - (string-prefix? "tty0" spec) - (string-prefix? "tty1" spec) - (string-prefix? "tty2" spec) - (string-prefix? "tty3" spec) - (string-prefix? "tty4" spec) - (string-prefix? "tty5" spec) - (string-prefix? "tty6" spec) - (string-prefix? "tty7" spec) - (string-prefix? "tty8" spec) - (string-prefix? "tty9" spec))))) - (find-long-options "console" command))) - (specs (append agetty-specs console-specs))) - (match specs - (() #f) - ((spec _ ...) - ;; Extract device name from first spec. - (match (string-tokenize spec not-comma) - ((device-name _ ...) - device-name))))))))) + #~(begin + ;; console=device,options + ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). + ;; options: BBBBPNF. P n|o|e, N number of bits, + ;; F flow control (r RTS) + (let* ((not-comma (char-set-complement (char-set #\,))) + (command (linux-command-line)) + (agetty-specs (find-long-options "agetty.tty" command)) + (console-specs (filter (lambda (spec) + (and (string-prefix? "tty" spec) + (not (or + (string-prefix? "tty0" spec) + (string-prefix? "tty1" spec) + (string-prefix? "tty2" spec) + (string-prefix? "tty3" spec) + (string-prefix? "tty4" spec) + (string-prefix? "tty5" spec) + (string-prefix? "tty6" spec) + (string-prefix? "tty7" spec) + (string-prefix? "tty8" spec) + (string-prefix? "tty9" spec))))) + (find-long-options "console" command))) + (specs (append agetty-specs console-specs))) + (match specs + (() #f) + ((spec _ ...) + ;; Extract device name from first spec. + (match (string-tokenize spec not-comma) + ((device-name _ ...) + device-name)))))))) (define agetty-shepherd-service (match-lambda @@ -893,124 +890,122 @@ to use as the tty. This is primarily useful for headless systems." (start (with-imported-modules (source-module-closure '((gnu build linux-boot))) - (with-extensions (list guile-zlib) - #~(lambda args - (let ((defaulted-tty #$(or tty (default-serial-port)))) - (apply - (if defaulted-tty - (make-forkexec-constructor - (list #$(file-append util-linux "/sbin/agetty") - #$@extra-options - #$@(if eight-bits? - #~("--8bits") - #~()) - #$@(if no-reset? - #~("--noreset") - #~()) - #$@(if remote? - #~("--remote") - #~()) - #$@(if flow-control? - #~("--flow-control") - #~()) - #$@(if host - #~("--host" #$host) - #~()) - #$@(if no-issue? - #~("--noissue") - #~()) - #$@(if init-string - #~("--init-string" #$init-string) - #~()) - #$@(if no-clear? - #~("--noclear") - #~()) -;;; FIXME This doesn't work as expected. According to agetty(8), if this -;;; option is not passed, then the default is 'auto'. However, in my tests, -;;; when that option is selected, agetty never presents the login prompt, and -;;; the term-ttyS0 service respawns every few seconds. - #$@(if local-line - #~(#$(match local-line - ('auto "--local-line=auto") - ('always "--local-line=always") - ('never "-local-line=never"))) - #~()) - #$@(if tty - #~() - #~("--keep-baud")) - #$@(if extract-baud? - #~("--extract-baud") - #~()) - #$@(if skip-login? - #~("--skip-login") - #~()) - #$@(if no-newline? - #~("--nonewline") - #~()) - #$@(if login-options - #~("--login-options" #$login-options) - #~()) - #$@(if chroot - #~("--chroot" #$chroot) - #~()) - #$@(if hangup? - #~("--hangup") - #~()) - #$@(if keep-baud? - #~("--keep-baud") - #~()) - #$@(if timeout - #~("--timeout" - #$(number->string timeout)) - #~()) - #$@(if detect-case? - #~("--detect-case") - #~()) - #$@(if wait-cr? - #~("--wait-cr") - #~()) - #$@(if no-hints? - #~("--nohints?") - #~()) - #$@(if no-hostname? - #~("--nohostname") - #~()) - #$@(if long-hostname? - #~("--long-hostname") - #~()) - #$@(if erase-characters - #~("--erase-chars" #$erase-characters) - #~()) - #$@(if kill-characters - #~("--kill-chars" #$kill-characters) - #~()) - #$@(if chdir - #~("--chdir" #$chdir) - #~()) - #$@(if delay - #~("--delay" #$(number->string delay)) - #~()) - #$@(if nice - #~("--nice" #$(number->string nice)) - #~()) - #$@(if auto-login - (list "--autologin" auto-login) - '()) - #$@(if login-program - #~("--login-program" #$login-program) - #~()) - #$@(if login-pause? - #~("--login-pause") - #~()) - defaulted-tty - #$@(if baud-rate - #~(#$baud-rate) - #~()) - #$@(if term - #~(#$term) - #~()))) - (const #f)) ; never start. - args)))))) + #~(lambda args + (let ((defaulted-tty #$(or tty (default-serial-port)))) + (apply + (if defaulted-tty + (make-forkexec-constructor + (list #$(file-append util-linux "/sbin/agetty") + #$@extra-options + #$@(if eight-bits? + #~("--8bits") + #~()) + #$@(if no-reset? + #~("--noreset") + #~()) + #$@(if remote? + #~("--remote") + #~()) + #$@(if flow-control? + #~("--flow-control") + #~()) + #$@(if host + #~("--host" #$host) + #~()) + #$@(if no-issue? + #~("--noissue") + #~()) + #$@(if init-string + #~("--init-string" #$init-string) + #~()) + #$@(if no-clear? + #~("--noclear") + #~()) +;;; FIXME This doesn't work as expected. According to agetty(8), if this option +;;; is not passed, then the default is 'auto'. However, in my tests, when that +;;; option is selected, agetty never presents the login prompt, and the +;;; term-ttyS0 service respawns every few seconds. + #$@(if local-line + #~(#$(match local-line + ('auto "--local-line=auto") + ('always "--local-line=always") + ('never "-local-line=never"))) + #~()) + #$@(if tty + #~() + #~("--keep-baud")) + #$@(if extract-baud? + #~("--extract-baud") + #~()) + #$@(if skip-login? + #~("--skip-login") + #~()) + #$@(if no-newline? + #~("--nonewline") + #~()) + #$@(if login-options + #~("--login-options" #$login-options) + #~()) + #$@(if chroot + #~("--chroot" #$chroot) + #~()) + #$@(if hangup? + #~("--hangup") + #~()) + #$@(if keep-baud? + #~("--keep-baud") + #~()) + #$@(if timeout + #~("--timeout" #$(number->string timeout)) + #~()) + #$@(if detect-case? + #~("--detect-case") + #~()) + #$@(if wait-cr? + #~("--wait-cr") + #~()) + #$@(if no-hints? + #~("--nohints?") + #~()) + #$@(if no-hostname? + #~("--nohostname") + #~()) + #$@(if long-hostname? + #~("--long-hostname") + #~()) + #$@(if erase-characters + #~("--erase-chars" #$erase-characters) + #~()) + #$@(if kill-characters + #~("--kill-chars" #$kill-characters) + #~()) + #$@(if chdir + #~("--chdir" #$chdir) + #~()) + #$@(if delay + #~("--delay" #$(number->string delay)) + #~()) + #$@(if nice + #~("--nice" #$(number->string nice)) + #~()) + #$@(if auto-login + (list "--autologin" auto-login) + '()) + #$@(if login-program + #~("--login-program" #$login-program) + #~()) + #$@(if login-pause? + #~("--login-pause") + #~()) + defaulted-tty + #$@(if baud-rate + #~(#$baud-rate) + #~()) + #$@(if term + #~(#$term) + #~()))) + (const #f)) ; never start. + args))))) (stop #~(make-kill-destructor))))))) (define agetty-service-type @@ -1944,73 +1939,70 @@ item of @var{packages}." (start (with-imported-modules (source-module-closure '((gnu build linux-boot))) - (with-extensions (list guile-zlib) - #~(lambda () - (define udevd - ;; 'udevd' from eudev. - #$(file-append udev "/sbin/udevd")) - - (define (wait-for-udevd) - ;; Wait until someone's listening on udevd's control - ;; socket. - (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) - (let try () - (catch 'system-error - (lambda () - (connect sock PF_UNIX "/run/udev/control") - (close-port sock)) - (lambda args - (format #t "waiting for udevd...~%") - (usleep 500000) - (try)))))) - - ;; Allow udev to find the modules. - (setenv "LINUX_MODULE_DIRECTORY" - "/run/booted-system/kernel/lib/modules") - - (let* ((kernel-release - (utsname:release (uname))) - (linux-module-directory - (getenv "LINUX_MODULE_DIRECTORY")) - (directory - (string-append linux-module-directory "/" - kernel-release)) - (old-umask (umask #o022))) - ;; If we're in a container, DIRECTORY might not exist, - ;; for instance because the host runs a different - ;; kernel. In that case, skip it; we'll just miss a few - ;; nodes like /dev/fuse. - (when (file-exists? directory) - (make-static-device-nodes directory)) - (umask old-umask)) - - (let ((pid - (fork+exec-command - (list udevd) - #:environment-variables - (cons* - ;; The first one is for udev, the second one for - ;; eudev. - (string-append "UDEV_CONFIG_FILE=" #$udev.conf) - (string-append "EUDEV_RULES_DIRECTORY=" - #$(file-append - rules "/lib/udev/rules.d")) - (string-append "LINUX_MODULE_DIRECTORY=" - (getenv "LINUX_MODULE_DIRECTORY")) - (default-environment-variables))))) - ;; Wait until udevd is up and running. This appears to - ;; be needed so that the events triggered below are - ;; actually handled. - (wait-for-udevd) - - ;; Trigger device node creation. - (system* #$(file-append udev "/bin/udevadm") - "trigger" "--action=add") - - ;; Wait for things to settle down. - (system* #$(file-append udev "/bin/udevadm") - "settle") - pid))))) + #~(lambda () + (define udevd + ;; 'udevd' from eudev. + #$(file-append udev "/sbin/udevd")) + + (define (wait-for-udevd) + ;; Wait until someone's listening on udevd's control + ;; socket. + (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) + (let try () + (catch 'system-error + (lambda () + (connect sock PF_UNIX "/run/udev/control") + (close-port sock)) + (lambda args + (format #t "waiting for udevd...~%") + (usleep 500000) + (try)))))) + + ;; Allow udev to find the modules. + (setenv "LINUX_MODULE_DIRECTORY" + "/run/booted-system/kernel/lib/modules") + + (let* ((kernel-release + (utsname:release (uname))) + (linux-module-directory + (getenv "LINUX_MODULE_DIRECTORY")) + (directory + (string-append linux-module-directory "/" + kernel-release)) + (old-umask (umask #o022))) + ;; If we're in a container, DIRECTORY might not exist, + ;; for instance because the host runs a different + ;; kernel. In that case, skip it; we'll just miss a few + ;; nodes like /dev/fuse. + (when (file-exists? directory) + (make-static-device-nodes directory)) + (umask old-umask)) + + (let ((pid (fork+exec-command (list udevd) + #:environment-variables + (cons* + ;; The first one is for udev, the second one for + ;; eudev. + (string-append "UDEV_CONFIG_FILE=" #$udev.conf) + (string-append "EUDEV_RULES_DIRECTORY=" + #$(file-append + rules "/lib/udev/rules.d")) + (string-append "LINUX_MODULE_DIRECTORY=" + (getenv "LINUX_MODULE_DIRECTORY")) + (default-environment-variables))))) + ;; Wait until udevd is up and running. This appears to + ;; be needed so that the events triggered below are + ;; actually handled. + (wait-for-udevd) + + ;; Trigger device node creation. + (system* #$(file-append udev "/bin/udevadm") + "trigger" "--action=add") + + ;; Wait for things to settle down. + (system* #$(file-append udev "/bin/udevadm") + "settle") + pid)))) (stop #~(make-kill-destructor)) ;; When halting the system, 'udev' is actually killed by diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 19c99a3dfa..36f56e237d 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -141,7 +141,7 @@ (match (package-transitive-propagated-inputs package) (((labels packages) ...) packages)))) - (list guile-gcrypt guile-sqlite3 guile-zlib))) + (list guile-gcrypt guile-sqlite3))) (define-syntax-rule (with-imported-modules* gexp* ...) (with-extensions gcrypt-sqlite3&co diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index f642d250b0..a69339bc07 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -34,7 +34,6 @@ #:use-module ((gnu packages admin) #:select (shadow)) #:use-module (gnu packages bash) - #:use-module (gnu packages guile) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -325,12 +324,11 @@ accounts among ACCOUNTS+GROUPS." (start (with-imported-modules (source-module-closure '((gnu build activation) (gnu system accounts))) - (with-extensions (list guile-zlib) - #~(lambda () - (activate-user-home - (map sexp->user-account - (list #$@(map user-account->gexp accounts)))) - #t)))) ;success + #~(lambda () + (activate-user-home + (map sexp->user-account + (list #$@(map user-account->gexp accounts)))) + #t))) ;success (documentation "Create user home directories.")))) (define (shells-file shells) -- cgit 1.4.1 From 6a9581741e4ee81226aeb2f1c997df76670a6aab Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 26 Aug 2020 08:11:34 -0400 Subject: system: image: Do not offload image files. Image files can be very large (multiple gigabytes), and the process of generating them is primarily I/O bound. As disk access is typically faster than network access, it makes sense build them locally. * gnu/system/image.scm (system-disk-image): Pass the #:local-build? #t parameter to computed-file calls dealing with generating image files. (system-iso9660-image): Likewise. --- gnu/system/image.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 36f56e237d..c1a718d607 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -266,7 +266,8 @@ used in the image." #$output image-root))))) (computed-file "partition.img" image-builder - #:options `(#:references-graphs ,inputs)))) + #:options `(#:local-build? #t ;typically large file + #:references-graphs ,inputs)))) (define (partition->config partition) ;; Return the genimage partition configuration for PARTITION. @@ -324,7 +325,8 @@ image ~a { #~(symlink (string-append #$image-dir "/" #$genimage-name) #$output) - #:options `(#:substitutable? ,substitutable?)))) + #:options `(#:local-build? #t ;typically large file + #:substitutable? ,substitutable?)))) ;; @@ -401,7 +403,8 @@ used in the image. " #:volume-id #$root-label #:volume-uuid #$root-uuid))))) (computed-file name builder - #:options `(#:references-graphs ,inputs + #:options `(#:local-build? #t ;typically large file + #:references-graphs ,inputs #:substitutable? ,substitutable?)))) -- cgit 1.4.1 From be1c00ae3c3dc7086ada05f34c36e85adb839038 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 28 Aug 2020 00:08:22 +0200 Subject: system: Remove extra line from 'lightweight-desktop.tmpl'. This is a followup to c7af96871737ffa0e2be879e200573bc60603c8c. * gnu/system/examples/lightweight-desktop.tmpl: Remove extra 'use-package-modules' line. --- gnu/system/examples/lightweight-desktop.tmpl | 1 - 1 file changed, 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/examples/lightweight-desktop.tmpl b/gnu/system/examples/lightweight-desktop.tmpl index 20b122fe51..b4037d4f79 100644 --- a/gnu/system/examples/lightweight-desktop.tmpl +++ b/gnu/system/examples/lightweight-desktop.tmpl @@ -4,7 +4,6 @@ (use-modules (gnu) (gnu system nss)) (use-service-modules desktop) -(use-package-modules bootloaders certs ratpoison suckless wm) (use-package-modules bootloaders certs ratpoison suckless wm xorg) (operating-system -- cgit 1.4.1 From 7eeb78157d3d0267ce4a4ea38ff56a2c4246c11b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 31 Aug 2020 14:19:22 +0200 Subject: vm: Disable caching for writable file system mappings. Fixes . Reported by elaexuotee@wilsonb.com. * gnu/system/vm.scm (mapping->file-system)[options]: Disable loose caching when WRITABLE? is true. --- gnu/system/vm.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 861f2a427a..80a8618729 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -699,7 +699,8 @@ of the GNU system as described by OS." (device (file-system->mount-tag source)) (type "9p") (flags (if writable? '() '(read-only))) - (options "trans=virtio,cache=loose") + (options (string-append "trans=virtio" + (if writable? "" ",cache=loose"))) (check? #f) (create-mount-point? #t))))) -- cgit 1.4.1 From 036f23f053ee6bd34c6d387debb4a9166561dd02 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Sat, 29 Aug 2020 15:34:56 +0200 Subject: guix: system: Add `--label' option. * guix/scripts/system.scm (%options): Add `--label'. (system-derivation-for-action): Take a #:label key to set volume ID. (perform-action): Take a #:label key. (%default-options): Add default label value. (process-action): Pass label value from command-line to perform-action. * gnu/system/image.scm (image-with-label): New procedure. --- doc/guix.texi | 4 +++- gnu/system/image.scm | 17 ++++++++++++++++- guix/scripts/system.scm | 18 ++++++++++++++---- 3 files changed, 33 insertions(+), 6 deletions(-) (limited to 'gnu/system') diff --git a/doc/guix.texi b/doc/guix.texi index 6206a93857..56b1cd8976 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -28836,7 +28836,9 @@ the @option{--image-size} option is ignored in the case of @code{docker-image}. You can specify the root file system type by using the -@option{--file-system-type} option. It defaults to @code{ext4}. +@option{--file-system-type} option. It defaults to @code{ext4}. When its +value is @code{iso9660}, the @option{--label} option can be used to specify +a volume ID with @code{disk-image}. When using @code{vm-image}, the returned image is in qcow2 format, which the QEMU emulator can efficiently use. @xref{Running Guix in a VM}, diff --git a/gnu/system/image.scm b/gnu/system/image.scm index c1a718d607..733f2bfa8d 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -63,7 +63,8 @@ iso9660-image find-image - system-image)) + system-image + image-with-label)) ;;; @@ -407,6 +408,20 @@ used in the image. " #:references-graphs ,inputs #:substitutable? ,substitutable?)))) +(define (image-with-label base-image label) + "The volume ID of an ISO is the label of the first partition. This procedure +returns an image record where the first partition's label is set to