From a5e2fc73760a2ae023f2e56bdbf8025971f90e64 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 24 Jul 2020 22:58:08 +0200 Subject: utils: Move and '&error-location' to (guix diagnostics). * guix/utils.scm (, source-properties->location) (location->source-properties, &error-location): Move to... * guix/diagnostics.scm: ... here. * gnu.scm: Adjust imports accordingly. * gnu/machine.scm: Likewise. * gnu/system.scm: Likewise. * gnu/tests.scm: Likewise. * guix/inferior.scm: Likewise. * tests/channels.scm: Likewise. * tests/packages.scm: Likewise. --- guix/diagnostics.scm | 60 ++++++++++++++++++++++++++++++++++++++++++-- guix/inferior.scm | 3 ++- guix/utils.scm | 71 +++++++++++----------------------------------------- 3 files changed, 75 insertions(+), 59 deletions(-) (limited to 'guix') diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm index 6c0753aef4..8b24b1b994 100644 --- a/guix/diagnostics.scm +++ b/guix/diagnostics.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,8 +19,9 @@ (define-module (guix diagnostics) #:use-module (guix colors) #:use-module (guix i18n) - #:autoload (guix utils) () + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) #:use-module (ice-9 format) #:use-module (ice-9 match) #:export (warning @@ -28,8 +29,20 @@ (define-module (guix diagnostics) report-error leave + + location + location? + location-file + location-line + location-column + source-properties->location + location->source-properties location->string + &error-location + error-location? + error-location + guix-warning-port program-name)) @@ -162,6 +175,45 @@ (define prefix-color (program-name) (program-name) (prefix-color prefix))))) + +;; A source location. +(define-record-type + (make-location file line column) + location? + (file location-file) ; file name + (line location-line) ; 1-indexed line + (column location-column)) ; 0-indexed column + +(define (location file line column) + "Return the object for the given FILE, LINE, and COLUMN." + (and line column file + (make-location file line column))) + +(define (source-properties->location loc) + "Return a location object based on the info in LOC, an alist as returned +by Guile's `source-properties', `frame-source', `current-source-location', +etc." + ;; In accordance with the GCS, start line and column numbers at 1. Note + ;; that unlike LINE and `port-column', COL is actually 1-indexed here... + (match loc + ((('line . line) ('column . col) ('filename . file)) ;common case + (and file line col + (make-location file (+ line 1) col))) + (#f + #f) + (_ + (let ((file (assq-ref loc 'filename)) + (line (assq-ref loc 'line)) + (col (assq-ref loc 'column))) + (location file (and line (+ line 1)) col))))) + +(define (location->source-properties loc) + "Return the source property association list based on the info in LOC, +a location object." + `((line . ,(and=> (location-line loc) 1-)) + (column . ,(location-column loc)) + (filename . ,(location-file loc)))) + (define (location->string loc) "Return a human-friendly, GNU-standard representation of LOC." (match loc @@ -169,6 +221,10 @@ (define (location->string loc) (($ file line column) (format #f "~a:~a:~a" file line column)))) +(define-condition-type &error-location &error + error-location? + (location error-location)) ; + (define guix-warning-port (make-parameter (current-warning-port))) diff --git a/guix/inferior.scm b/guix/inferior.scm index d347754bbc..77820872b3 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -21,9 +21,10 @@ (define-module (guix inferior) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module ((guix diagnostics) + #:select (source-properties->location)) #:use-module ((guix utils) #:select (%current-system - source-properties->location call-with-temporary-directory version>? version-prefix? cache-directory)) diff --git a/guix/utils.scm b/guix/utils.scm index 17a96370f1..64894ecf1f 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -37,13 +37,27 @@ (define-module (guix utils) #:use-module (guix memoization) #:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively)) #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) + #:use-module (guix diagnostics) ;, &error-location, etc. #:use-module (ice-9 format) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module ((ice-9 iconv) #:prefix iconv:) #:use-module (system foreign) - #:re-export (memoize) ; for backwards compatibility + #:re-export (memoize ;for backwards compatibility + + + location + location? + location-file + location-line + location-column + source-properties->location + location->source-properties + + &error-location + error-location? + error-location) #:export (strip-keyword-arguments default-keyword-arguments substitute-keyword-arguments @@ -51,19 +65,6 @@ (define-module (guix utils) current-source-directory - - location - location? - location-file - location-line - location-column - source-properties->location - location->source-properties - - &error-location - error-location? - error-location - &fix-hint fix-hint? condition-fix-hint @@ -834,48 +835,6 @@ (define-syntax current-source-directory ;; raising an error would upset Geiser users #f)))))) -;; A source location. -(define-record-type - (make-location file line column) - location? - (file location-file) ; file name - (line location-line) ; 1-indexed line - (column location-column)) ; 0-indexed column - -(define (location file line column) - "Return the object for the given FILE, LINE, and COLUMN." - (and line column file - (make-location file line column))) - -(define (source-properties->location loc) - "Return a location object based on the info in LOC, an alist as returned -by Guile's `source-properties', `frame-source', `current-source-location', -etc." - ;; In accordance with the GCS, start line and column numbers at 1. Note - ;; that unlike LINE and `port-column', COL is actually 1-indexed here... - (match loc - ((('line . line) ('column . col) ('filename . file)) ;common case - (and file line col - (make-location file (+ line 1) col))) - (#f - #f) - (_ - (let ((file (assq-ref loc 'filename)) - (line (assq-ref loc 'line)) - (col (assq-ref loc 'column))) - (location file (and line (+ line 1)) col))))) - -(define (location->source-properties loc) - "Return the source property association list based on the info in LOC, -a location object." - `((line . ,(and=> (location-line loc) 1-)) - (column . ,(location-column loc)) - (filename . ,(location-file loc)))) - -(define-condition-type &error-location &error - error-location? - (location error-location)) ; - (define-condition-type &fix-hint &condition fix-hint? (hint condition-fix-hint)) ;string -- cgit v1.2.3 From 6a79eed920fd4914b162461553a8d7e8f5eee324 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 24 Jul 2020 23:10:32 +0200 Subject: utils: Remove compatibility re-export of 'memoize'. The 'memoize' binding was re-exported in 2016, commit 19e1d5f7f90194f1ac7e783b28a688ce1441786d, as a backwards-compatibility measure that makes little sense now. * guix/utils.scm: Don't re-export 'memoize'. * guix/import/pypi.scm: Adjust imports. * tests/pypi.scm: Remove duplicate (guix memoization) import. --- guix/import/pypi.scm | 4 +++- guix/utils.scm | 4 +--- tests/pypi.scm | 1 - 3 files changed, 4 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index a2b5d995ef..a4a2489688 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -34,8 +34,10 @@ (define-module (guix import pypi) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix memoization) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module ((guix build utils) #:select ((package-name->name+version . hyphen-package-name->name+version) diff --git a/guix/utils.scm b/guix/utils.scm index 64894ecf1f..8198204ade 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -44,9 +44,7 @@ (define-module (guix utils) #:use-module (ice-9 format) #:use-module ((ice-9 iconv) #:prefix iconv:) #:use-module (system foreign) - #:re-export (memoize ;for backwards compatibility - - + #:re-export ( ;for backwards compatibility location location? location-file diff --git a/tests/pypi.scm b/tests/pypi.scm index 6788c8db3e..f421d6d9df 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -23,7 +23,6 @@ (define-module (test-pypi) #:use-module (guix base32) #:use-module (guix memoization) #:use-module (gcrypt hash) - #:use-module (guix memoization) #:use-module (guix tests) #:use-module (guix build-system python) #:use-module ((guix build utils) #:select (delete-file-recursively which mkdir-p)) -- cgit v1.2.3 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.scm | 1 - gnu/system/mapped-devices.scm | 2 +- guix/channels.scm | 4 ---- guix/diagnostics.scm | 8 ++++++++ guix/profiles.scm | 1 + guix/scripts/system/reconfigure.scm | 1 - guix/ssh.scm | 2 +- guix/utils.scm | 15 +++++---------- 8 files changed, 16 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/gnu.scm b/gnu.scm index 5f593bd569..b95082f42e 100644 --- a/gnu.scm +++ b/gnu.scm @@ -20,7 +20,6 @@ (define-module (gnu) #:use-module (guix i18n) - #:use-module ((guix utils) #:select (&fix-hint)) #:use-module (guix diagnostics) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) 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 @@ (define-module (gnu system mapped-devices) #: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)) diff --git a/guix/channels.scm b/guix/channels.scm index bbabf654a9..21a2fdb631 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -40,10 +40,6 @@ (define-module (guix channels) #:use-module (guix sets) #:use-module (guix store) #:use-module (guix i18n) - #:use-module ((guix utils) - #:select (source-properties->location - &error-location - &fix-hint)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm index 8b24b1b994..3096d384d8 100644 --- a/guix/diagnostics.scm +++ b/guix/diagnostics.scm @@ -43,6 +43,10 @@ (define-module (guix diagnostics) error-location? error-location + &fix-hint + fix-hint? + condition-fix-hint + guix-warning-port program-name)) @@ -225,6 +229,10 @@ (define-condition-type &error-location &error error-location? (location error-location)) ; +(define-condition-type &fix-hint &condition + fix-hint? + (hint condition-fix-hint)) ;string + (define guix-warning-port (make-parameter (current-warning-port))) diff --git a/guix/profiles.scm b/guix/profiles.scm index f34f73e17e..0619e735fb 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -32,6 +32,7 @@ (define-module (guix profiles) #:use-module ((guix utils) #:hide (package-name->name+version)) #:use-module ((guix build utils) #:select (package-name->name+version mkdir-p)) + #:use-module ((guix diagnostics) #:select (&fix-hint)) #:use-module (guix i18n) #:use-module (guix records) #:use-module (guix packages) diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 9013e035f7..a2570839a8 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -39,7 +39,6 @@ (define-module (guix scripts system reconfigure) #:autoload (guix git) (update-cached-checkout) #:use-module (guix i18n) #:use-module (guix diagnostics) - #:use-module ((guix utils) #:select (&fix-hint)) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) diff --git a/guix/ssh.scm b/guix/ssh.scm index b9e6ff8564..418443992b 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -20,7 +20,7 @@ (define-module (guix ssh) #:use-module (guix store) #:use-module (guix inferior) #:use-module (guix i18n) - #:use-module ((guix utils) #:select (&fix-hint)) + #:use-module ((guix diagnostics) #:select (&fix-hint)) #:use-module (gcrypt pk-crypto) #:use-module (ssh session) #:use-module (ssh auth) diff --git a/guix/utils.scm b/guix/utils.scm index 8198204ade..436c5cd093 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -29,7 +29,6 @@ (define-module (guix utils) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-35) #:use-module (srfi srfi-39) #:use-module (ice-9 ftw) #:use-module (rnrs io ports) ;need 'port-position' etc. @@ -55,7 +54,11 @@ (define-module (guix utils) &error-location error-location? - error-location) + error-location + + &fix-hint + fix-hint? + condition-fix-hint) #:export (strip-keyword-arguments default-keyword-arguments substitute-keyword-arguments @@ -63,10 +66,6 @@ (define-module (guix utils) current-source-directory - &fix-hint - fix-hint? - condition-fix-hint - nix-system->gnu-triplet gnu-triplet->nix-system %current-system @@ -833,10 +832,6 @@ (define-syntax current-source-directory ;; raising an error would upset Geiser users #f)))))) -(define-condition-type &fix-hint &condition - fix-hint? - (hint condition-fix-hint)) ;string - ;;; Local Variables: ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1) ;;; End: -- cgit v1.2.3 From efe037fc5cc3134bbc3ef4e36b49a3f788921b68 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 25 Jul 2020 15:50:36 +0200 Subject: ui: Factorize '&message' handling. * guix/ui.scm (call-with-error-handling): Factorize the three 'message-condition?' clauses into one. --- guix/ui.scm | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 27bcade9dd..588eb8480e 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -782,17 +782,14 @@ (define (manifest-entry-output* entry) (invoke-error-stop-signal c) (cons (invoke-error-program c) (invoke-error-arguments c)))) - ((and (error-location? c) (message-condition? c)) - (report-error (error-location c) (G_ "~a~%") + ((message-condition? c) + ;; Normally '&message' error conditions have an i18n'd message. + (report-error (and (error-location? c) (error-location c)) + (G_ "~a~%") (gettext (condition-message c) %gettext-domain)) (when (fix-hint? c) (display-hint (condition-fix-hint c))) (exit 1)) - ((and (message-condition? c) (fix-hint? c)) - (report-error (G_ "~a~%") - (gettext (condition-message c) %gettext-domain)) - (display-hint (condition-fix-hint c)) - (exit 1)) ;; On Guile 3.0.0, exceptions such as 'unbound-variable' are ;; compound and include a '&message'. However, that message only @@ -806,12 +803,7 @@ (define (manifest-entry-output* entry) (guile-3 ((exception-predicate &exception-with-kind-and-args) c)) (else #f)) - (raise c)) - - ((message-condition? c) - ;; Normally '&message' error conditions have an i18n'd message. - (leave (G_ "~a~%") - (gettext (condition-message c) %gettext-domain)))) + (raise c))) ;; Catch EPIPE and the likes. (catch 'system-error thunk -- cgit v1.2.3 From 860f3d77495aad0061c4ee9b6de73d6fe9fc40e9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 25 Jul 2020 17:54:20 +0200 Subject: diagnostics: Add a procedural variant of diagnostic procedures. Callers can pass 'report-error', 'warning', etc. to 'apply'. * guix/diagnostics.scm (trivial-format-string?): New procedure, moved from... (highlight-argument): ... here. (define-diagnostic): Add 'identifier?' clause. (emit-diagnostic): New procedure. --- guix/diagnostics.scm | 48 +++++++++++++++++++++++++++++++++++------------- 1 file changed, 35 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm index 3096d384d8..3b536d8e96 100644 --- a/guix/diagnostics.scm +++ b/guix/diagnostics.scm @@ -57,22 +57,22 @@ (define-module (guix diagnostics) ;;; ;;; Code: +(define (trivial-format-string? fmt) + (define len + (string-length fmt)) + + (let loop ((start 0)) + (or (>= (+ 1 start) len) + (let ((tilde (string-index fmt #\~ start))) + (or (not tilde) + (case (string-ref fmt (+ tilde 1)) + ((#\a #\A #\%) (loop (+ tilde 2))) + (else #f))))))) + (define-syntax highlight-argument (lambda (s) "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT is a trivial format string." - (define (trivial-format-string? fmt) - (define len - (string-length fmt)) - - (let loop ((start 0)) - (or (>= (+ 1 start) len) - (let ((tilde (string-index fmt #\~ start))) - (or (not tilde) - (case (string-ref fmt (+ tilde 1)) - ((#\a #\A #\%) (loop (+ tilde 2))) - (else #f))))))) - ;; Be conservative: limit format argument highlighting to cases where the ;; format string contains nothing but ~a escapes. If it contained ~s ;; escapes, this strategy wouldn't work. @@ -132,7 +132,15 @@ (define-syntax name args (... ...)) (free-identifier=? #'N-underscore #'N_) #'(name #f (N-underscore singular plural n) - args (... ...))))))))) + args (... ...))) + (id + (identifier? #'id) + ;; Run-time variant. + #'(lambda (location fmt . args) + (emit-diagnostic fmt args + #:location location + #:prefix prefix + #:colors colors))))))))) ;; XXX: This doesn't work well for right-to-left languages. ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; @@ -147,6 +155,20 @@ (define-syntax-rule (leave args ...) (report-error args ...) (exit 1))) +(define* (emit-diagnostic fmt args + #:key location (colors (color)) (prefix "")) + "Report diagnostic message FMT with the given ARGS and the specified +LOCATION, COLORS, and PREFIX. + +This procedure is used as a last resort when the format string is not known at +macro-expansion time." + (print-diagnostic-prefix (gettext prefix %gettext-domain) + location #:colors colors) + (apply format (guix-warning-port) fmt + (if (trivial-format-string? fmt) + (map %highlight-argument args) + args))) + (define %warning-color (color BOLD MAGENTA)) (define %info-color (color BOLD)) (define %error-color (color BOLD RED)) -- cgit v1.2.3 From 252a1926bc7d7aa0b39d89a484c0c1b82e945fcd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 25 Jul 2020 17:59:13 +0200 Subject: diagnostics: Add '&formatted-message'. This allows 'gettext' to be called on the format string at the site where the exception is caught (rather than the site where it's thrown). It also allows for argument highlighting. * guix/diagnostics.scm (&formatted-message): New condition type. (check-format-string): New procedure. (formatted-message): New macro. * guix/ui.scm (report-load-error): Add clause for 'formatted-message?'. (warn-about-load-error): Likewise. (call-with-error-handling): Likewise. (read/eval): Likewise. --- guix/diagnostics.scm | 65 ++++++++++++++++++++++++++++++++++++++++++++++++++++ guix/ui.scm | 62 +++++++++++++++++++++++++++++++++++-------------- 2 files changed, 110 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm index 3b536d8e96..7b9ffc61b5 100644 --- a/guix/diagnostics.scm +++ b/guix/diagnostics.scm @@ -19,6 +19,7 @@ (define-module (guix diagnostics) #:use-module (guix colors) #:use-module (guix i18n) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-35) @@ -43,6 +44,11 @@ (define-module (guix diagnostics) error-location? error-location + formatted-message + formatted-message? + formatted-message-string + formatted-message-arguments + &fix-hint fix-hint? condition-fix-hint @@ -255,6 +261,65 @@ (define-condition-type &fix-hint &condition fix-hint? (hint condition-fix-hint)) ;string +(define-condition-type &formatted-message &error + formatted-message? + (format formatted-message-string) + (arguments formatted-message-arguments)) + +(define (check-format-string location format args) + "Check that FORMAT, a format string, contains valid escapes, and that the +number of arguments in ARGS matches the escapes in FORMAT." + (define actual-count + (length args)) + + (define allowed-chars ;for 'simple-format' + '(#\A #\S #\a #\s #\~ #\%)) + + (define (format-chars fmt) + (let loop ((chars (string->list fmt)) + (result '())) + (match chars + (() + (reverse result)) + ((#\~ opt rest ...) + (loop rest (cons opt result))) + ((chr rest ...) + (and (memv chr allowed-chars) + (loop rest result)))))) + + (match (format-chars format) + (#f + ;; XXX: In this case it could be that FMT contains invalid escapes, or it + ;; could be that it contains escapes beyond ALLOWED-CHARS, for (ice-9 + ;; format). Instead of implementing '-Wformat', do nothing. + #f) + (chars + (let ((count (fold (lambda (chr count) + (case chr + ((#\~ #\%) count) + (else (+ count 1)))) + 0 + chars))) + (unless (= count actual-count) + (warning location (G_ "format string got ~a arguments, expected ~a~%") + actual-count count)))))) + +(define-syntax formatted-message + (lambda (s) + "Return a '&formatted-message' error condition." + (syntax-case s (G_) + ((_ (G_ str) args ...) + (string? (syntax->datum #'str)) + (let ((str (syntax->datum #'str))) + ;; Implement a subset of '-Wformat'. + (check-format-string (source-properties->location + (syntax-source s)) + str #'(args ...)) + (with-syntax ((str (string-append str "\n"))) + #'(condition + (&formatted-message (format str) + (arguments (list args ...)))))))))) + (define guix-warning-port (make-parameter (current-warning-port))) diff --git a/guix/ui.scm b/guix/ui.scm index 588eb8480e..162eb35d26 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -388,12 +388,18 @@ (define* (report-load-error file args #:optional frame) (('unbound-variable _ ...) (report-unbound-variable-error args #:frame frame)) (((or 'srfi-34 '%exception) obj) - (if (message-condition? obj) - (report-error (and (error-location? obj) - (error-location obj)) - (G_ "~a~%") - (gettext (condition-message obj) %gettext-domain)) - (report-error (G_ "exception thrown: ~s~%") obj)) + (cond ((message-condition? obj) + (report-error (and (error-location? obj) + (error-location obj)) + (G_ "~a~%") + (gettext (condition-message obj) %gettext-domain))) + ((formatted-message? obj) + (apply report-error + (and (error-location? obj) (error-location obj)) + (gettext (formatted-message-string obj) %gettext-domain) + (formatted-message-arguments obj))) + (else + (report-error (G_ "exception thrown: ~s~%") obj))) (when (fix-hint? obj) (display-hint (condition-fix-hint obj)))) ((key args ...) @@ -420,12 +426,19 @@ (define (warn-about-load-error file module args) ;FIXME: factorize with ↑ (('unbound-variable _ ...) (report-unbound-variable-error args)) (((or 'srfi-34 '%exception) obj) - (if (message-condition? obj) - (warning (G_ "failed to load '~a': ~a~%") - file - (gettext (condition-message obj) %gettext-domain)) - (warning (G_ "failed to load '~a': exception thrown: ~s~%") - file obj))) + (cond ((message-condition? obj) + (warning (G_ "failed to load '~a': ~a~%") + file + (gettext (condition-message obj) %gettext-domain))) + ((formatted-message? obj) + (warning (G_ "failed to load '~a': ~a~%") + (apply format #f + (gettext (formatted-message-string obj) + %gettext-domain) + (formatted-message-arguments obj)))) + (else + (warning (G_ "failed to load '~a': exception thrown: ~s~%") + file obj)))) ((error args ...) (warning (G_ "failed to load '~a':~%") module) (apply display-error #f (current-error-port) args) @@ -791,6 +804,15 @@ (define (manifest-entry-output* entry) (display-hint (condition-fix-hint c))) (exit 1)) + ((formatted-message? c) + (apply report-error + (and (error-location? c) (error-location c)) + (gettext (formatted-message-string c) %gettext-domain) + (formatted-message-arguments c)) + (when (fix-hint? c) + (display-hint (condition-fix-hint c))) + (exit 1)) + ;; On Guile 3.0.0, exceptions such as 'unbound-variable' are ;; compound and include a '&message'. However, that message only ;; contains the format string. Thus, special-case it here to @@ -854,11 +876,17 @@ (define (read/eval str) (('syntax-error proc message properties form . rest) (report-error (G_ "syntax error: ~a~%") message)) (((or 'srfi-34 '%exception) obj) - (if (message-condition? obj) - (report-error (G_ "~a~%") - (gettext (condition-message obj) - %gettext-domain)) - (report-error (G_ "exception thrown: ~s~%") obj))) + (cond ((message-condition? obj) + (report-error (G_ "~a~%") + (gettext (condition-message obj) + %gettext-domain))) + ((formatted-message? obj) + (apply report-error #f + (gettext (formatted-message-string obj) + %gettext-domain) + (formatted-message-arguments obj))) + (else + (report-error (G_ "exception thrown: ~s~%") obj)))) ((error args ...) (apply display-error #f (current-error-port) args)) (what? #f)) -- cgit v1.2.3 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 'guix') diff --git a/gnu.scm b/gnu.scm index b95082f42e..f139531ef3 100644 --- a/gnu.scm +++ b/gnu.scm @@ -78,10 +78,8 @@ (define (location->string loc) (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 @@ (define-module (gnu machine digital-ocean) #: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 @@ (define (maybe-raise-unsupported-configuration-error machine) (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 @@ (define (check-literal-file-system fs) (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 @@ (define remote-exp (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 @@ (define remote-exp (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 @@ (define (machine-check-building-for-appropriate-system 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 @@ (define (deploy-managed-host machine) (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 @@ (define (maybe-raise-unsupported-configuration-error machine) (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 @@ (define-module (gnu packages) #: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-auxiliary-file file-name) (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 @@ (define-module (gnu services) #: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 @@ (define (%service-with-default-value location type) (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 @@ (define (assert-no-duplicates files) (() #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 @@ (define (apply-extension target) 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 @@ (define (locale-name->definition* name) "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 @@ (define-module (gnu system mapped-devices) #: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 @@ (define missing ;; "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 @@ (define missing 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 @@ (define* (check-luks-device md #:key (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 @@ (define (dot-git? file stat) ;; 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 @@ (define-module (guix cve) #: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 @@ (define (json->cve-items json) (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 @@ (define-module (guix git-authenticate) #: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 @@ (define* (commit-signing-key repo commit-id 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 @@ (define* (commit-signing-key repo commit-id keyring (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 @@ (define (assert-parents-lack-authorizations commit) ;; 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 @@ (define signing-key (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 @@ (define actual-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 @@ (define (check-patch-file-names package) ;; 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 @@ (define (try store system) (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 @@ (define-module (guix remote) #: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 @@ (define repl-command (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 @@ (define-module (guix scripts graph) #: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 @@ (define assert-package 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 @@ (define-module (guix scripts offload) #: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 @@ (define (private-key-from-file* file) (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 @@ (define-module (guix ssh) #: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 @@ (define (authenticate-server* session key) ;; 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 @@ (define* (open-ssh-session host #:key user port identity (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 @@ (define* (open-ssh-session host #:key user port identity 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 @@ (define* (remote-inferior session #:optional become-command) (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 @@ (define generation-ctime-alist 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 @@ (define* (package-update store package updaters #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 @@ (define-module (test-channels) #: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 @@ (define (find-commit* message) (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 @@ (define (find-commit* message) (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 @@ (define (warning-contains? str warnings) (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 @@ (define read-at (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 v1.2.3 From 9a6322774db5739f22342e22abc9385479b88ba5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 25 Jul 2020 18:37:30 +0200 Subject: guix system: Report file system errors using 'report-error'. * guix/scripts/system.scm (check-file-system-availability)[file-system-location*]: Return a record instead of a string. [error]: Use 'report-error' instead of 'format'. Change callers accordingly. --- guix/scripts/system.scm | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 79bfcd7db2..bfd50c7a79 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -565,16 +565,14 @@ (define uuid (define fail? #f) (define (file-system-location* fs) - (location->string - (source-properties->location - (file-system-location fs)))) + (and=> (file-system-location fs) + source-properties->location)) (let-syntax ((error (syntax-rules () ((_ args ...) (begin (set! fail? #t) - (format (current-error-port) - args ...)))))) + (report-error args ...)))))) (for-each (lambda (fs) (catch 'system-error (lambda () @@ -582,9 +580,9 @@ (define (file-system-location* fs) (lambda args (let ((errno (system-error-errno args)) (device (file-system-device fs))) - (error (G_ "~a: error: device '~a' not found: ~a~%") - (file-system-location* fs) device - (strerror errno)) + (error (file-system-location* fs) + (G_ "device '~a' not found: ~a~%") + device (strerror errno)) (unless (string-prefix? "/" device) (display-hint (format #f (G_ "If '~a' is a file system label, write @code{(file-system-label ~s)} in your @code{device} field.") @@ -594,13 +592,14 @@ (define (file-system-location* fs) (let ((label (file-system-label->string (file-system-device fs)))) (unless (find-partition-by-label label) - (error (G_ "~a: error: file system with label '~a' not found~%") - (file-system-location* fs) label)))) + (error (file-system-location* fs) + (G_ "file system with label '~a' not found~%") + label)))) labeled) (for-each (lambda (fs) (unless (find-partition-by-uuid (file-system-device fs)) - (error (G_ "~a: error: file system with UUID '~a' not found~%") - (file-system-location* fs) + (error (file-system-location* fs) + (G_ "file system with UUID '~a' not found~%") (uuid->string (file-system-device fs))))) uuid) -- cgit v1.2.3 From 9296a2e511311d23dc49c4e4b3cbb9341ea82bb3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 26 Jul 2020 16:45:42 +0200 Subject: processes: Allow 'less' to properly estimate line length. Until now, the first few lines in the output of 'guix processes' could disappear in 'less'. * guix/ui.scm (call-with-paginated-output-port): Add #:less-options parameter and honor it. (with-paginated-output-port): Allow callers to pass #:less-options. * guix/scripts/processes.scm (guix-processes): Pass #:less-options to 'with-paginated-output-port'. --- guix/scripts/processes.scm | 5 ++++- guix/ui.scm | 20 +++++++++++++++----- 2 files changed, 19 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm index 01f7213e8c..35698a0216 100644 --- a/guix/scripts/processes.scm +++ b/guix/scripts/processes.scm @@ -235,4 +235,7 @@ (define options (for-each (lambda (session) (daemon-session->recutils session port) (newline port)) - (daemon-sessions)))) + (daemon-sessions)) + + ;; Pass 'R' (instead of 'r') so 'less' correctly estimates line length. + #:less-options "FRX")) diff --git a/guix/ui.scm b/guix/ui.scm index 420c9689ae..55460cef00 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1607,13 +1607,18 @@ (define (package-relevance package regexps) zero means that PACKAGE does not match any of REGEXPS." (relevance package regexps %package-metrics)) -(define (call-with-paginated-output-port proc) +(define* (call-with-paginated-output-port proc + #:key (less-options "FrX")) (if (isatty?* (current-output-port)) ;; Set 'LESS' so that 'less' exits if everything fits on the screen (F), ;; lets ANSI escapes through (r), does not send the termcap ;; initialization string (X). Set it unconditionally because some ;; distros set it to something that doesn't work here. - (let ((pager (with-environment-variables `(("LESS" "FrX")) + ;; + ;; For things that produce long lines, such as 'guix processes', use 'R' + ;; instead of 'r': this strips hyperlinks but allows 'less' to make a + ;; good estimate of the line length. + (let ((pager (with-environment-variables `(("LESS" ,less-options)) (open-pipe* OPEN_WRITE (or (getenv "GUIX_PAGER") (getenv "PAGER") "less"))))) @@ -1623,10 +1628,15 @@ (define (call-with-paginated-output-port proc) (lambda () (close-pipe pager)))) (proc (current-output-port)))) -(define-syntax-rule (with-paginated-output-port port exp ...) - "Evaluate EXP... with PORT bound to a port that talks to the pager if +(define-syntax with-paginated-output-port + (syntax-rules () + "Evaluate EXP... with PORT bound to a port that talks to the pager if standard output is a tty, or with PORT set to the current output port." - (call-with-paginated-output-port (lambda (port) exp ...))) + ((_ port exp ... #:less-options opts) + (call-with-paginated-output-port (lambda (port) exp ...) + #:less-options opts)) + ((_ port exp ...) + (call-with-paginated-output-port (lambda (port) exp ...))))) (define* (display-search-results matches port #:key -- cgit v1.2.3 From a396dd01bc6e90ae512001350d1afa471e01661d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Jul 2020 11:03:14 +0200 Subject: machine: ssh: Check for potential system downgrades. This is a followup to 8e31736b0a60919cc1bfc5dc22c395b09243484a. * guix/scripts/system/reconfigure.scm (check-forward-update): Add #:current-channels. Use it instead of OLD. * gnu/services.scm (sexp->system-provenance): New procedure. (system-provenance): Use it. * gnu/machine/ssh.scm ()[allow-downgrades?]: New field. (machine-check-forward-update): New procedure. (check-deployment-sanity)[assertions]: Call it. * doc/guix.texi (Invoking guix deploy): Document 'allow-downgrades?' field. --- doc/guix.texi | 10 ++++++++++ gnu/machine/ssh.scm | 32 +++++++++++++++++++++++++++++++- gnu/services.scm | 26 +++++++++++++++++--------- guix/scripts/system/reconfigure.scm | 21 +++++++++++---------- 4 files changed, 69 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index e2b304ff63..ca96ecc298 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -29033,6 +29033,16 @@ When @code{host-key} is @code{#f}, the server is authenticated against the @file{~/.ssh/known_hosts} file, just like the OpenSSH @command{ssh} client does. +@item @code{allow-downgrades?} (default: @code{#f}) +Whether to allow potential downgrades. + +Like @command{guix system reconfigure}, @command{guix deploy} compares +the channel commits currently deployed on the remote host (as returned +by @command{guix system describe}) to those currently in use (as +returned by @command{guix describe}) to determine whether commits +currently in use are descendants of those deployed. When this is not +the case and @code{allow-downgrades?} is false, it raises an error. +This ensures you do not accidentally downgrade remote machines. @end table @end deftp diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index 641e871861..4e31baa4b9 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -24,6 +24,7 @@ (define-module (gnu machine ssh) #:use-module (gnu system) #:use-module (gnu system file-systems) #:use-module (gnu system uuid) + #:use-module ((gnu services) #:select (sexp->system-provenance)) #:use-module (guix diagnostics) #:use-module (guix gexp) #:use-module (guix i18n) @@ -55,6 +56,7 @@ (define-module (gnu machine ssh) machine-ssh-configuration-host-name machine-ssh-configuration-build-locally? machine-ssh-configuration-authorize? + machine-ssh-configuration-allow-downgrades? machine-ssh-configuration-port machine-ssh-configuration-user machine-ssh-configuration-host-key @@ -83,6 +85,8 @@ (define-record-type* machine-ssh-configuration (default #t)) (authorize? machine-ssh-configuration-authorize? ; boolean (default #t)) + (allow-downgrades? machine-ssh-configuration-allow-downgrades? ; boolean + (default #f)) (port machine-ssh-configuration-port ; integer (default 22)) (user machine-ssh-configuration-user ; string @@ -271,6 +275,27 @@ (define dev (map missing-modules file-systems)) +(define* (machine-check-forward-update machine) + "Check whether we are making a forward update for MACHINE. Depending on its +'allow-upgrades?' field, raise an error or display a warning if we are +potentially downgrading it." + (define config + (machine-configuration machine)) + + (define validate-reconfigure + (if (machine-ssh-configuration-allow-downgrades? config) + warn-about-backward-reconfigure + ensure-forward-reconfigure)) + + (remote-let ((provenance #~(call-with-input-file + "/run/current-system/provenance" + read))) + (define channels + (sexp->system-provenance provenance)) + + (check-forward-update validate-reconfigure + #:current-channels channels))) + (define (machine-check-building-for-appropriate-system machine) "Raise a '&message' error condition if MACHINE is configured to be built locally and the 'system' field does not match the '%current-system' reported @@ -289,7 +314,8 @@ (define (check-deployment-sanity machine) 'system' declaration would fail." (define assertions (append (machine-check-file-system-availability machine) - (machine-check-initrd-modules machine))) + (machine-check-initrd-modules machine) + (list (machine-check-forward-update machine)))) (define aggregate-exp ;; Gather all the expressions so that a single round-trip is enough to @@ -491,3 +517,7 @@ (define (maybe-raise-unsupported-configuration-error machine) for environment of type '~a'") config environment))))) + +;; Local Variables: +;; eval: (put 'remote-let 'scheme-indent-function 1) +;; End: diff --git a/gnu/services.scm b/gnu/services.scm index 399a432e3f..11ba21e824 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -89,6 +89,7 @@ (define-module (gnu services) system-service-type provenance-service-type + sexp->system-provenance system-provenance boot-service-type cleanup-service-type @@ -488,6 +489,19 @@ (define provenance-service-type itself: the channels used when building the system, and its configuration file, when available."))) +(define (sexp->system-provenance sexp) + "Parse SEXP, an s-expression read from /run/current-system/provenance or +similar, and return two values: the list of channels listed therein, and the +OS configuration file or #f." + (match sexp + (('provenance ('version 0) + ('channels channels ...) + ('configuration-file config-file)) + (values (map sexp->channel channels) + config-file)) + (_ + (values '() #f)))) + (define (system-provenance system) "Given SYSTEM, the file name of a system generation, return two values: the list of channels SYSTEM is built from, and its configuration file. If that @@ -495,15 +509,9 @@ (define (system-provenance system) #false (for the configuration file)." (catch 'system-error (lambda () - (match (call-with-input-file (string-append system "/provenance") - read) - (('provenance ('version 0) - ('channels channels ...) - ('configuration-file config-file)) - (values (map sexp->channel channels) - config-file)) - (_ - (values '() #f)))) + (sexp->system-provenance + (call-with-input-file (string-append system "/provenance") + read))) (lambda _ (values '() #f)))) diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index a2570839a8..45bb1d5d3b 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -339,24 +339,25 @@ (define (channel-relations old new) old)) (define* (check-forward-update #:optional - (validate-reconfigure ensure-forward-reconfigure)) + (validate-reconfigure + ensure-forward-reconfigure) + #:key + (current-channels + (system-provenance "/run/current-system"))) "Call VALIDATE-RECONFIGURE passing it, for each channel, the channel, the -currently-deployed commit (as returned by 'guix system describe') and the -target commit (as returned by 'guix describe')." - ;; TODO: Make that functionality available to 'guix deploy'. +currently-deployed commit (from CURRENT-CHANNELS, which is as returned by +'guix system describe' by default) and the target commit (as returned by 'guix +describe')." (define new (or (and=> (current-profile) profile-channels) '())) - (define old - (system-provenance "/run/current-system")) - - (when (null? old) - (warning (G_ "cannot determine provenance for /run/current-system~%"))) + (when (null? current-channels) + (warning (G_ "cannot determine provenance for current system~%"))) (when (and (null? new) (not (getenv "GUIX_UNINSTALLED"))) (warning (G_ "cannot determine provenance of ~a~%") %guix-package-name)) (for-each (match-lambda ((channel old new relation) (validate-reconfigure channel old new relation))) - (channel-relations old new))) + (channel-relations current-channels new))) -- cgit v1.2.3 From bc76f8b1f9a74c0f187022991b633cc1820944c7 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Mon, 27 Jul 2020 13:33:39 +0200 Subject: upstream: Handle the case where the file name has no extension. Fixes . Reported by Alexandru-Sergiu Marton . * guix/upstream.scm (package-update/url-fetch): Handle the case where the file name has no extension. --- guix/upstream.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/upstream.scm b/guix/upstream.scm index ca184601b2..6584d5e4c4 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -369,7 +369,7 @@ (define* (package-update/url-fetch store package source (let*-values (((archive-type) (match (and=> (package-source package) origin-uri) ((? string? uri) - (let ((type (file-extension (basename uri)))) + (let ((type (or (file-extension (basename uri)) ""))) ;; Sometimes we have URLs such as ;; "https://github.com/…/tarball/v0.1", in which case ;; we must not consider "1" as the extension. -- cgit v1.2.3 From 8b221b64a552d31e241701aa5c6d339287a7a15b Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 28 Jul 2020 14:05:09 +0200 Subject: store: deduplication: Handle fs without d_type support. scandir* uses readdir, which means that the file type property can be 'unknown if the underlying file-system does not support d_type. Make sure to fallback to lstat in that case. Fixes: https://issues.guix.gnu.org/issue/42579. * guix/store/deduplication.scm (deduplicate): Handle the case where properties is 'unknown because the underlying file-system does not support d_type. --- guix/store/deduplication.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index a742a142ee..df959bdd06 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -164,8 +164,10 @@ (define links-directory ((file . properties) (unless (member file '("." "..")) (let* ((file (string-append path "/" file)) - (type (or (assq-ref properties 'type) - (stat:type (lstat file))))) + (type (match (assoc-ref properties 'type) + ((or 'unknown #f) + (stat:type (lstat file))) + (type type)))) (loop file type (and (not (eq? 'directory type)) (nar-sha256 file))))))) -- cgit v1.2.3 From c6c0d5a22c2ee3d7164dab0129b2e4852a4ae76c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 28 Jul 2020 10:48:50 +0200 Subject: pack: "fakechroot" execution engine can load its audit module. Fixes . Until now, loading 'pack-audit.so' in a truly non-Guix environment would usually fail because 'pack-audit.so' depends on 'libgcc_s.so' and 'libc.so', none of which could be found. Furthermore, the test was not working as expected: the trick unshare -mrf sh -c 'mount -t tmpfs none /gnu ; ...' would allow the fakechroot engine to make its store available as /gnu/store as a result of another bug. * gnu/packages/aux-files/run-in-namespace.c (relocated_search_path): New function. (exec_with_loader): Pass "--library-path" to the loader. * guix/scripts/pack.scm (wrapped-package)[build](runpath): New procedure. (elf-loader-compile-flags): Pass "-DLOADER_AUDIT_RUNPATH". * tests/guix-pack-relocatable.sh: Remove 'STORE_PARENT'. (run_without_store): New function. Erase $NIX_STORE_DIR instead of $STORE_PARENT. Use 'run_without_store' throughout. --- gnu/packages/aux-files/run-in-namespace.c | 48 +++++++++++++++++-- guix/scripts/pack.scm | 17 +++++++ tests/guix-pack-relocatable.sh | 76 +++++++++++++++---------------- 3 files changed, 99 insertions(+), 42 deletions(-) (limited to 'guix') diff --git a/gnu/packages/aux-files/run-in-namespace.c b/gnu/packages/aux-files/run-in-namespace.c index 5a6b932b87..7f7e5c6885 100644 --- a/gnu/packages/aux-files/run-in-namespace.c +++ b/gnu/packages/aux-files/run-in-namespace.c @@ -371,24 +371,64 @@ exec_with_proot (const char *store, int argc, char *argv[]) #if HAVE_EXEC_WITH_LOADER +/* Traverse PATH, a NULL-terminated string array, and return a colon-separated + search path where each item of PATH has been relocated to STORE. The + result is malloc'd. */ +static char * +relocated_search_path (const char *path[], const char *store) +{ + char *new_path; + size_t size = 0; + + for (size_t i = 0; path[i] != NULL; i++) + size += strlen (store) + strlen (path[i]) + 1; /* upper bound */ + + new_path = xmalloc (size + 1); + new_path[0] = '\0'; + + for (size_t i = 0; path[i] != NULL; i++) + { + if (strncmp (path[i], original_store, + sizeof original_store - 1) == 0) + { + strcat (new_path, store); + strcat (new_path, path[i] + sizeof original_store - 1); + } + else + strcat (new_path, path[i]); /* possibly $ORIGIN */ + + strcat (new_path, ":"); + } + + new_path[strlen (new_path) - 1] = '\0'; /* Remove trailing colon. */ + + return new_path; +} + /* Execute the wrapped program by invoking the loader (ld.so) directly, passing it the audit module and preloading libfakechroot.so. */ static void exec_with_loader (const char *store, int argc, char *argv[]) { + static const char *audit_library_path[] = LOADER_AUDIT_RUNPATH; char *loader = concat (store, PROGRAM_INTERPRETER + sizeof original_store); - size_t loader_specific_argc = 6; + size_t loader_specific_argc = 8; size_t loader_argc = argc + loader_specific_argc; char *loader_argv[loader_argc + 1]; loader_argv[0] = argv[0]; loader_argv[1] = "--audit"; loader_argv[2] = concat (store, LOADER_AUDIT_MODULE + sizeof original_store); - loader_argv[3] = "--preload"; - loader_argv[4] = concat (store, + + /* The audit module depends on libc.so and libgcc_s.so. */ + loader_argv[3] = "--library-path"; + loader_argv[4] = relocated_search_path (audit_library_path, store); + + loader_argv[5] = "--preload"; + loader_argv[6] = concat (store, FAKECHROOT_LIBRARY + sizeof original_store); - loader_argv[5] = concat (store, + loader_argv[7] = concat (store, "@WRAPPED_PROGRAM@" + sizeof original_store); for (size_t i = 0; i < argc; i++) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 5fb6aaae0c..75386deee7 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -744,11 +744,13 @@ (define build (with-imported-modules (source-module-closure '((guix build utils) (guix build union) + (guix build gremlin) (guix elf))) #~(begin (use-modules (guix build utils) ((guix build union) #:select (relative-file-name)) (guix elf) + (guix build gremlin) (ice-9 binary-ports) (ice-9 ftw) (ice-9 match) @@ -786,6 +788,14 @@ (define (elf-interpreter elf) bv 0 (bytevector-length bv)) (utf8->string bv))))) + (define (runpath file) + ;; Return the RUNPATH of FILE as a list of directories. + (let* ((bv (call-with-input-file file get-bytevector-all)) + (elf (parse-elf bv)) + (dyninfo (elf-dynamic-info elf))) + (or (and=> dyninfo elf-dynamic-info-runpath) + '()))) + (define (elf-loader-compile-flags program) ;; Return the cpp flags defining macros for the ld.so/fakechroot ;; wrapper of PROGRAM. @@ -807,6 +817,13 @@ (define (elf-loader-compile-flags program) (string-append "-DLOADER_AUDIT_MODULE=\"" #$(audit-module) "\"") + (string-append "-DLOADER_AUDIT_RUNPATH={ " + (string-join + (map object->string + (runpath + #$(audit-module))) + ", " 'suffix) + "NULL }") (if gconv (string-append "-DGCONV_DIRECTORY=\"" gconv "\"") diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh index 52d7212594..1ba3889036 100644 --- a/tests/guix-pack-relocatable.sh +++ b/tests/guix-pack-relocatable.sh @@ -38,51 +38,52 @@ then exit 77 fi -STORE_PARENT="`dirname $NIX_STORE_DIR`" -export STORE_PARENT -if test "$STORE_PARENT" = "/"; then exit 77; fi - -if unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"' -then - # Test the wrapper that relies on user namespaces. - relocatable_option="-R" -else - case "`uname -m`" in - x86_64|i?86) - # Test the wrapper that falls back to PRoot. - relocatable_option="-RR";; - *) - # XXX: Our 'proot' package currently fails tests on non-Intel - # architectures, so skip this by default. - exit 77;; - esac -fi +# Attempt to run the given command in a namespace where the store is +# invisible. This makes sure the presence of the store does not hide +# problems. +run_without_store () +{ + if unshare -r true # Are user namespaces supported? + then + # Run that relocatable executable in a user namespace where we "erase" + # the store by mounting an empty file system on top of it. That way, + # we exercise the wrapper code that creates the user namespace and + # bind-mounts the store. + unshare -mrf sh -c 'mount -t tmpfs -o ro none "$NIX_STORE_DIR"; '"$*" + else + # Run the relocatable program in the current namespaces. This is a + # weak test because we're going to access store items from the host + # store. + $* + fi +} test_directory="`mktemp -d`" export test_directory trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT -export relocatable_option -tarball="`guix pack $relocatable_option -S /Bin=bin sed`" -(cd "$test_directory"; tar xvf "$tarball") - -if unshare -r true # Are user namespaces supported? +if unshare -r true then - # Run that relocatable 'sed' in a user namespace where we "erase" the store by - # mounting an empty file system on top of it. That way, we exercise the - # wrapper code that creates the user namespace and bind-mounts the store. - unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"; echo "$STORE_PARENT"/*; "$test_directory/Bin/sed" --version > "$test_directory/output"' + # Test the 'userns' execution engine. + tarball="`guix pack -R -S /Bin=bin sed`" + (cd "$test_directory"; tar xvf "$tarball") + + run_without_store "$test_directory/Bin/sed" --version > "$test_directory/output" + grep 'GNU sed' "$test_directory/output" + + # Same with an explicit engine. + run_without_store GUIX_EXECUTION_ENGINE="userns" \ + "$test_directory/Bin/sed" --version > "$test_directory/output" + grep 'GNU sed' "$test_directory/output" # Check whether the exit code is preserved. - if unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"; echo "$STORE_PARENT"/*; "$test_directory/Bin/sed" --does-not-exist'; + if run_without_store "$test_directory/Bin/sed" --does-not-exist; then false; else true; fi + + chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/* else - # Run the relocatable 'sed' in the current namespaces. This is a weak - # test because we're going to access store items from the host store. - "$test_directory/Bin/sed" --version > "$test_directory/output" + echo "'userns' execution tests skipped" >&2 fi -grep 'GNU sed' "$test_directory/output" -chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/* case "`uname -m`" in x86_64|i?86) @@ -90,20 +91,19 @@ case "`uname -m`" in tarball="`guix pack -RR -S /Bin=bin sed`" tar tvf "$tarball" | grep /bin/proot (cd "$test_directory"; tar xvf "$tarball") - GUIX_EXECUTION_ENGINE="proot" - export GUIX_EXECUTION_ENGINE + run_without_store GUIX_EXECUTION_ENGINE="proot" \ "$test_directory/Bin/sed" --version > "$test_directory/output" grep 'GNU sed' "$test_directory/output" # Now with fakechroot. - GUIX_EXECUTION_ENGINE="fakechroot" + run_without_store GUIX_EXECUTION_ENGINE="fakechroot" \ "$test_directory/Bin/sed" --version > "$test_directory/output" grep 'GNU sed' "$test_directory/output" chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/* ;; *) - echo "skipping PRoot test" >&2 + echo "skipping PRoot and Fakechroot tests" >&2 ;; esac -- cgit v1.2.3 From c9c8c6331e51097652a28538ad3bd06e9ddac5c0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 30 Jul 2020 11:17:51 +0200 Subject: deploy: Gracefully handle errors. * guix/scripts/deploy.scm (guix-deploy): Wrap body in 'with-error-handling'. --- guix/scripts/deploy.scm | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 4466a0c632..09ad63c44a 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -140,18 +140,19 @@ (define (guix-deploy . args) (define (handle-argument arg result) (alist-cons 'file arg result)) - (let* ((opts (parse-command-line args %options (list %default-options) - #:argument-handler handle-argument)) - (file (assq-ref opts 'file)) - (machines (or (and file (load-source-file file)) '()))) - (show-what-to-deploy machines) - - (with-status-verbosity (assoc-ref opts 'verbosity) - (with-store store - (set-build-options-from-command-line store opts) - (with-build-handler (build-notifier #:use-substitutes? - (assoc-ref opts 'substitutes?)) - (parameterize ((%graft? (assq-ref opts 'graft?))) - (map/accumulate-builds store - (cut deploy-machine* store <>) - machines))))))) + (with-error-handling + (let* ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument)) + (file (assq-ref opts 'file)) + (machines (or (and file (load-source-file file)) '()))) + (show-what-to-deploy machines) + + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-store store + (set-build-options-from-command-line store opts) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?)) + (parameterize ((%graft? (assq-ref opts 'graft?))) + (map/accumulate-builds store + (cut deploy-machine* store <>) + machines)))))))) -- cgit v1.2.3 From 7caa3506eac288afcd224023ba526f27e3da893b Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Thu, 30 Jul 2020 09:01:39 +0200 Subject: guix: lint: Ignore unsupported source URL’s. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/lint.scm (check-source): Add match case for #f. Signed-off-by: Mathieu Othacehe --- guix/lint.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 8a55f3e744..71ce931964 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -794,6 +794,9 @@ (define (warnings-for-uris uris) (#t ;; We found a working URL, so stop right away. '()) + (#f + ;; Unsupported URL or other error, skip. + (loop rest warnings)) ((? lint-warning? warning) (loop rest (cons warning warnings)))))))) -- cgit v1.2.3 From a55d83b5460407fe1d5c828dddbb7de0cf749e2b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Jul 2020 23:11:56 +0200 Subject: ui: Add #:verbosity to 'show-what-to-build'. * guix/ui.scm (%default-verbosity): New variable. (show-what-to-build): Add #:verbosity and honor it. (build-notifier): Add #:verbosity and pass it to 'show-what-to-build'. --- guix/ui.scm | 175 +++++++++++++++++++++++++++++++++++++----------------------- 1 file changed, 109 insertions(+), 66 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 55460cef00..42afdc2856 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -951,17 +951,25 @@ (define (colorize-store-file-name file) (color DARK)) (string-drop file prefix))))) +(define %default-verbosity + ;; Default verbosity level for 'show-what-to-build'. + 2) + (define* (show-what-to-build store drv #:key dry-run? (use-substitutes? #t) + (verbosity %default-verbosity) (mode (build-mode normal))) "Show what will or would (depending on DRY-RUN?) be built in realizing the derivations listed in DRV using MODE, a 'build-mode' value. The elements of DRV can be either derivations or derivation inputs. Return two values: a Boolean indicating whether there's something to build, -and a Boolean indicating whether there's something to download. When -USE-SUBSTITUTES?, check and report what is prerequisites are available for -download." +and a Boolean indicating whether there's something to download. + +When USE-SUBSTITUTES?, check and report what is prerequisites are available +for download. VERBOSITY is an integer indicating the level of details to be +shown: level 2 and higher provide all the details, level 1 shows a high-level +summary, and level 0 shows nothing." (define inputs (map (match-lambda ((? derivation? drv) (derivation-input drv)) @@ -1020,71 +1028,104 @@ (define display-download-size? ;; display when we have information for all of DOWNLOAD. (not (any (compose zero? substitutable-download-size) download))) + ;; Combinatorial explosion ahead along two axes: DRY-RUN? and VERBOSITY. + ;; Unfortunately, this is hardly avoidable for proper i18n. (if dry-run? (begin - (format (current-error-port) - (N_ "~:[The following derivation would be built:~%~{ ~a~%~}~;~]" - "~:[The following derivations would be built:~%~{ ~a~%~}~;~]" - (length build)) - (null? build) (map colorized-store-item build)) - (if display-download-size? - (format (current-error-port) - ;; TRANSLATORS: "MB" is for "megabyte"; it should be - ;; translated to the corresponding abbreviation. - (G_ "~:[~,1h MB would be downloaded:~%~{ ~a~%~}~;~]") - (null? download) - download-size - (map (compose colorized-store-item substitutable-path) - download)) - (format (current-error-port) - (N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]" - "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]" - (length download)) - (null? download) - (map (compose colorized-store-item substitutable-path) - download))) - (format (current-error-port) - (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]" - "~:[The following grafts would be made:~%~{ ~a~%~}~;~]" - (length graft)) - (null? graft) (map colorized-store-item graft)) - (format (current-error-port) - (N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]" - "~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]" - (length hook)) - (null? hook) (map colorized-store-item hook))) + (unless (zero? verbosity) + (format (current-error-port) + (N_ "~:[The following derivation would be built:~%~{ ~a~%~}~;~]" + "~:[The following derivations would be built:~%~{ ~a~%~}~;~]" + (length build)) + (null? build) (map colorized-store-item build))) + (cond ((>= verbosity 2) + (if display-download-size? + (format (current-error-port) + ;; TRANSLATORS: "MB" is for "megabyte"; it should be + ;; translated to the corresponding abbreviation. + (G_ "~:[~,1h MB would be downloaded:~%~{ ~a~%~}~;~]") + (null? download) + download-size + (map (compose colorized-store-item substitutable-path) + download)) + (format (current-error-port) + (N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]" + "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]" + (length download)) + (null? download) + (map (compose colorized-store-item substitutable-path) + download))) + (format (current-error-port) + (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]" + "~:[The following grafts would be made:~%~{ ~a~%~}~;~]" + (length graft)) + (null? graft) (map colorized-store-item graft)) + (format (current-error-port) + (N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]" + "~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]" + (length hook)) + (null? hook) (map colorized-store-item hook))) + ((= verbosity 1) + ;; Display the bare minimum; don't mention grafts and hooks. + (if display-download-size? + (format (current-error-port) + ;; TRANSLATORS: "MB" is for "megabyte"; it should be + ;; translated to the corresponding abbreviation. + (G_ "~:[~,1h MB would be downloaded~%~;~]") + (null? download) download-size) + (format (current-error-port) + (N_ "~:[~h item would be downloaded~%~;~]" + "~:[~h items would be downloaded~%~;~]" + (length download)) + (null? download) (length download)))))) + (begin - (format (current-error-port) - (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]" - "~:[The following derivations will be built:~%~{ ~a~%~}~;~]" - (length build)) - (null? build) (map colorized-store-item build)) - (if display-download-size? - (format (current-error-port) - ;; TRANSLATORS: "MB" is for "megabyte"; it should be - ;; translated to the corresponding abbreviation. - (G_ "~:[~,1h MB will be downloaded:~%~{ ~a~%~}~;~]") - (null? download) - download-size - (map (compose colorized-store-item substitutable-path) - download)) - (format (current-error-port) - (N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]" - "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]" - (length download)) - (null? download) - (map (compose colorized-store-item substitutable-path) - download))) - (format (current-error-port) - (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]" - "~:[The following grafts will be made:~%~{ ~a~%~}~;~]" - (length graft)) - (null? graft) (map colorized-store-item graft)) - (format (current-error-port) - (N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]" - "~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]" - (length hook)) - (null? hook) (map colorized-store-item hook)))) + (unless (zero? verbosity) + (format (current-error-port) + (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]" + "~:[The following derivations will be built:~%~{ ~a~%~}~;~]" + (length build)) + (null? build) (map colorized-store-item build))) + (cond ((>= verbosity 2) + (if display-download-size? + (format (current-error-port) + ;; TRANSLATORS: "MB" is for "megabyte"; it should be + ;; translated to the corresponding abbreviation. + (G_ "~:[~,1h MB will be downloaded:~%~{ ~a~%~}~;~]") + (null? download) + download-size + (map (compose colorized-store-item substitutable-path) + download)) + (format (current-error-port) + (N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]" + "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]" + (length download)) + (null? download) + (map (compose colorized-store-item substitutable-path) + download))) + (format (current-error-port) + (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]" + "~:[The following grafts will be made:~%~{ ~a~%~}~;~]" + (length graft)) + (null? graft) (map colorized-store-item graft)) + (format (current-error-port) + (N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]" + "~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]" + (length hook)) + (null? hook) (map colorized-store-item hook))) + ((= verbosity 1) + ;; Display the bare minimum; don't mention grafts and hooks. + (if display-download-size? + (format (current-error-port) + ;; TRANSLATORS: "MB" is for "megabyte"; it should be + ;; translated to the corresponding abbreviation. + (G_ "~:[~,1h MB will be downloaded~%~;~]") + (null? download) download-size) + (format (current-error-port) + (N_ "~:[~h item will be downloaded~%~;~]" + "~:[~h items will be downloaded~%~;~]" + (length download)) + (null? download) (length download))))))) (check-available-space installed-size) @@ -1093,7 +1134,8 @@ (define display-download-size? (define show-what-to-build* (store-lift show-what-to-build)) -(define* (build-notifier #:key (dry-run? #f) (use-substitutes? #t)) +(define* (build-notifier #:key (dry-run? #f) (use-substitutes? #t) + (verbosity %default-verbosity)) "Return a procedure suitable for 'with-build-handler' that, when 'build-things' is called, invokes 'show-what-to-build' to display the build plan. When DRY-RUN? is true, the 'with-build-handler' form returns without @@ -1127,6 +1169,7 @@ (define inputs (show-what-to-build store inputs #:dry-run? dry-run? #:use-substitutes? use-substitutes? + #:verbosity verbosity #:mode mode))) (unless (and (or build? download?) -- cgit v1.2.3 From 898e6d0a07e4260600d0876d8d1f551ac8b647f9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Jul 2020 23:22:13 +0200 Subject: scripts: Pass #:verbosity to 'build-notifier'. * guix/scripts/archive.scm (guix-archive): Pass #:verbosity to 'build-notifier'. * guix/scripts/build.scm (guix-build): Likewise. * guix/scripts/copy.scm (guix-copy): Likewise. * guix/scripts/deploy.scm (guix-deploy): Likewise. * guix/scripts/environment.scm (guix-environment): Likewise. * guix/scripts/pack.scm (guix-pack): Likewise. * guix/scripts/package.scm (guix-package*): Likewise. * guix/scripts/pull.scm (guix-pull): Likewise. * guix/scripts/system.scm (verbosity-level): New procedure. (process-action): Pass #:verbosity to 'build-notifier'. (guix-system): Use 'verbosity-level' for 'with-status-verbosity'. --- guix/scripts/archive.scm | 2 ++ guix/scripts/build.scm | 2 ++ guix/scripts/copy.scm | 2 ++ guix/scripts/deploy.scm | 4 +++- guix/scripts/environment.scm | 2 ++ guix/scripts/pack.scm | 2 ++ guix/scripts/package.scm | 2 ++ guix/scripts/pull.scm | 2 ++ guix/scripts/system.scm | 11 +++++++++-- 9 files changed, 26 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 41a2a42c21..f3b86fba14 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -380,6 +380,8 @@ (define (lines port) (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (cond ((assoc-ref opts 'export) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 8ff2fd1910..6286a43c02 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -961,6 +961,8 @@ (define graft? (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (parameterize ((current-terminal-columns (terminal-columns)) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index f6f64d0a11..16d2de30f7 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -175,6 +175,8 @@ (define (guix-copy . args) (set-build-options-from-command-line store opts) (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (with-status-verbosity (assoc-ref opts 'verbosity) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 09ad63c44a..4a68197620 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -151,7 +151,9 @@ (define (handle-argument arg result) (with-store store (set-build-options-from-command-line store opts) (with-build-handler (build-notifier #:use-substitutes? - (assoc-ref opts 'substitutes?)) + (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity)) (parameterize ((%graft? (assq-ref opts 'graft?))) (map/accumulate-builds store (cut deploy-machine* store <>) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index d3b8b57ccc..b8979cac19 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -708,6 +708,8 @@ (define (guix-environment . args) (with-store store (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (with-status-verbosity (assoc-ref opts 'verbosity) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 75386deee7..9d6881fdaf 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1153,6 +1153,8 @@ (define with-provenance (with-build-handler (build-notifier #:dry-run? (assoc-ref opts 'dry-run?) + #:verbosity + (assoc-ref opts 'verbosity) #:use-substitutes? (assoc-ref opts 'substitutes?)) (parameterize ((%graft? (assoc-ref opts 'graft?)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 1246147798..ac8dedb5f3 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -965,6 +965,8 @@ (define (guix-package* opts) (set-build-options-from-command-line (%store) opts) (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (parameterize ((%guile-for-build diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 807daec593..5b4ccf13fe 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -773,6 +773,8 @@ (define (guix-pull . args) (%graft? (assoc-ref opts 'graft?))) (with-build-handler (build-notifier #:use-substitutes? substitutes? + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? dry-run?) (set-build-options-from-command-line store opts) (ensure-default-profile) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index bfd50c7a79..f6d20382b6 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1067,6 +1067,12 @@ (define %default-options (image-size . guess) (install-bootloader? . #t))) +(define (verbosity-level opts) + "Return the verbosity level based on OPTS, the alist of parsed options." + (or (assoc-ref opts 'verbosity) + (if (eq? (assoc-ref opts 'action) 'build) + 2 1))) + ;;; ;;; Entry point. @@ -1126,6 +1132,8 @@ (define save-provenance? (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (verbosity-level opts) #:dry-run? (assoc-ref opts 'dry-run?)) (run-with-store store @@ -1282,8 +1290,7 @@ (define (fail) (args (option-arguments opts)) (command (assoc-ref opts 'action))) (parameterize ((%graft? (assoc-ref opts 'graft?))) - (with-status-verbosity (or (assoc-ref opts 'verbosity) - (if (eq? command 'build) 2 1)) + (with-status-verbosity (verbosity-level opts) (process-command command args opts)))))) ;;; Local Variables: -- cgit v1.2.3 From 05f3d34094b23dc9612ff6641a0257bc4f7dcd12 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 4 Aug 2020 21:27:30 +0200 Subject: ui: Report key-and-arg exceptions correctly. Fixes . Reported by Jan Wielkiewicz . Regression introduced in efe037fc5cc3134bbc3ef4e36b49a3f788921b68 whereby errors like 'wrong-type-arg' would be improperly reported: guix environment: error: Wrong type argument in position ~A (expecting ~A): ~S See also commit a07d5e558b5403dad0a59776b950b6b02169c249. * guix/ui.scm (call-with-error-handling): Move 'message-condition?' clause after '&exception-with-kind-and-args' clause. --- guix/ui.scm | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 42afdc2856..efc3f39186 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -795,14 +795,6 @@ (define (manifest-entry-output* entry) (invoke-error-stop-signal c) (cons (invoke-error-program c) (invoke-error-arguments c)))) - ((message-condition? c) - ;; Normally '&message' error conditions have an i18n'd message. - (report-error (and (error-location? c) (error-location c)) - (G_ "~a~%") - (gettext (condition-message c) %gettext-domain)) - (when (fix-hint? c) - (display-hint (condition-fix-hint c))) - (exit 1)) ((formatted-message? c) (apply report-error @@ -825,7 +817,16 @@ (define (manifest-entry-output* entry) (guile-3 ((exception-predicate &exception-with-kind-and-args) c)) (else #f)) - (raise c))) + (raise c)) + + ((message-condition? c) + ;; Normally '&message' error conditions have an i18n'd message. + (report-error (and (error-location? c) (error-location c)) + (G_ "~a~%") + (gettext (condition-message c) %gettext-domain)) + (when (fix-hint? c) + (display-hint (condition-fix-hint c))) + (exit 1))) ;; Catch EPIPE and the likes. (catch 'system-error thunk -- cgit v1.2.3 From bc2b1484f781f3a660ccad5c5b8e4c3f5d9cbe90 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 7 Aug 2020 11:26:07 +0200 Subject: ssh: Really report Guile setup errors in 'send-files'. This is a followup to commit 8f53d73493a2949e2db28cd7d689a690b2d9479a, which did not have the desired effect: the 'resolve-module' call was bound to succeed since the inferior runs 'guix repl'. * guix/ssh.scm (store-import-channel)[import]: Add call to 'resolve-module' and write '(module-error) upon error. Write '(importing) when we're ready. (send-files)[inferior-remote-eval*]: Remove. [missing]: Remove call to 'resolve-module'. Call 'handle-import/export-channel-error' when PORT doesn't return '(importing). (handle-import/export-channel-error): New procedure. (retrieve-files*): Use it. --- guix/ssh.scm | 73 ++++++++++++++++++++++++++++++++++-------------------------- 1 file changed, 41 insertions(+), 32 deletions(-) (limited to 'guix') diff --git a/guix/ssh.scm b/guix/ssh.scm index a36f72bb67..24db171374 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -283,6 +283,11 @@ (define (store-import-channel session) ;; consumed. (define import `(begin + (eval-when (load expand eval) + (unless (resolve-module '(guix) #:ensure #f) + (write `(module-error)) + (exit 7))) + (use-modules (guix) (srfi srfi-34) (rnrs io ports) (rnrs bytevectors)) @@ -305,6 +310,9 @@ (define (consume-input port) (consume-input (current-input-port)) (list 'protocol-error (nix-protocol-error-message c)))) (with-store store + (write '(importing)) ;we're ready + (force-output) + (setvbuf (current-input-port) 'none) (import-paths store (current-input-port)) '(success)))) @@ -401,24 +409,11 @@ (define* (send-files local files remote "Send the subset of FILES from LOCAL (a local store) that's missing to REMOTE, a remote store. When RECURSIVE? is true, send the closure of FILES. Return the list of store items actually sent." - (define (inferior-remote-eval* exp session) - (guard (c ((inferior-exception? c) - (match (inferior-exception-arguments c) - (('quit 7) - (report-module-error (remote-store-host remote))) - (_ - (report-inferior-exception c (remote-store-host remote)))))) - (inferior-remote-eval exp session))) - ;; Compute the subset of FILES missing on SESSION and send them. (let* ((files (if recursive? (requisites local files) files)) (session (channel-get-session (store-connection-socket remote))) - (missing (inferior-remote-eval* + (missing (inferior-remote-eval `(begin - (eval-when (load expand eval) - (unless (resolve-module '(guix) #:ensure #f) - (exit 7))) - (use-modules (guix) (srfi srfi-1) (srfi srfi-26)) @@ -431,6 +426,13 @@ (define (inferior-remote-eval* exp session) (path-info-nar-size (query-path-info local item))) missing)) (port (store-import-channel session))) + ;; Make sure everything alright on the remote side. + (match (read port) + (('importing) + #t) + (sexp + (handle-import/export-channel-error sexp remote))) + (format log-port (N_ "sending ~a store item (~h MiB) to '~a'...~%" "sending ~a store items (~h MiB) to '~a'...~%" count) count @@ -505,6 +507,29 @@ (define-syntax raise-error (&message (message (format #f fmt args ...)))))))) +(define (handle-import/export-channel-error sexp remote) + "Report an error corresponding to SEXP, the EOF object or an sexp read from +REMOTE." + (match sexp + ((? eof-object?) + (report-guile-error (remote-store-host remote))) + (('module-error . _) + (report-module-error (remote-store-host remote))) + (('connection-error file code . _) + (raise-error (G_ "failed to connect to '~A' on remote host '~A': ~a") + file (remote-store-host remote) (strerror code))) + (('invalid-items items . _) + (raise-error (N_ "no such item on remote host '~A':~{ ~a~}" + "no such items on remote host '~A':~{ ~a~}" + (length items)) + (remote-store-host remote) items)) + (('protocol-error status message . _) + (raise-error (G_ "protocol error on remote host '~A': ~a") + (remote-store-host remote) message)) + (_ + (raise-error (G_ "failed to retrieve store items from '~a'") + (remote-store-host remote))))) + (define* (retrieve-files* files remote #:key recursive? (log-port (current-error-port)) (import (const #f))) @@ -525,24 +550,8 @@ (define* (retrieve-files* files remote (import port)) (lambda () (close-port port)))) - ((? eof-object?) - (report-guile-error (remote-store-host remote))) - (('module-error . _) - (report-module-error (remote-store-host remote))) - (('connection-error file code . _) - (raise-error (G_ "failed to connect to '~A' on remote host '~A': ~a") - file (remote-store-host remote) (strerror code))) - (('invalid-items items . _) - (raise-error (N_ "no such item on remote host '~A':~{ ~a~}" - "no such items on remote host '~A':~{ ~a~}" - (length items)) - (remote-store-host remote) items)) - (('protocol-error status message . _) - (raise-error (G_ "protocol error on remote host '~A': ~a") - (remote-store-host remote) message)) - (_ - (raise-error (G_ "failed to retrieve store items from '~a'") - (remote-store-host remote)))))) + (sexp + (handle-import/export-channel-error sexp remote))))) (define* (retrieve-files local files remote #:key recursive? (log-port (current-error-port))) -- cgit v1.2.3 From d98e0a27a7c5e34837fff4edd42a641828070213 Mon Sep 17 00:00:00 2001 From: Morgan Smith Date: Sun, 2 Aug 2020 14:26:52 -0400 Subject: build-system/emacs: Allow usage of #:parallel-tests? key MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/build-system/emacs.scm (emacs-build): Pass parallel-tests? to builder. Signed-off-by: Jakub Kądziołka --- guix/build-system/emacs.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') diff --git a/guix/build-system/emacs.scm b/guix/build-system/emacs.scm index ef6d1b3397..ac05ff420e 100644 --- a/guix/build-system/emacs.scm +++ b/guix/build-system/emacs.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa +;;; Copyright © 2020 Morgan Smith ;;; ;;; This file is part of GNU Guix. ;;; @@ -112,6 +113,7 @@ (define builder #:system ,system #:test-command ,test-command #:tests? ,tests? + #:parallel-tests? ,parallel-tests? #:phases ,phases #:outputs %outputs #:include ,include -- cgit v1.2.3 From 67cb9fa2357026ee42ec5bb0923ec4dc4a43abe2 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 16 Jun 2020 22:25:48 +0200 Subject: build-system/haskell: Support parallel builds. * guix/build-system/haskell.scm (haskell-build): Add keyword PARALLEL-BUILD? and pass it on to the builder. * guix/build/haskell-build-system.scm (build): Accept keyword PARALLEL-BUILD? and pass the number of parallel jobs to GHC. --- guix/build-system/haskell.scm | 2 ++ guix/build/haskell-build-system.scm | 7 +++++-- 2 files changed, 7 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index 1ec11c71d8..ab93c9601c 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -105,6 +105,7 @@ (define* (haskell-build store name inputs (haddock-flags ''()) (tests? #t) (test-target "test") + (parallel-build? #t) (configure-flags ''()) (phases '(@ (guix build haskell-build-system) %standard-phases)) @@ -138,6 +139,7 @@ (define builder #:system ,system #:test-target ,test-target #:tests? ,tests? + #:parallel-build? ,parallel-build? #:haddock? ,haddock? #:phases ,phases #:outputs %outputs diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 91f62138d0..5fd0c7dbfe 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -121,9 +121,12 @@ (define* (configure #:key outputs inputs tests? (configure-flags '()) (setenv "GHC_PACKAGE_PATH" ghc-path) #t)) -(define* (build #:rest empty) +(define* (build #:key parallel-build? #:allow-other-keys) "Build a given Haskell package." - (run-setuphs "build" '())) + (run-setuphs "build" + (if parallel-build? + `(,(string-append "--ghc-option=-j" (number->string (parallel-job-count)))) + '()))) (define* (install #:rest empty) "Install a given Haskell package." -- cgit v1.2.3 From 0347888a7ec3a11c050c4269533c8d69197a4c6e Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 24 Jun 2020 23:12:06 +0200 Subject: build-system/haskell: Refactor configure step. * guix/build/haskell-build-system.scm (configure): Replace append with quasiquotes and splicing. --- guix/build/haskell-build-system.scm | 35 ++++++++++++++++------------------- 1 file changed, 16 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 5fd0c7dbfe..a8cd62d03c 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -85,25 +85,22 @@ (define* (configure #:key outputs inputs tests? (configure-flags '()) dir) (_ '()))) (ghc-path (getenv "GHC_PACKAGE_PATH")) - (params (append `(,(string-append "--prefix=" out)) - `(,(string-append "--libdir=" (or lib out) "/lib")) - `(,(string-append "--bindir=" (or bin out) "/bin")) - `(,(string-append - "--docdir=" (or doc out) - "/share/doc/" name-version)) - '("--libsubdir=$compiler/$pkg-$version") - `(,(string-append "--package-db=" %tmp-db-dir)) - '("--global") - `(,@(map - (cut string-append "--extra-include-dirs=" <>) - (search-path-as-list '("include") input-dirs))) - `(,@(map - (cut string-append "--extra-lib-dirs=" <>) - (search-path-as-list '("lib") input-dirs))) - (if tests? - '("--enable-tests") - '()) - configure-flags))) + (params `(,(string-append "--prefix=" out) + ,(string-append "--libdir=" (or lib out) "/lib") + ,(string-append "--bindir=" (or bin out) "/bin") + ,(string-append "--docdir=" (or doc out) + "/share/doc/" name-version) + "--libsubdir=$compiler/$pkg-$version" + ,(string-append "--package-db=" %tmp-db-dir) + "--global" + ,@(map (cut string-append "--extra-include-dirs=" <>) + (search-path-as-list '("include") input-dirs)) + ,@(map (cut string-append "--extra-lib-dirs=" <>) + (search-path-as-list '("lib") input-dirs)) + ,@(if tests? + '("--enable-tests") + '()) + ,@configure-flags))) ;; Cabal errors if GHC_PACKAGE_PATH is set during 'configure', so unset ;; and restore it. (unsetenv "GHC_PACKAGE_PATH") -- cgit v1.2.3 From 9e5496e0ae0ee8f638ca93949ecca314fdb9251e Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 24 Jun 2020 23:46:57 +0200 Subject: build-system/haskell: Configure to link with shared libraries. * guix/build/haskell-build-system.scm (configure): Add configure flags to build shared libraries by default, to generate position independent code, and to set the RUNPATH. --- guix/build/haskell-build-system.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'guix') diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index a8cd62d03c..f57981511a 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -100,6 +100,12 @@ (define* (configure #:key outputs inputs tests? (configure-flags '()) ,@(if tests? '("--enable-tests") '()) + ;; Build and link with shared libraries + "--enable-shared" + "--enable-executable-dynamic" + "--ghc-option=-fPIC" + ,(string-append "--ghc-option=-optl=-Wl,-rpath=" (or lib out) + "/lib/$compiler/$pkg-$version") ,@configure-flags))) ;; Cabal errors if GHC_PACKAGE_PATH is set during 'configure', so unset ;; and restore it. -- cgit v1.2.3 From 718dc7d4a5e5d26cac80c79d78535677e0379dc8 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 16 Jun 2020 22:28:54 +0200 Subject: build-system/haskell: Add default output "static". * guix/build-system/haskell.scm (lower): Add OUTPUTS keyword and add the "static" output in the common case. (haskell-build): Set the default value for the OUTPUTS keyword to include the "static" output. * guix/build/haskell-build-system.scm (install): Move static libraries to the "static" output if it exists. --- guix/build-system/haskell.scm | 9 ++++++--- guix/build/haskell-build-system.scm | 17 ++++++++++++++--- 2 files changed, 20 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index ab93c9601c..f92fbcd713 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -67,7 +67,7 @@ (define* (lower name #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:target #:haskell #:cabal-revision #:inputs #:native-inputs)) + '(#:target #:haskell #:cabal-revision #:inputs #:native-inputs #:outputs)) (define (cabal-revision->origin cabal-revision) (match cabal-revision @@ -95,7 +95,10 @@ (define (cabal-revision->origin cabal-revision) ,@(standard-packages))) (build-inputs `(("haskell" ,haskell) ,@native-inputs)) - (outputs outputs) + ;; XXX: this is a hack to get around issue #41569. + (outputs (match outputs + (("out") (cons "static" outputs)) + (_ outputs))) (build haskell-build) (arguments (strip-keyword-arguments private-keywords arguments))))) @@ -109,7 +112,7 @@ (define* (haskell-build store name inputs (configure-flags ''()) (phases '(@ (guix build haskell-build-system) %standard-phases)) - (outputs '("out")) + (outputs '("out" "static")) (search-paths '()) (system (%current-system)) (guile #f) diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index f57981511a..46104cfb19 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2015 Federico Beffa ;;; Copyright © 2015 Eric Bavier ;;; Copyright © 2015 Paul van der Walt -;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2018, 2020 Ricardo Wurmus ;;; Copyright © 2018 Alex Vong ;;; ;;; This file is part of GNU Guix. @@ -131,9 +131,20 @@ (define* (build #:key parallel-build? #:allow-other-keys) `(,(string-append "--ghc-option=-j" (number->string (parallel-job-count)))) '()))) -(define* (install #:rest empty) +(define* (install #:key outputs #:allow-other-keys) "Install a given Haskell package." - (run-setuphs "copy" '())) + (run-setuphs "copy" '()) + (when (assoc-ref outputs "static") + (let ((static (assoc-ref outputs "static")) + (lib (or (assoc-ref outputs "lib") + (assoc-ref outputs "out")))) + (for-each (lambda (static-lib) + (let* ((subdir (string-drop static-lib (string-length lib))) + (new (string-append static subdir))) + (mkdir-p (dirname new)) + (rename-file static-lib new))) + (find-files lib "\\.a$")))) + #t) (define (grep rx port) "Given a regular-expression RX including a group, read from PORT until the -- cgit v1.2.3 From 75bda3c648ae06a08c7512240698837ddf297182 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 16 Jun 2020 22:32:09 +0200 Subject: haskell-build-system: register: Respect lib output. * guix/build/haskell-build-system.scm (register): Use lib output if it exists. --- guix/build/haskell-build-system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 46104cfb19..86681bb7a7 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -246,7 +246,7 @@ (define (install-transitive-deps conf-file src dest) (let* ((out (assoc-ref outputs "out")) (haskell (assoc-ref inputs "haskell")) (name-verion (strip-store-file-name haskell)) - (lib (string-append out "/lib")) + (lib (string-append (or (assoc-ref outputs "lib") out) "/lib")) (config-dir (string-append lib "/" name-verion "/" name ".conf.d")) -- cgit v1.2.3 From 3f7922cbf5f43418d0cb6d44ba4903f33db8ac61 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 16 Jun 2020 22:34:37 +0200 Subject: haskell-build-system: register: Remove references to the doc output. * guix/build/haskell-build-system.scm (register): Strip references to the doc output from the generated package config files; move the haddock files from the "doc" output to the "lib" output. --- guix/build/haskell-build-system.scm | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 86681bb7a7..d587962b8b 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -244,6 +244,7 @@ (define (install-transitive-deps conf-file src dest) (loop seen tail)))))) (let* ((out (assoc-ref outputs "out")) + (doc (assoc-ref outputs "doc")) (haskell (assoc-ref inputs "haskell")) (name-verion (strip-store-file-name haskell)) (lib (string-append (or (assoc-ref outputs "lib") out) "/lib")) @@ -258,8 +259,25 @@ (define (install-transitive-deps conf-file src dest) ;; The conf file is created only when there is a library to register. (when (file-exists? config-file) (mkdir-p config-dir) - (let* ((config-file-name+id - (call-with-ascii-input-file config-file (cut grep id-rx <>)))) + (let ((config-file-name+id + (call-with-ascii-input-file config-file (cut grep id-rx <>)))) + + ;; Remove reference to "doc" output from "lib" (or "out") by rewriting the + ;; "haddock-interfaces" field and removing the optional "haddock-html" + ;; field in the generated .conf file. + (when doc + (substitute* config-file + (("^haddock-html: .*") "\n") + (((format #f "^haddock-interfaces: ~a" doc)) + (string-append "haddock-interfaces: " lib))) + ;; Move the referenced file to the "lib" (or "out") output. + (match (find-files doc "\\.haddock$") + ((haddock-file . rest) + (let* ((subdir (string-drop haddock-file (string-length doc))) + (new (string-append lib subdir))) + (mkdir-p (dirname new)) + (rename-file haddock-file new))) + (_ #f))) (install-transitive-deps config-file %tmp-db-dir config-dir) (rename-file config-file (string-append config-dir "/" -- cgit v1.2.3 From 54a5fd0791f15108d7c06f0b439e75e049fde249 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Sat, 8 Aug 2020 16:36:35 -0400 Subject: build-system/haskell: Add 'extra-directories' keyword. See . * guix/build-system/haskell.scm (lower): Include the transitive propagated inputs of 'extra-directories' inputs. (haskell-build): Add the 'extra-directories' keyword and pass it through to the builder. * guix/build/haskell-build-system.scm (configure): Use it to select which inputs get passed via 'extra-include-dirs' and 'extra-lib-dirs' to Cabal. * gnu/packages/haskell-xyz.scm (ghc-alsa-core, ghc-hmatrix, ghc-hmatrix-gsl, ghc-hslua, ghc-iwlib, ghc-libyaml, ghc-ncurses, ghc-openglraw, ghc-x11, ghc-x11-xft, ghc-zlib): Set 'extra-directories'. * gnu/packages/haskell-crypto.scm (ghc-digest, ghc-hsopenssl): Likewise. --- gnu/packages/haskell-crypto.scm | 4 ++++ gnu/packages/haskell-xyz.scm | 27 +++++++++++++++++++++++---- guix/build-system/haskell.scm | 17 ++++++++++++++++- guix/build/haskell-build-system.scm | 11 ++++------- 4 files changed, 47 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/gnu/packages/haskell-crypto.scm b/gnu/packages/haskell-crypto.scm index b9b350b61a..3c863f6cfa 100644 --- a/gnu/packages/haskell-crypto.scm +++ b/gnu/packages/haskell-crypto.scm @@ -343,6 +343,8 @@ (define-public ghc-digest (base32 "04gy2zp8yzvv7j9bdfvmfzcz3sqyqa6rwslqcn4vyair2vmif5v4")))) (build-system haskell-build-system) + (arguments + `(#:extra-directories ("zlib"))) (inputs `(("zlib" ,zlib))) (home-page @@ -790,6 +792,8 @@ (define-public ghc-hsopenssl (base32 "0qivl9clmybfglwxqp2sq308rv4ia4rhwshcsc8b029bvpp0mpsi")))) (build-system haskell-build-system) + (arguments + `(#:extra-directories ("openssl"))) (inputs `(("ghc-network" ,ghc-network) ("openssl" ,openssl))) diff --git a/gnu/packages/haskell-xyz.scm b/gnu/packages/haskell-xyz.scm index a9a5f8afe6..77288784d8 100644 --- a/gnu/packages/haskell-xyz.scm +++ b/gnu/packages/haskell-xyz.scm @@ -327,6 +327,8 @@ (define-public ghc-alsa-core (base32 "1avh4a419h9d2zsslg6j8hm87ppgsgqafz8ll037rk2yy1g4jl7b")))) (build-system haskell-build-system) + (arguments + `(#:extra-directories ("alsa-lib"))) (inputs `(("ghc-extensible-exceptions" ,ghc-extensible-exceptions) ("alsa-lib" ,alsa-lib))) @@ -5636,6 +5638,8 @@ (define-public ghc-hmatrix (sha256 (base32 "1sqy1aci5zfagkb34mz3xdil7cl96z4b4cx28cha54vc5sx1lhpg")))) (build-system haskell-build-system) + (arguments + `(#:extra-directories ("lapack"))) (inputs `(("ghc-random" ,ghc-random) ("ghc-split" ,ghc-split) @@ -5667,6 +5671,8 @@ (define-public ghc-hmatrix-gsl (sha256 (base32 "0v6dla426x4ywaq59jm89ql1i42n39iw6z0j378xwb676v9kfxhm")))) (build-system haskell-build-system) + (arguments + `(#:extra-directories ("gsl"))) (inputs `(("ghc-hmatrix" ,ghc-hmatrix) ("ghc-vector" ,ghc-vector) @@ -5884,7 +5890,8 @@ (define-public ghc-hslua "183bgl5jcx5y2r94lviqfw0a5w9089nxjd1z40k8vx9y2h60pm6j")))) (build-system haskell-build-system) (arguments - `(#:configure-flags '("-fsystem-lua"))) + `(#:configure-flags '("-fsystem-lua") + #:extra-directories ("lua"))) (inputs `(("lua" ,lua) ("ghc-exceptions" ,ghc-exceptions) @@ -6494,6 +6501,8 @@ (define-public ghc-iwlib (sha256 (base32 "0khmfwql4vwj55idsxmhjhrbqzfir3g9wm5lmpvnf77mm95cfpdz")))) (build-system haskell-build-system) + (arguments + `(#:extra-directories ("wireless-tools"))) (inputs `(("wireless-tools" ,wireless-tools))) (home-page "https://github.com/jaor/iwlib") @@ -6876,7 +6885,8 @@ (define-public ghc-libyaml #t)))) (build-system haskell-build-system) (arguments - `(#:configure-flags `("--flags=system-libyaml"))) + `(#:configure-flags `("--flags=system-libyaml") + #:extra-directories ("libyaml"))) (inputs `(("ghc-conduit" ,ghc-conduit) ("ghc-resourcet" ,ghc-resourcet) @@ -8090,7 +8100,8 @@ (define-public ghc-ncurses "0gsyyaqyh5r9zc0rhwpj5spyd6i4w2vj61h4nihgmmh0yyqvf3z5")))) (build-system haskell-build-system) (arguments - '(#:phases + '(#:extra-directories ("ncurses") + #:phases (modify-phases %standard-phases (add-before 'build 'fix-includes (lambda _ @@ -8458,6 +8469,8 @@ (define-public ghc-openglraw (base32 "0zgllb4bcash2i2cispa3j565aw3dpxs41ghmhpvyvi4a6xmyldx")))) (build-system haskell-build-system) + (arguments + `(#:extra-directories ("glu"))) (inputs `(("ghc-half" ,ghc-half) ("ghc-fixed" ,ghc-fixed) @@ -14292,6 +14305,9 @@ (define-public ghc-x11 (sha256 (base32 "0gg6852mrlgl8zng1j84fismz7k81jr5fk92glgkscf8q6ryg0bm")))) (build-system haskell-build-system) + (arguments + `(#:extra-directories + ("libx11" "libxrandr" "libxinerama" "libxscrnsaver"))) (inputs `(("libx11" ,libx11) ("libxrandr" ,libxrandr) @@ -14316,6 +14332,8 @@ (define-public ghc-x11-xft "X11-xft-" version ".tar.gz")) (sha256 (base32 "1lgqb0s2qfwwgbvwxhjbi23rbwamzdi0l0slfr20c3jpcbp3zfjf")))) + (arguments + `(#:extra-directories ("libx11" "libxft" "xorgproto"))) (inputs `(("ghc-x11" ,ghc-x11) ("ghc-utf8-string" ,ghc-utf8-string) @@ -14516,7 +14534,8 @@ (define-public ghc-zlib "1l11jraslcrp9d4wnhwfyhwk4fsiq1aq8i6vj81vcq1m2zzi1y7h")))) (build-system haskell-build-system) (arguments - `(#:phases + `(#:extra-directories ("zlib") + #:phases (modify-phases %standard-phases (add-before 'configure 'strip-test-framework-constraints (lambda _ diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index f92fbcd713..8304e3b222 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa +;;; Copyright © 2020 Timothy Sample ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ (define-module (guix build-system haskell) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%haskell-build-system-modules haskell-build @@ -100,7 +102,18 @@ (define (cabal-revision->origin cabal-revision) (("out") (cons "static" outputs)) (_ outputs))) (build haskell-build) - (arguments (strip-keyword-arguments private-keywords arguments))))) + (arguments + (substitute-keyword-arguments + (strip-keyword-arguments private-keywords arguments) + ((#:extra-directories extra-directories) + `(list ,@(append-map + (lambda (name) + (match (assoc name inputs) + ((_ pkg) + (match (package-transitive-propagated-inputs pkg) + (((propagated-names . _) ...) + (cons name propagated-names)))))) + extra-directories)))))))) (define* (haskell-build store name inputs #:key source @@ -110,6 +123,7 @@ (define* (haskell-build store name inputs (test-target "test") (parallel-build? #t) (configure-flags ''()) + (extra-directories ''()) (phases '(@ (guix build haskell-build-system) %standard-phases)) (outputs '("out" "static")) @@ -138,6 +152,7 @@ (define builder (derivation->output-path revision)) (revision revision)) #:configure-flags ,configure-flags + #:extra-directories ,extra-directories #:haddock-flags ,haddock-flags #:system ,system #:test-target ,test-target diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index d587962b8b..d7789cdef9 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -73,17 +73,14 @@ (define (run-setuphs command params) (error "no Setup.hs nor Setup.lhs found")))) (define* (configure #:key outputs inputs tests? (configure-flags '()) - #:allow-other-keys) + (extra-directories '()) #:allow-other-keys) "Configure a given Haskell package." (let* ((out (assoc-ref outputs "out")) (doc (assoc-ref outputs "doc")) (lib (assoc-ref outputs "lib")) (bin (assoc-ref outputs "bin")) (name-version (strip-store-file-name out)) - (input-dirs (match inputs - (((_ . dir) ...) - dir) - (_ '()))) + (extra-dirs (filter-map (cut assoc-ref inputs <>) extra-directories)) (ghc-path (getenv "GHC_PACKAGE_PATH")) (params `(,(string-append "--prefix=" out) ,(string-append "--libdir=" (or lib out) "/lib") @@ -94,9 +91,9 @@ (define* (configure #:key outputs inputs tests? (configure-flags '()) ,(string-append "--package-db=" %tmp-db-dir) "--global" ,@(map (cut string-append "--extra-include-dirs=" <>) - (search-path-as-list '("include") input-dirs)) + (search-path-as-list '("include") extra-dirs)) ,@(map (cut string-append "--extra-lib-dirs=" <>) - (search-path-as-list '("lib") input-dirs)) + (search-path-as-list '("lib") extra-dirs)) ,@(if tests? '("--enable-tests") '()) -- cgit v1.2.3 From aa1a75cc0ef2bf73f1a11d6123b48641e770016d Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 24 Jun 2020 23:12:06 +0200 Subject: build-system/haskell: Do not pass "--bindir" during configure. The "--bindir" option is not as useful as it seems as the configured location is embedded in the outputs. Instead of using "--bindir" it seems better to build a statically linked binary and move the binary to its own output to avoid references between the "out" and "bin" outputs. * guix/build/haskell-build-system.scm (configure): Do not pass "--bindir". --- guix/build/haskell-build-system.scm | 2 -- 1 file changed, 2 deletions(-) (limited to 'guix') diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index d7789cdef9..28253ce2f0 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -78,13 +78,11 @@ (define* (configure #:key outputs inputs tests? (configure-flags '()) (let* ((out (assoc-ref outputs "out")) (doc (assoc-ref outputs "doc")) (lib (assoc-ref outputs "lib")) - (bin (assoc-ref outputs "bin")) (name-version (strip-store-file-name out)) (extra-dirs (filter-map (cut assoc-ref inputs <>) extra-directories)) (ghc-path (getenv "GHC_PACKAGE_PATH")) (params `(,(string-append "--prefix=" out) ,(string-append "--libdir=" (or lib out) "/lib") - ,(string-append "--bindir=" (or bin out) "/bin") ,(string-append "--docdir=" (or doc out) "/share/doc/" name-version) "--libsubdir=$compiler/$pkg-$version" -- cgit v1.2.3 From 46886728a7b0ba94be66b817520e34d058bb2f57 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Thu, 13 Aug 2020 14:47:27 +0300 Subject: utils: Add version-major+minor+point. * guix/utils.scm (version-major+minor+point): New procedure. --- guix/utils.scm | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 436c5cd093..fc57c416a0 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2015 David Thompson ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2018, 2020 Marius Bakke +;;; Copyright © 2020 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -82,6 +83,7 @@ (define-module (guix utils) version>? version>=? version-prefix + version-major+minor+point version-major+minor version-major guile-version>? @@ -564,6 +566,15 @@ (define (version-prefix version-string num-parts) For example, (version-prefix \"2.1.47.4.23\" 3) returns \"2.1.47\"" (string-join (take (string-split version-string #\.) num-parts) ".")) +(define (version-major+minor+point version-string) + "Return \"major>..\", where major, minor and point are the +major, minor and point version numbers from the version-string. For example, +(version-major+minor+point \"6.4.5.2\") returns \"6.4.5\" or +(version-major+minor+point \"1.19.2-2581-324ca14c3003\") returns \"1.19.2\"." + (let* ((3-dot (version-prefix version-string 3)) + (index (string-index 3-dot #\-))) + (or (false-if-exception (substring 3-dot 0 index)) + 3-dot))) (define (version-major+minor version-string) "Return \".\", where major and minor are the major and -- cgit v1.2.3 From 68193624d1428836b18e93306f96e78706e082c3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 23 Aug 2020 22:11:31 +0200 Subject: lint: Avoid calls to 'package-field-location' with #f as the field. * guix/lint.scm (%make-warning): Call 'package-field-location' only when FIELD is true. --- guix/lint.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 71ce931964..4a6abe4275 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -139,7 +139,7 @@ (define* (%make-warning package message-text message-text message-data (or location - (package-field-location package field) + (and field (package-field-location package field)) (package-location package)))) (define-syntax make-warning -- cgit v1.2.3 From d10474c38d58bdc676e64336769dc2e00cdfa8ed Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 23 Aug 2020 22:48:19 +0200 Subject: lint: formatting: Gracefully handle relative file names. Fixes . Reported by Jack Hill . * guix/lint.scm (check-formatting): Always return a list (previously we would return #f when 'search-path' returns #f). Check whether LOCATION's file is a relative file name. Return a warning if not. * tests/guix-lint.sh: Add test. --- guix/lint.scm | 20 ++++++++++++++------ tests/guix-lint.sh | 13 +++++++++++-- 2 files changed, 25 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 4a6abe4275..ec43a4dcad 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1355,12 +1355,20 @@ (define (check-formatting package) "Check the formatting of the source code of PACKAGE." (let ((location (package-location package))) (if location - (and=> (search-path %load-path (location-file location)) - (lambda (file) - ;; Report issues starting from the line before the 'package' - ;; form, which usually contains the 'define' form. - (report-formatting-issues package file - (- (location-line location) 1)))) + ;; Report issues starting from the line before the 'package' + ;; form, which usually contains the 'define' form. + (let ((line (- (location-line location) 1))) + (match (search-path %load-path (location-file location)) + ((? string? file) + (report-formatting-issues package file line)) + (#f + ;; It could be that LOCATION lists a "true" relative file + ;; name--i.e., not relative to an element of %LOAD-PATH. + (let ((file (location-file location))) + (if (file-exists? file) + (report-formatting-issues package file line) + (list (make-warning package + (G_ "source file not found")))))))) '()))) diff --git a/tests/guix-lint.sh b/tests/guix-lint.sh index f0df1fda3a..ebe79efb84 100644 --- a/tests/guix-lint.sh +++ b/tests/guix-lint.sh @@ -22,8 +22,11 @@ guix lint --version -module_dir="t-guix-lint-$$" -mkdir "$module_dir" +# Choose a module directory not below any %LOAD-PATH component. This is +# necessary when testing '-L' with a relative file name. +module_dir="$(mktemp -d)" + +mkdir -p "$module_dir" trap "rm -rf $module_dir" EXIT @@ -87,3 +90,9 @@ then false; else true; fi # Make sure specifying multiple packages works. guix lint -L $module_dir -c inputs-should-be-native dummy dummy@42 dummy + +# Test '-L' with a relative file name. 'guix lint' will see "t-xyz/foo.scm" +# (instead of "foo.scm") and will thus fail to find it in %LOAD-PATH. Check +# that it does find it anyway. See . +(cd "$module_dir"/.. ; guix lint -c formatting -L "$(basename "$module_dir")" dummy@42) 2>&1 > "$module_dir/out" +test -z "$(cat "$module_dir/out")" -- cgit v1.2.3 From e9f8a7e21579fd2833dfca6830e21f886a79a9ca Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Thu, 6 Aug 2020 15:00:01 +0200 Subject: Use guile-zlib extension in build-side code. * Makefile.am (MODULES): Move guix/build/download-nar.scm to ... (MODULES_NOT_COMPILED): ... here. * guix/build/download-nar.scm: Use (zlib) instead of (guix zlib). * guix/cvs-download.scm (cvs-fetch): Do not stub (guix config) in imported modules list, instead add "guile-zlib" to the extension list. * guix/git-download.scm (git-fetch): Ditto. * guix/hg-download.scm (hg-fetch): Do not stub (guix config) in imported modules list, instead add "guile-zlib" to the extension list. --- guix/build/download-nar.scm | 2 +- guix/cvs-download.scm | 39 +++++++++++++++------------------------ guix/git-download.scm | 29 ++++++++++------------------- guix/hg-download.scm | 37 ++++++++++++++----------------------- 4 files changed, 40 insertions(+), 67 deletions(-) (limited to 'guix') diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm index 377e428341..867f3c10bb 100644 --- a/guix/build/download-nar.scm +++ b/guix/build/download-nar.scm @@ -20,7 +20,7 @@ (define-module (guix build download-nar) #:use-module (guix build download) #:use-module (guix build utils) #:use-module ((guix serialization) #:hide (dump-port*)) - #:use-module (guix zlib) + #:autoload (zlib) (call-with-gzip-input-port) #:use-module (guix progress) #:use-module (web uri) #:use-module (srfi srfi-11) diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm index cb42103aae..76b3eac739 100644 --- a/guix/cvs-download.scm +++ b/guix/cvs-download.scm @@ -60,35 +60,26 @@ (define* (cvs-fetch ref hash-algo hash "Return a fixed-output derivation that fetches REF, a object. The output is expected to have recursive hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." - (define zlib - (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) - - (define config.scm - (scheme-file "config.scm" - #~(begin - (define-module (guix config) - #:export (%libz)) - - (define %libz - #+(file-append zlib "/lib/libz"))))) + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) (define modules - (cons `((guix config) => ,config.scm) - (delete '(guix config) - (source-module-closure '((guix build cvs) - (guix build download-nar)))))) + (delete '(guix config) + (source-module-closure '((guix build cvs) + (guix build download-nar))))) (define build (with-imported-modules modules - #~(begin - (use-modules (guix build cvs) - (guix build download-nar)) + (with-extensions (list guile-zlib) + #~(begin + (use-modules (guix build cvs) + (guix build download-nar)) - (or (cvs-fetch '#$(cvs-reference-root-directory ref) - '#$(cvs-reference-module ref) - '#$(cvs-reference-revision ref) - #$output - #:cvs-command (string-append #+cvs "/bin/cvs")) - (download-nar #$output))))) + (or (cvs-fetch '#$(cvs-reference-root-directory ref) + '#$(cvs-reference-module ref) + '#$(cvs-reference-revision ref) + #$output + #:cvs-command (string-append #+cvs "/bin/cvs")) + (download-nar #$output)))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "cvs-checkout") build diff --git a/guix/git-download.scm b/guix/git-download.scm index 71ea1031c5..90634a8c4c 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -84,35 +84,26 @@ (define inputs ("tar" ,(module-ref (resolve-interface '(gnu packages base)) 'tar))))) - (define zlib - (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) - (define guile-json (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-3)) + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) + (define gnutls (module-ref (resolve-interface '(gnu packages tls)) 'gnutls)) - (define config.scm - (scheme-file "config.scm" - #~(begin - (define-module (guix config) - #:export (%libz)) - - (define %libz - #+(file-append zlib "/lib/libz"))))) - (define modules - (cons `((guix config) => ,config.scm) - (delete '(guix config) - (source-module-closure '((guix build git) - (guix build utils) - (guix build download-nar) - (guix swh)))))) + (delete '(guix config) + (source-module-closure '((guix build git) + (guix build utils) + (guix build download-nar) + (guix swh))))) (define build (with-imported-modules modules - (with-extensions (list guile-json gnutls) ;for (guix swh) + (with-extensions (list guile-json gnutls ;for (guix swh) + guile-zlib) #~(begin (use-modules (guix build git) (guix build utils) diff --git a/guix/hg-download.scm b/guix/hg-download.scm index 4cdc1a780a..694105ceba 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.scm @@ -60,35 +60,26 @@ (define* (hg-fetch ref hash-algo hash "Return a fixed-output derivation that fetches REF, a object. The output is expected to have recursive hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." - (define zlib - (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) - - (define config.scm - (scheme-file "config.scm" - #~(begin - (define-module (guix config) - #:export (%libz)) - - (define %libz - #+(file-append zlib "/lib/libz"))))) + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) (define modules - (cons `((guix config) => ,config.scm) - (delete '(guix config) - (source-module-closure '((guix build hg) - (guix build download-nar)))))) + (delete '(guix config) + (source-module-closure '((guix build hg) + (guix build download-nar))))) (define build (with-imported-modules modules - #~(begin - (use-modules (guix build hg) - (guix build download-nar)) + (with-extensions (list guile-zlib) + #~(begin + (use-modules (guix build hg) + (guix build download-nar)) - (or (hg-fetch '#$(hg-reference-url ref) - '#$(hg-reference-changeset ref) - #$output - #:hg-command (string-append #+hg "/bin/hg")) - (download-nar #$output))))) + (or (hg-fetch '#$(hg-reference-url ref) + '#$(hg-reference-changeset ref) + #$output + #:hg-command (string-append #+hg "/bin/hg")) + (download-nar #$output)))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "hg-checkout") build -- cgit v1.2.3 From 4c0c65acfade63ce0549115d19db4b639c1e9992 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Mon, 27 Jul 2020 16:36:39 +0200 Subject: Use "guile-zlib" and "guile-lzlib" instead of (guix config). * Makefile.am (MODULES): Remove guix/zlib.scm and guix/lzlib.scm, (SCM_TESTS): remove tests/zlib.scm, tests/lzlib.scm. * build-aux/build-self.scm (make-config.scm): Remove unused %libz variable. * configure.ac: Remove LIBZ and LIBLZ variables and check instead for Guile-zlib and Guile-lzlib. * doc/guix.texi ("Requirements"): Remove zlib requirement and add Guile-zlib and Guile-lzlib instead. * gnu/packages/package-management.scm (guix)[native-inputs]: Add "guile-zlib" and "guile-lzlib", [inputs]: remove "zlib" and "lzlib", [propagated-inputs]: ditto, [arguments]: add "guile-zlib" and "guile-lzlib" to Guile load path. * guix/config.scm.in (%libz, %liblz): Remove them. * guix/lzlib.scm: Remove it. * guix/man-db.scm: Use (zlib) instead of (guix zlib). * guix/profiles.scm (manual-database): Do not stub (guix config) in imported modules list, instead add "guile-zlib" to the extension list. * guix/scripts/publish.scm: Use (zlib) instead of (guix zlib) and (lzlib) instead of (guix lzlib), (string->compression-type, effective-compression): do not check for zlib and lzlib availability. * guix/scripts/substitute.scm (%compression-methods): Do not check for lzlib availability. * guix/self.scm (specification->package): Add "guile-zlib" and "guile-lzlib" and remove "zlib" and "lzlib", (compiled-guix): remove "zlib" and "lzlib" arguments and add guile-zlib and guile-lzlib to the dependencies, also do not pass "zlib" and "lzlib" to "make-config.scm" procedure, (make-config.scm): remove "zlib" and "lzlib" arguments as well as %libz and %liblz variables. * guix/utils.scm (lzip-port): Use (lzlib) instead of (guix lzlib) and do not check for lzlib availability. * guix/zlib.scm: Remove it. * m4/guix.m4 (GUIX_LIBZ_LIBDIR, GUIX_LIBLZ_FILE_NAME): Remove them. * tests/lzlib.scm: Use (zlib) instead of (guix zlib) and (lzlib) instead of (guix lzlib), and do not check for zlib and lzlib availability. * tests/publish.scm: Ditto. * tests/substitute.scm: Do not check for lzlib availability. * tests/utils.scm: Ditto. * tests/zlib.scm: Remove it. --- Makefile.am | 6 +- build-aux/build-self.scm | 8 +- configure.ac | 33 +- doc/guix.texi | 3 +- gnu/packages/package-management.scm | 13 +- guix/config.scm.in | 8 - guix/gnu-maintenance.scm | 2 +- guix/lzlib.scm | 709 ------------------------------------ guix/man-db.scm | 2 +- guix/profiles.scm | 23 +- guix/scripts/publish.scm | 15 +- guix/scripts/substitute.scm | 3 +- guix/self.scm | 32 +- guix/utils.scm | 9 +- guix/zlib.scm | 241 ------------ m4/guix.m4 | 26 -- tests/lzlib.scm | 120 ------ tests/publish.scm | 28 +- tests/substitute.scm | 4 +- tests/utils.scm | 3 +- tests/zlib.scm | 62 ---- 21 files changed, 60 insertions(+), 1290 deletions(-) delete mode 100644 guix/lzlib.scm delete mode 100644 guix/zlib.scm delete mode 100644 tests/lzlib.scm delete mode 100644 tests/zlib.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index a22414716b..4e50a33f82 100644 --- a/Makefile.am +++ b/Makefile.am @@ -109,8 +109,6 @@ MODULES = \ guix/cache.scm \ guix/cve.scm \ guix/workers.scm \ - guix/zlib.scm \ - guix/lzlib.scm \ guix/build-system.scm \ guix/build-system/android-ndk.scm \ guix/build-system/ant.scm \ @@ -431,7 +429,6 @@ SCM_TESTS = \ tests/import-utils.scm \ tests/inferior.scm \ tests/lint.scm \ - tests/lzlib.scm \ tests/modules.scm \ tests/monads.scm \ tests/nar.scm \ @@ -470,8 +467,7 @@ SCM_TESTS = \ tests/upstream.scm \ tests/utils.scm \ tests/uuid.scm \ - tests/workers.scm \ - tests/zlib.scm + tests/workers.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index e2495919d5..4b6e2bfae5 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -71,7 +71,7 @@ (define %config-variables (variables rest ...)))))) (variables %localstatedir %storedir %sysconfdir %system))) -(define* (make-config.scm #:key zlib gzip xz bzip2 +(define* (make-config.scm #:key gzip xz bzip2 (package-name "GNU Guix") (package-version "0") (bug-report-address "bug-guix@gnu.org") @@ -133,11 +133,7 @@ (define %gzip (define %bzip2 #+(and bzip2 (file-append bzip2 "/bin/bzip2"))) (define %xz - #+(and xz (file-append xz "/bin/xz"))) - - (define %libz - #+(and zlib - (file-append zlib "/lib/libz"))))))) + #+(and xz (file-append xz "/bin/xz"))))))) ;;; diff --git a/configure.ac b/configure.ac index 7675eef7c4..5d549cc3af 100644 --- a/configure.ac +++ b/configure.ac @@ -141,6 +141,18 @@ if test "x$guix_cv_have_recent_guile_gcrypt" != "xyes"; then AC_MSG_ERROR([A recent Guile-Gcrypt could not be found; please install it.]) fi +dnl Check for Guile-zlib. +GUILE_MODULE_AVAILABLE([have_guile_zlib], [(zlib)]) +if test "x$have_guile_zlib" != "xyes"; then + AC_MSG_ERROR([Guile-zlib is missing; please install it.]) +fi + +dnl Check for Guile-lzlib. +GUILE_MODULE_AVAILABLE([have_guile_lzlib], [(lzlib)]) +if test "x$have_guile_lzlib" != "xyes"; then + AC_MSG_ERROR([Guile-lzlib is missing; please install it.]) +fi + dnl Guile-newt is used by the graphical installer. GUILE_MODULE_AVAILABLE([have_guile_newt], [(newt)]) @@ -245,27 +257,6 @@ esac AC_SUBST([LIBGCRYPT_PREFIX]) AC_SUBST([LIBGCRYPT_LIBDIR]) -dnl Library name of zlib suitable for 'dynamic-link'. -GUIX_LIBZ_LIBDIR([libz_libdir]) -if test "x$libz_libdir" = "x"; then - LIBZ="libz" -else - LIBZ="$libz_libdir/libz" -fi -AC_MSG_CHECKING([for zlib's shared library name]) -AC_MSG_RESULT([$LIBZ]) -AC_SUBST([LIBZ]) - -dnl Library name of lzlib suitable for 'dynamic-link'. -GUIX_LIBLZ_FILE_NAME([LIBLZ]) -if test "x$LIBLZ" = "x"; then - LIBLZ="liblz" -else - # Strip the .so or .so.1 extension since that's what 'dynamic-link' expects. - LIBLZ="`echo $LIBLZ | sed -es'/\.so\(\.[[0-9.]]\+\)\?//g'`" -fi -AC_SUBST([LIBLZ]) - dnl Check for Guile-SSH, for the (guix ssh) module. GUIX_CHECK_GUILE_SSH AM_CONDITIONAL([HAVE_GUILE_SSH], diff --git a/doc/guix.texi b/doc/guix.texi index f562d0465e..4264ce5194 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -778,12 +778,13 @@ Guile,, gnutls-guile, GnuTLS-Guile}); @item @uref{https://notabug.org/guile-sqlite3/guile-sqlite3, Guile-SQLite3}, version 0.1.0 or later; +@item @uref{https://notabug.org/guile-zlib/guile-zlib, Guile-zlib}; +@item @uref{https://notabug.org/guile-lzlib/guile-lzlib, Guile-lzlib}; @item @c FIXME: Specify a version number once a release has been made. @uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, from August 2017 or later; @item @uref{https://savannah.nongnu.org/projects/guile-json/, Guile-JSON} 3.x; -@item @url{https://zlib.net, zlib}; @item @url{https://www.gnu.org/software/make/, GNU Make}. @end itemize diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index 4f419502b0..d7d279f795 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -279,6 +279,8 @@ (define code (gcrypt (assoc-ref inputs "guile-gcrypt")) (json (assoc-ref inputs "guile-json")) (sqlite (assoc-ref inputs "guile-sqlite3")) + (zlib (assoc-ref inputs "guile-zlib")) + (lzlib (assoc-ref inputs "guile-lzlib")) (git (assoc-ref inputs "guile-git")) (bs (assoc-ref inputs "guile-bytestructures")) @@ -286,7 +288,7 @@ (define code (gnutls (assoc-ref inputs "gnutls")) (locales (assoc-ref inputs "glibc-utf8-locales")) (deps (list gcrypt json sqlite gnutls - git bs ssh)) + git bs ssh zlib lzlib)) (effective (read-line (open-pipe* OPEN_READ @@ -326,6 +328,8 @@ (define code ("guile-gcrypt" ,guile-gcrypt) ("guile-json" ,guile-json-4) ("guile-sqlite3" ,guile-sqlite3) + ("guile-zlib" ,guile-zlib) + ("guile-lzlib" ,guile-lzlib) ("guile-ssh" ,guile-ssh) ("guile-git" ,guile-git) @@ -342,9 +346,6 @@ (define code (inputs `(("bzip2" ,bzip2) ("gzip" ,gzip) - ("zlib" ,zlib) ;for 'guix publish' - ("lzlib" ,lzlib) ;for 'guix publish' and 'guix substitute' - ("sqlite" ,sqlite) ("libgcrypt" ,libgcrypt) @@ -378,7 +379,9 @@ (define code ("guile-json" ,guile-json-4) ("guile-sqlite3" ,guile-sqlite3) ("guile-ssh" ,guile-ssh) - ("guile-git" ,guile-git))) + ("guile-git" ,guile-git) + ("guile-zlib" ,guile-zlib) + ("guile-lzlib" ,guile-lzlib))) (home-page "https://www.gnu.org/software/guix/") (synopsis "Functional package manager for installed software packages and versions") diff --git a/guix/config.scm.in b/guix/config.scm.in index 0ada0f3c38..b2901735d8 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -33,8 +33,6 @@ (define-module (guix config) %config-directory %system - %libz - %liblz %gzip %bzip2 %xz)) @@ -88,12 +86,6 @@ (define %config-directory (define %system "@guix_system@") -(define %libz - "@LIBZ@") - -(define %liblz - "@LIBLZ@") - (define %gzip "@GZIP@") diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index cd7109002b..08b2bcf758 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -36,7 +36,7 @@ (define-module (guix gnu-maintenance) #:use-module (guix records) #:use-module (guix upstream) #:use-module (guix packages) - #:use-module (guix zlib) + #:use-module (zlib) #:export (gnu-package-name gnu-package-mundane-name gnu-package-copyright-holder diff --git a/guix/lzlib.scm b/guix/lzlib.scm deleted file mode 100644 index 2fc326ba34..0000000000 --- a/guix/lzlib.scm +++ /dev/null @@ -1,709 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Pierre Neidhardt -;;; Copyright © 2019, 2020 Ludovic Courtès -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (guix lzlib) - #:use-module (rnrs bytevectors) - #:use-module (rnrs arithmetic bitwise) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 match) - #:use-module (system foreign) - #:use-module (guix config) - #:use-module (srfi srfi-11) - #:export (lzlib-available? - make-lzip-input-port - make-lzip-output-port - make-lzip-input-port/compressed - call-with-lzip-input-port - call-with-lzip-output-port - %default-member-length-limit - %default-compression-level - dictionary-size+match-length-limit)) - -;;; Commentary: -;;; -;;; Bindings to the lzlib / liblz API. Some convenience functions are also -;;; provided (see the export). -;;; -;;; While the bindings are complete, the convenience functions only support -;;; single member archives. To decompress single member archives, we loop -;;; until lz-decompress-read returns 0. This is simpler. To support multiple -;;; members properly, we need (among others) to call lz-decompress-finish and -;;; loop over lz-decompress-read until lz-decompress-finished? returns #t. -;;; Otherwise a multi-member archive starting with an empty member would only -;;; decompress the empty member and stop there, resulting in truncated output. - -;;; Code: - -(define %lzlib - ;; File name of lzlib's shared library. When updating via 'guix pull', - ;; '%liblz' might be undefined so protect against it. - (delay (dynamic-link (if (defined? '%liblz) - %liblz - "liblz")))) - -(define (lzlib-available?) - "Return true if lzlib is available, #f otherwise." - (false-if-exception (force %lzlib))) - -(define (lzlib-procedure ret name parameters) - "Return a procedure corresponding to C function NAME in liblz, or #f if -either lzlib or the function could not be found." - (match (false-if-exception (dynamic-func name (force %lzlib))) - ((? pointer? ptr) - (pointer->procedure ret ptr parameters)) - (#f - #f))) - -(define-wrapped-pointer-type - ;; Scheme counterpart of the 'LZ_Decoder' opaque type. - lz-decoder? - pointer->lz-decoder - lz-decoder->pointer - (lambda (obj port) - (format port "#" - (number->string (object-address obj) 16)))) - -(define-wrapped-pointer-type - ;; Scheme counterpart of the 'LZ_Encoder' opaque type. - lz-encoder? - pointer->lz-encoder - lz-encoder->pointer - (lambda (obj port) - (format port "#" - (number->string (object-address obj) 16)))) - -;; From lzlib.h -(define %error-number-ok 0) -(define %error-number-bad-argument 1) -(define %error-number-mem-error 2) -(define %error-number-sequence-error 3) -(define %error-number-header-error 4) -(define %error-number-unexpected-eof 5) -(define %error-number-data-error 6) -(define %error-number-library-error 7) - - -;; Compression bindings. - -(define lz-compress-open - (let ((proc (lzlib-procedure '* "LZ_compress_open" (list int int uint64))) - ;; member-size is an "unsigned long long", and the C standard guarantees - ;; a minimum range of 0..2^64-1. - (unlimited-size (- (expt 2 64) 1))) - (lambda* (dictionary-size match-length-limit #:optional (member-size unlimited-size)) - "Initialize the internal stream state for compression and returns a -pointer that can only be used as the encoder argument for the other -lz-compress functions, or a null pointer if the encoder could not be -allocated. - -See the manual: (lzlib) Compression functions." - (let ((encoder-ptr (proc dictionary-size match-length-limit member-size))) - (if (not (= (lz-compress-error encoder-ptr) -1)) - (pointer->lz-encoder encoder-ptr) - (throw 'lzlib-error 'lz-compress-open)))))) - -(define lz-compress-close - (let ((proc (lzlib-procedure int "LZ_compress_close" '(*)))) - (lambda (encoder) - "Close encoder. ENCODER can no longer be used as an argument to any -lz-compress function. " - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-close ret) - ret))))) - -(define lz-compress-finish - (let ((proc (lzlib-procedure int "LZ_compress_finish" '(*)))) - (lambda (encoder) - "Tell that all the data for this member have already been written (with -the `lz-compress-write' function). It is safe to call `lz-compress-finish' as -many times as needed. After all the produced compressed data have been read -with `lz-compress-read' and `lz-compress-member-finished?' returns #t, a new -member can be started with 'lz-compress-restart-member'." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-finish (lz-compress-error encoder)) - ret))))) - -(define lz-compress-restart-member - (let ((proc (lzlib-procedure int "LZ_compress_restart_member" (list '* uint64)))) - (lambda (encoder member-size) - "Start a new member in a multimember data stream. -Call this function only after `lz-compress-member-finished?' indicates that the -current member has been fully read (with the `lz-compress-read' function)." - (let ((ret (proc (lz-encoder->pointer encoder) member-size))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-restart-member - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-sync-flush - (let ((proc (lzlib-procedure int "LZ_compress_sync_flush" (list '*)))) - (lambda (encoder) - "Make available to `lz-compress-read' all the data already written with -the `LZ-compress-write' function. First call `lz-compress-sync-flush'. Then -call 'lz-compress-read' until it returns 0. - -Repeated use of `LZ-compress-sync-flush' may degrade compression ratio, -so use it only when needed. " - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-sync-flush - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-read - (let ((proc (lzlib-procedure int "LZ_compress_read" (list '* '* int)))) - (lambda* (encoder lzfile-bv #:optional (start 0) (count (bytevector-length lzfile-bv))) - "Read up to COUNT bytes from the encoder stream, storing the results in LZFILE-BV. -Return the number of uncompressed bytes written, a positive integer." - (let ((ret (proc (lz-encoder->pointer encoder) - (bytevector->pointer lzfile-bv start) - count))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-read (lz-compress-error encoder)) - ret))))) - -(define lz-compress-write - (let ((proc (lzlib-procedure int "LZ_compress_write" (list '* '* int)))) - (lambda* (encoder bv #:optional (start 0) (count (bytevector-length bv))) - "Write up to COUNT bytes from BV to the encoder stream. Return the -number of uncompressed bytes written, a strictly positive integer." - (let ((ret (proc (lz-encoder->pointer encoder) - (bytevector->pointer bv start) - count))) - (if (< ret 0) - (throw 'lzlib-error 'lz-compress-write (lz-compress-error encoder)) - ret))))) - -(define lz-compress-write-size - (let ((proc (lzlib-procedure int "LZ_compress_write_size" '(*)))) - (lambda (encoder) - "The maximum number of bytes that can be immediately written through the -`lz-compress-write' function. - -It is guaranteed that an immediate call to `lz-compress-write' will accept a -SIZE up to the returned number of bytes. " - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-write-size (lz-compress-error encoder)) - ret))))) - -(define lz-compress-error - (let ((proc (lzlib-procedure int "LZ_compress_errno" '(*)))) - (lambda (encoder) - "ENCODER can be a Scheme object or a pointer." - (let* ((error-number (proc (if (lz-encoder? encoder) - (lz-encoder->pointer encoder) - encoder)))) - error-number)))) - -(define lz-compress-finished? - (let ((proc (lzlib-procedure int "LZ_compress_finished" '(*)))) - (lambda (encoder) - "Return #t if all the data have been read and `lz-compress-close' can -be safely called. Otherwise return #f." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (match ret - (1 #t) - (0 #f) - (_ (throw 'lzlib-error 'lz-compress-finished? (lz-compress-error encoder)))))))) - -(define lz-compress-member-finished? - (let ((proc (lzlib-procedure int "LZ_compress_member_finished" '(*)))) - (lambda (encoder) - "Return #t if the current member, in a multimember data stream, has -been fully read and 'lz-compress-restart-member' can be safely called. -Otherwise return #f." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (match ret - (1 #t) - (0 #f) - (_ (throw 'lzlib-error 'lz-compress-member-finished? (lz-compress-error encoder)))))))) - -(define lz-compress-data-position - (let ((proc (lzlib-procedure uint64 "LZ_compress_data_position" '(*)))) - (lambda (encoder) - "Return the number of input bytes already compressed in the current -member." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-data-position - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-member-position - (let ((proc (lzlib-procedure uint64 "LZ_compress_member_position" '(*)))) - (lambda (encoder) - "Return the number of compressed bytes already produced, but perhaps -not yet read, in the current member." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-member-position - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-total-in-size - (let ((proc (lzlib-procedure uint64 "LZ_compress_total_in_size" '(*)))) - (lambda (encoder) - "Return the total number of input bytes already compressed." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-total-in-size - (lz-compress-error encoder)) - ret))))) - -(define lz-compress-total-out-size - (let ((proc (lzlib-procedure uint64 "LZ_compress_total_out_size" '(*)))) - (lambda (encoder) - "Return the total number of compressed bytes already produced, but -perhaps not yet read." - (let ((ret (proc (lz-encoder->pointer encoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-compress-total-out-size - (lz-compress-error encoder)) - ret))))) - - -;; Decompression bindings. - -(define lz-decompress-open - (let ((proc (lzlib-procedure '* "LZ_decompress_open" '()))) - (lambda () - "Initializes the internal stream state for decompression and returns a -pointer that can only be used as the decoder argument for the other -lz-decompress functions, or a null pointer if the decoder could not be -allocated. - -See the manual: (lzlib) Decompression functions." - (let ((decoder-ptr (proc))) - (if (not (= (lz-decompress-error decoder-ptr) -1)) - (pointer->lz-decoder decoder-ptr) - (throw 'lzlib-error 'lz-decompress-open)))))) - -(define lz-decompress-close - (let ((proc (lzlib-procedure int "LZ_decompress_close" '(*)))) - (lambda (decoder) - "Close decoder. DECODER can no longer be used as an argument to any -lz-decompress function. " - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-close ret) - ret))))) - -(define lz-decompress-finish - (let ((proc (lzlib-procedure int "LZ_decompress_finish" '(*)))) - (lambda (decoder) - "Tell that all the data for this stream have already been written (with -the `lz-decompress-write' function). It is safe to call -`lz-decompress-finish' as many times as needed." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-finish (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-reset - (let ((proc (lzlib-procedure int "LZ_decompress_reset" '(*)))) - (lambda (decoder) - "Reset the internal state of DECODER as it was just after opening it -with the `lz-decompress-open' function. Data stored in the internal buffers -is discarded. Position counters are set to 0." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-reset - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-sync-to-member - (let ((proc (lzlib-procedure int "LZ_decompress_sync_to_member" '(*)))) - (lambda (decoder) - "Reset the error state of DECODER and enters a search state that lasts -until a new member header (or the end of the stream) is found. After a -successful call to `lz-decompress-sync-to-member', data written with -`lz-decompress-write' will be consumed and 'lz-decompress-read' will return 0 -until a header is found. - -This function is useful to discard any data preceding the first member, or to -discard the rest of the current member, for example in case of a data -error. If the decoder is already at the beginning of a member, this function -does nothing." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-sync-to-member - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-read - (let ((proc (lzlib-procedure int "LZ_decompress_read" (list '* '* int)))) - (lambda* (decoder file-bv #:optional (start 0) (count (bytevector-length file-bv))) - "Read up to COUNT bytes from the decoder stream, storing the results in FILE-BV. -Return the number of uncompressed bytes written, a non-negative positive integer." - (let ((ret (proc (lz-decoder->pointer decoder) - (bytevector->pointer file-bv start) - count))) - (if (< ret 0) - (throw 'lzlib-error 'lz-decompress-read (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-write - (let ((proc (lzlib-procedure int "LZ_decompress_write" (list '* '* int)))) - (lambda* (decoder bv #:optional (start 0) (count (bytevector-length bv))) - "Write up to COUNT bytes from BV to the decoder stream. Return the -number of uncompressed bytes written, a non-negative integer." - (let ((ret (proc (lz-decoder->pointer decoder) - (bytevector->pointer bv start) - count))) - (if (< ret 0) - (throw 'lzlib-error 'lz-decompress-write (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-write-size - (let ((proc (lzlib-procedure int "LZ_decompress_write_size" '(*)))) - (lambda (decoder) - "Return the maximum number of bytes that can be immediately written -through the `lz-decompress-write' function. - -It is guaranteed that an immediate call to `lz-decompress-write' will accept a -SIZE up to the returned number of bytes. " - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-write-size (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-error - (let ((proc (lzlib-procedure int "LZ_decompress_errno" '(*)))) - (lambda (decoder) - "DECODER can be a Scheme object or a pointer." - (let* ((error-number (proc (if (lz-decoder? decoder) - (lz-decoder->pointer decoder) - decoder)))) - error-number)))) - -(define lz-decompress-finished? - (let ((proc (lzlib-procedure int "LZ_decompress_finished" '(*)))) - (lambda (decoder) - "Return #t if all the data have been read and `lz-decompress-close' can -be safely called. Otherwise return #f." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (match ret - (1 #t) - (0 #f) - (_ (throw 'lzlib-error 'lz-decompress-finished? (lz-decompress-error decoder)))))))) - -(define lz-decompress-member-finished? - (let ((proc (lzlib-procedure int "LZ_decompress_member_finished" '(*)))) - (lambda (decoder) - "Return #t if the current member, in a multimember data stream, has -been fully read and `lz-decompress-restart-member' can be safely called. -Otherwise return #f." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (match ret - (1 #t) - (0 #f) - (_ (throw 'lzlib-error 'lz-decompress-member-finished? (lz-decompress-error decoder)))))))) - -(define lz-decompress-member-version - (let ((proc (lzlib-procedure int "LZ_decompress_member_version" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the version of current member from member header." - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-data-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-dictionary-size - (let ((proc (lzlib-procedure int "LZ_decompress_dictionary_size" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the dictionary size of current member from member header." - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-member-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-data-crc - (let ((proc (lzlib-procedure unsigned-int "LZ_decompress_data_crc" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the 32 bit Cyclic Redundancy Check of the data decompressed -from the current member. The returned value is valid only when -`lz-decompress-member-finished' returns #t. " - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-member-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-data-position - (let ((proc (lzlib-procedure uint64 "LZ_decompress_data_position" '(*)))) - (lambda (decoder) - "Return the number of decompressed bytes already produced, but perhaps -not yet read, in the current member." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-data-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-member-position - (let ((proc (lzlib-procedure uint64 "LZ_decompress_member_position" '(*)))) - (lambda (decoder) - "Return the number of input bytes already decompressed in the current -member." - (let ((ret (proc (lz-decoder->pointer decoder)))) - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-member-position - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-total-in-size - (let ((proc (lzlib-procedure uint64 "LZ_decompress_total_in_size" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the total number of input bytes already compressed." - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-total-in-size - (lz-decompress-error decoder)) - ret))))) - -(define lz-decompress-total-out-size - (let ((proc (lzlib-procedure uint64 "LZ_decompress_total_out_size" '(*)))) - (lambda (decoder) - (let ((ret (proc (lz-decoder->pointer decoder)))) - "Return the total number of compressed bytes already produced, but -perhaps not yet read." - (if (= ret -1) - (throw 'lzlib-error 'lz-decompress-total-out-size - (lz-decompress-error decoder)) - ret))))) - - -;; High level functions. - -(define* (lzread! decoder port bv - #:optional (start 0) (count (bytevector-length bv))) - "Read up to COUNT bytes from PORT into BV at offset START. Return the -number of uncompressed bytes actually read; it is zero if COUNT is zero or if -the end-of-stream has been reached." - (define (feed-decoder! decoder) - ;; Feed DECODER with data read from PORT. - (match (get-bytevector-n port (lz-decompress-write-size decoder)) - ((? eof-object? eof) eof) - (bv (lz-decompress-write decoder bv)))) - - (let loop ((read 0) - (start start)) - (cond ((< read count) - (match (lz-decompress-read decoder bv start (- count read)) - (0 (cond ((lz-decompress-finished? decoder) - read) - ((eof-object? (feed-decoder! decoder)) - (lz-decompress-finish decoder) - (loop read start)) - (else ;read again - (loop read start)))) - (n (loop (+ read n) (+ start n))))) - (else - read)))) - -(define (lzwrite! encoder source source-offset source-count - target target-offset target-count) - "Write up to SOURCE-COUNT bytes from SOURCE to ENCODER, and read up to -TARGET-COUNT bytes into TARGET at TARGET-OFFSET. Return two values: the -number of bytes read from SOURCE, and the number of bytes written to TARGET, -possibly zero." - (define read - (if (> (lz-compress-write-size encoder) 0) - (match (lz-compress-write encoder source source-offset source-count) - (0 (lz-compress-finish encoder) 0) - (n n)) - 0)) - - (define written - (lz-compress-read encoder target target-offset target-count)) - - (values read written)) - -(define* (lzwrite encoder bv lz-port - #:optional (start 0) (count (bytevector-length bv))) - "Write up to COUNT bytes from BV at offset START into LZ-PORT. Return -the number of uncompressed bytes written, a non-negative integer." - (let ((written 0) - (read 0)) - (while (and (< 0 (lz-compress-write-size encoder)) - (< written count)) - (set! written (+ written - (lz-compress-write encoder bv (+ start written) (- count written))))) - (when (= written 0) - (lz-compress-finish encoder)) - (let ((lz-bv (make-bytevector written))) - (let loop ((rd 0)) - (set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv))) - (put-bytevector lz-port lz-bv 0 rd) - (set! read (+ read rd)) - (unless (= rd 0) - (loop rd)))) - ;; `written' is the total byte count of uncompressed data. - written)) - - -;;; -;;; Port interface. -;;; - -;; Alist of (levels (dictionary-size match-length-limit)). 0 is the fastest. -;; See bbexample.c in lzlib's source. -(define %compression-levels - `((0 65535 16) - (1 ,(bitwise-arithmetic-shift-left 1 20) 5) - (2 ,(bitwise-arithmetic-shift-left 3 19) 6) - (3 ,(bitwise-arithmetic-shift-left 1 21) 8) - (4 ,(bitwise-arithmetic-shift-left 3 20) 12) - (5 ,(bitwise-arithmetic-shift-left 1 22) 20) - (6 ,(bitwise-arithmetic-shift-left 1 23) 36) - (7 ,(bitwise-arithmetic-shift-left 1 24) 68) - (8 ,(bitwise-arithmetic-shift-left 3 23) 132) - (9 ,(bitwise-arithmetic-shift-left 1 25) 273))) - -(define %default-compression-level - 6) - -(define (dictionary-size+match-length-limit level) - "Return two values: the dictionary size for LEVEL, and its match-length -limit. LEVEL must be a compression level, an integer between 0 and 9." - (match (assv-ref %compression-levels level) - ((dictionary-size match-length-limit) - (values dictionary-size match-length-limit)))) - -(define* (make-lzip-input-port port) - "Return an input port that decompresses data read from PORT, a file port. -PORT is automatically closed when the resulting port is closed." - (define decoder (lz-decompress-open)) - - (define (read! bv start count) - (lzread! decoder port bv start count)) - - (make-custom-binary-input-port "lzip-input" read! #f #f - (lambda () - (lz-decompress-close decoder) - (close-port port)))) - -(define* (make-lzip-output-port port - #:key - (level %default-compression-level)) - "Return an output port that compresses data at the given LEVEL, using PORT, -a file port, as its sink. PORT is automatically closed when the resulting -port is closed." - (define encoder - (call-with-values (lambda () (dictionary-size+match-length-limit level)) - lz-compress-open)) - - (define (write! bv start count) - (lzwrite encoder bv port start count)) - - (make-custom-binary-output-port "lzip-output" write! #f #f - (lambda () - (lz-compress-finish encoder) - ;; "lz-read" the trailing metadata added by `lz-compress-finish'. - (let ((lz-bv (make-bytevector (* 64 1024)))) - (let loop ((rd 0)) - (set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv))) - (put-bytevector port lz-bv 0 rd) - (unless (= rd 0) - (loop rd)))) - (lz-compress-close encoder) - (close-port port)))) - -(define* (make-lzip-input-port/compressed port - #:key - (level %default-compression-level)) - "Return an input port that compresses data read from PORT, with the given LEVEL. -PORT is automatically closed when the resulting port is closed." - (define encoder - (call-with-values (lambda () (dictionary-size+match-length-limit level)) - lz-compress-open)) - - (define input-buffer (make-bytevector 8192)) - (define input-len 0) - (define input-offset 0) - - (define input-eof? #f) - - (define (read! bv start count) - (cond - (input-eof? - (match (lz-compress-read encoder bv start count) - (0 (if (lz-compress-finished? encoder) - 0 - (read! bv start count))) - (n n))) - ((= input-offset input-len) - (match (get-bytevector-n! port input-buffer 0 - (bytevector-length input-buffer)) - ((? eof-object?) - (set! input-eof? #t) - (lz-compress-finish encoder)) - (count - (set! input-offset 0) - (set! input-len count))) - (read! bv start count)) - (else - (let-values (((read written) - (lzwrite! encoder - input-buffer input-offset - (- input-len input-offset) - bv start count))) - (set! input-offset (+ input-offset read)) - - ;; Make sure we don't return zero except on EOF. - (if (= 0 written) - (read! bv start count) - written))))) - - (make-custom-binary-input-port "lzip-input/compressed" - read! #f #f - (lambda () - (close-port port)))) - -(define* (call-with-lzip-input-port port proc) - "Call PROC with a port that wraps PORT and decompresses data read from it. -PORT is closed upon completion." - (let ((lzip (make-lzip-input-port port))) - (dynamic-wind - (const #t) - (lambda () - (proc lzip)) - (lambda () - (close-port lzip))))) - -(define* (call-with-lzip-output-port port proc - #:key - (level %default-compression-level)) - "Call PROC with an output port that wraps PORT and compresses data. PORT is -close upon completion." - (let ((lzip (make-lzip-output-port port - #:level level))) - (dynamic-wind - (const #t) - (lambda () - (proc lzip)) - (lambda () - (close-port lzip))))) - -;;; lzlib.scm ends here diff --git a/guix/man-db.scm b/guix/man-db.scm index 4cef874f8b..a6528e4431 100644 --- a/guix/man-db.scm +++ b/guix/man-db.scm @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix man-db) - #:use-module (guix zlib) + #:use-module (zlib) #:use-module ((guix build utils) #:select (find-files)) #:use-module (gdbm) ;gdbm-ffi #:use-module (srfi srfi-9) diff --git a/guix/profiles.scm b/guix/profiles.scm index 0619e735fb..6b2344270e 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1412,27 +1412,18 @@ (define gdbm-ffi (module-ref (resolve-interface '(gnu packages guile)) 'guile-gdbm-ffi)) - (define zlib - (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) - - (define config.scm - (scheme-file "config.scm" - #~(begin - (define-module #$'(guix config) ;placate Geiser - #:export (%libz)) - - (define %libz - #+(file-append zlib "/lib/libz"))))) + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) (define modules - (cons `((guix config) => ,config.scm) - (delete '(guix config) - (source-module-closure `((guix build utils) - (guix man-db)))))) + (delete '(guix config) + (source-module-closure `((guix build utils) + (guix man-db))))) (define build (with-imported-modules modules - (with-extensions (list gdbm-ffi) ;for (guix man-db) + (with-extensions (list gdbm-ffi ;for (guix man-db) + guile-zlib) #~(begin (use-modules (guix man-db) (guix build utils) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index a00f08f9d9..61542f83a0 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -50,10 +50,9 @@ (define-module (guix scripts publish) #:use-module (guix workers) #:use-module (guix store) #:use-module ((guix serialization) #:select (write-file)) - #:use-module (guix zlib) - #:autoload (guix lzlib) (lzlib-available? - call-with-lzip-output-port - make-lzip-output-port) + #:use-module (zlib) + #:autoload (lzlib) (call-with-lzip-output-port + make-lzip-output-port) #:use-module (guix cache) #:use-module (guix ui) #:use-module (guix scripts) @@ -880,8 +879,8 @@ (define (string->compression-type string) "Return a symbol denoting the compression method expressed by STRING; return #f if STRING doesn't match any supported method." (match string - ("gzip" (and (zlib-available?) 'gzip)) - ("lzip" (and (lzlib-available?) 'lzip)) + ("gzip" 'gzip) + ("lzip" 'lzip) (_ #f))) (define (effective-compression requested-type compressions) @@ -1032,9 +1031,7 @@ (define (guix-publish . args) opts) (() ;; Default to fast & low compression. - (list (if (zlib-available?) - %default-gzip-compression - %no-compression))) + (list %default-gzip-compression)) (lst (reverse lst)))) (address (let ((addr (assoc-ref opts 'address))) (make-socket-address (sockaddr:fam addr) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index ba2b2d2d4e..f9d19fd735 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -41,7 +41,6 @@ (define-module (guix scripts substitute) #:use-module (guix progress) #:use-module ((guix build syscalls) #:select (set-thread-name)) - #:autoload (guix lzlib) (lzlib-available?) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) @@ -912,7 +911,7 @@ (define %compression-methods ;; Known compression methods and a thunk to determine whether they're ;; supported. See 'decompressed-port' in (guix utils). `(("gzip" . ,(const #t)) - ("lzip" . ,lzlib-available?) + ("lzip" . ,(const #t)) ("xz" . ,(const #t)) ("bzip2" . ,(const #t)) ("none" . ,(const #t)))) diff --git a/guix/self.scm b/guix/self.scm index f70b1ecdd8..6a1640acdf 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -53,10 +53,10 @@ (define specification->package ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-git" (ref '(gnu packages guile) 'guile-git)) ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) + ("guile-zlib" (ref '(gnu packages guile) 'guile-zlib)) + ("guile-lzlib" (ref '(gnu packages guile) 'guile-lzlib)) ("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt)) ("gnutls" (ref '(gnu packages tls) 'guile3.0-gnutls)) - ("zlib" (ref '(gnu packages compression) 'zlib)) - ("lzlib" (ref '(gnu packages compression) 'lzlib)) ("gzip" (ref '(gnu packages compression) 'gzip)) ("bzip2" (ref '(gnu packages compression) 'bzip2)) ("xz" (ref '(gnu packages compression) 'xz)) @@ -727,8 +727,6 @@ (define* (compiled-guix source #:key (version %guix-version) (name (string-append "guix-" version)) (guile-version (effective-version)) (guile-for-build (default-guile)) - (zlib (specification->package "zlib")) - (lzlib (specification->package "lzlib")) (gzip (specification->package "gzip")) (bzip2 (specification->package "bzip2")) (xz (specification->package "xz")) @@ -746,6 +744,12 @@ (define guile-git (define guile-sqlite3 (specification->package "guile-sqlite3")) + (define guile-zlib + (specification->package "guile-zlib")) + + (define guile-lzlib + (specification->package "guile-lzlib")) + (define guile-gcrypt (specification->package "guile-gcrypt")) @@ -757,7 +761,7 @@ (define dependencies (cons (list "x" package) (package-transitive-propagated-inputs package))) (list guile-gcrypt gnutls guile-git guile-json - guile-ssh guile-sqlite3)) + guile-ssh guile-sqlite3 guile-zlib guile-lzlib)) (((labels packages _ ...) ...) packages))) @@ -884,9 +888,7 @@ (define *config* '() #:extra-modules `(((guix config) - => ,(make-config.scm #:zlib zlib - #:lzlib lzlib - #:gzip gzip + => ,(make-config.scm #:gzip gzip #:bzip2 bzip2 #:xz xz #:package-name @@ -983,7 +985,7 @@ (define %config-variables (variables rest ...)))))) (variables %localstatedir %storedir %sysconfdir))) -(define* (make-config.scm #:key zlib lzlib gzip xz bzip2 +(define* (make-config.scm #:key gzip xz bzip2 (package-name "GNU Guix") (package-version "0") (bug-report-address "bug-guix@gnu.org") @@ -1004,8 +1006,6 @@ (define defmod 'define-module) %state-directory %store-database-directory %config-directory - %libz - %liblz %gzip %bzip2 %xz)) @@ -1048,15 +1048,7 @@ (define %gzip (define %bzip2 #+(and bzip2 (file-append bzip2 "/bin/bzip2"))) (define %xz - #+(and xz (file-append xz "/bin/xz"))) - - (define %libz - #+(and zlib - (file-append zlib "/lib/libz"))) - - (define %liblz - #+(and lzlib - (file-append lzlib "/lib/liblz")))) + #+(and xz (file-append xz "/bin/xz")))) ;; Guile 2.0 *requires* the 'define-module' to be at the ;; top-level or the 'toplevel-ref' in the resulting .go file are diff --git a/guix/utils.scm b/guix/utils.scm index fc57c416a0..b816c355dc 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -208,13 +208,8 @@ (define (filtered-port command input) (define (lzip-port proc port . args) "Return the lzip port produced by calling PROC (a symbol) on PORT and ARGS. Raise an error if lzlib support is missing." - (let* ((lzlib (false-if-exception (resolve-interface '(guix lzlib)))) - (supported? (and lzlib - ((module-ref lzlib 'lzlib-available?))))) - (if supported? - (let ((make-port (module-ref lzlib proc))) - (values (make-port port) '())) - (error "lzip compression not supported" lzlib)))) + (let ((make-port (module-ref (resolve-interface '(lzlib)) proc))) + (values (make-port port) '()))) (define (decompressed-port compression input) "Return an input port where INPUT is decompressed according to COMPRESSION, diff --git a/guix/zlib.scm b/guix/zlib.scm deleted file mode 100644 index 3bd0ad86c9..0000000000 --- a/guix/zlib.scm +++ /dev/null @@ -1,241 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (guix zlib) - #:use-module (rnrs bytevectors) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 match) - #:use-module (system foreign) - #:use-module (guix config) - #:export (zlib-available? - make-gzip-input-port - make-gzip-output-port - call-with-gzip-input-port - call-with-gzip-output-port - %default-buffer-size - %default-compression-level)) - -;;; Commentary: -;;; -;;; Bindings to the gzip-related part of zlib's API. The main limitation of -;;; this API is that it requires a file descriptor as the source or sink. -;;; -;;; Code: - -(define %zlib - ;; File name of zlib's shared library. When updating via 'guix pull', - ;; '%libz' might be undefined so protect against it. - (delay (dynamic-link (if (defined? '%libz) - %libz - "libz")))) - -(define (zlib-available?) - "Return true if zlib is available, #f otherwise." - (false-if-exception (force %zlib))) - -(define (zlib-procedure ret name parameters) - "Return a procedure corresponding to C function NAME in libz, or #f if -either zlib or the function could not be found." - (match (false-if-exception (dynamic-func name (force %zlib))) - ((? pointer? ptr) - (pointer->procedure ret ptr parameters)) - (#f - #f))) - -(define-wrapped-pointer-type - ;; Scheme counterpart of the 'gzFile' opaque type. - gzip-file? - pointer->gzip-file - gzip-file->pointer - (lambda (obj port) - (format port "#" - (number->string (object-address obj) 16)))) - -(define gzerror - (let ((proc (zlib-procedure '* "gzerror" '(* *)))) - (lambda (gzfile) - (let* ((errnum* (make-bytevector (sizeof int))) - (ptr (proc (gzip-file->pointer gzfile) - (bytevector->pointer errnum*)))) - (values (bytevector-sint-ref errnum* 0 - (native-endianness) (sizeof int)) - (pointer->string ptr)))))) - -(define gzdopen - (let ((proc (zlib-procedure '* "gzdopen" (list int '*)))) - (lambda (fd mode) - "Open file descriptor FD as a gzip stream with the given MODE. MODE must -be a string denoting the how FD is to be opened, such as \"r\" for reading or -\"w9\" for writing data compressed at level 9 to FD. Calling 'gzclose' also -closes FD." - (let ((result (proc fd (string->pointer mode)))) - (if (null-pointer? result) - (throw 'zlib-error 'gzdopen) - (pointer->gzip-file result)))))) - -(define gzread! - (let ((proc (zlib-procedure int "gzread" (list '* '* unsigned-int)))) - (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv))) - "Read up to COUNT bytes from GZFILE into BV at offset START. Return the -number of uncompressed bytes actually read; it is zero if COUNT is zero or if -the end-of-stream has been reached." - (let ((ret (proc (gzip-file->pointer gzfile) - (bytevector->pointer bv start) - count))) - (if (< ret 0) - (throw 'zlib-error 'gzread! ret) - ret))))) - -(define gzwrite - (let ((proc (zlib-procedure int "gzwrite" (list '* '* unsigned-int)))) - (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv))) - "Write up to COUNT bytes from BV at offset START into GZFILE. Return -the number of uncompressed bytes written, a strictly positive integer." - (let ((ret (proc (gzip-file->pointer gzfile) - (bytevector->pointer bv start) - count))) - (if (<= ret 0) - (throw 'zlib-error 'gzwrite ret) - ret))))) - -(define gzbuffer! - (let ((proc (zlib-procedure int "gzbuffer" (list '* unsigned-int)))) - (lambda (gzfile size) - "Change the internal buffer size of GZFILE to SIZE bytes." - (let ((ret (proc (gzip-file->pointer gzfile) size))) - (unless (zero? ret) - (throw 'zlib-error 'gzbuffer! ret)))))) - -(define gzeof? - (let ((proc (zlib-procedure int "gzeof" '(*)))) - (lambda (gzfile) - "Return true if the end-of-file has been reached on GZFILE." - (not (zero? (proc (gzip-file->pointer gzfile))))))) - -(define gzclose - (let ((proc (zlib-procedure int "gzclose" '(*)))) - (lambda (gzfile) - "Close GZFILE." - (let ((ret (proc (gzip-file->pointer gzfile)))) - (unless (zero? ret) - (throw 'zlib-error 'gzclose ret (gzerror gzfile))))))) - - - -;;; -;;; Port interface. -;;; - -(define %default-buffer-size - ;; Default buffer size, as documented in . - 8192) - -(define %default-compression-level - ;; Z_DEFAULT_COMPRESSION. - -1) - -(define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size)) - "Return an input port that decompresses data read from PORT, a file port. -PORT is automatically closed when the resulting port is closed. BUFFER-SIZE -is the size in bytes of the internal buffer, 8 KiB by default; using a larger -buffer increases decompression speed. An error is thrown if PORT contains -buffered input, which would be lost (and is lost anyway)." - (define gzfile - (match (drain-input port) - ("" ;PORT's buffer is empty - ;; 'gzclose' will eventually close the file descriptor beneath PORT. - ;; 'close-port' on PORT would get EBADF if 'gzclose' already closed it, - ;; so that's no good; revealed ports are no good either because they - ;; leak (see ); calling 'close-port' after - ;; 'gzclose' doesn't work either because it leads to a race condition - ;; (see ). So we dup and close PORT right - ;; away. - (gzdopen (dup (fileno port)) "r")) - (_ - ;; This is unrecoverable but it's better than having the buffered input - ;; be lost, leading to unclear end-of-file or corrupt-data errors down - ;; the path. - (throw 'zlib-error 'make-gzip-input-port - "port contains buffered input" port)))) - - (define (read! bv start count) - (gzread! gzfile bv start count)) - - (unless (= buffer-size %default-buffer-size) - (gzbuffer! gzfile buffer-size)) - - (close-port port) ;we no longer need it - (make-custom-binary-input-port "gzip-input" read! #f #f - (lambda () - (gzclose gzfile)))) - -(define* (make-gzip-output-port port - #:key - (level %default-compression-level) - (buffer-size %default-buffer-size)) - "Return an output port that compresses data at the given LEVEL, using PORT, -a file port, as its sink. PORT is automatically closed when the resulting -port is closed." - (define gzfile - (begin - (force-output port) ;empty PORT's buffer - (gzdopen (dup (fileno port)) - (string-append "w" (number->string level))))) - - (define (write! bv start count) - (gzwrite gzfile bv start count)) - - (unless (= buffer-size %default-buffer-size) - (gzbuffer! gzfile buffer-size)) - - (close-port port) - (make-custom-binary-output-port "gzip-output" write! #f #f - (lambda () - (gzclose gzfile)))) - -(define* (call-with-gzip-input-port port proc - #:key (buffer-size %default-buffer-size)) - "Call PROC with a port that wraps PORT and decompresses data read from it. -PORT is closed upon completion. The gzip internal buffer size is set to -BUFFER-SIZE bytes." - (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size))) - (dynamic-wind - (const #t) - (lambda () - (proc gzip)) - (lambda () - (close-port gzip))))) - -(define* (call-with-gzip-output-port port proc - #:key - (level %default-compression-level) - (buffer-size %default-buffer-size)) - "Call PROC with an output port that wraps PORT and compresses data. PORT is -close upon completion. The gzip internal buffer size is set to BUFFER-SIZE -bytes." - (let ((gzip (make-gzip-output-port port - #:level level - #:buffer-size buffer-size))) - (dynamic-wind - (const #t) - (lambda () - (proc gzip)) - (lambda () - (close-port gzip))))) - -;;; zlib.scm ends here diff --git a/m4/guix.m4 b/m4/guix.m4 index cce03045db..b7bf74ccc8 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -342,32 +342,6 @@ AC_DEFUN([GUIX_LIBGCRYPT_LIBDIR], [ $1="$guix_cv_libgcrypt_libdir" ]) -dnl GUIX_LIBZ_LIBDIR VAR -dnl -dnl Attempt to determine libz's LIBDIR; store the result in VAR. -AC_DEFUN([GUIX_LIBZ_LIBDIR], [ - AC_REQUIRE([PKG_PROG_PKG_CONFIG]) - AC_CACHE_CHECK([zlib's library directory], - [guix_cv_libz_libdir], - [guix_cv_libz_libdir="`$PKG_CONFIG zlib --variable=libdir 2> /dev/null`"]) - $1="$guix_cv_libz_libdir" -]) - -dnl GUIX_LIBLZ_FILE_NAME VAR -dnl -dnl Attempt to determine liblz's absolute file name; store the result in VAR. -AC_DEFUN([GUIX_LIBLZ_FILE_NAME], [ - AC_REQUIRE([PKG_PROG_PKG_CONFIG]) - AC_CACHE_CHECK([lzlib's file name], - [guix_cv_liblz_libdir], - [old_LIBS="$LIBS" - LIBS="-llz" - AC_LINK_IFELSE([AC_LANG_SOURCE([int main () { return LZ_decompress_open(); }])], - [guix_cv_liblz_libdir="`ldd conftest$EXEEXT | grep liblz | sed '-es/.*=> \(.*\) .*$/\1/g'`"]) - LIBS="$old_LIBS"]) - $1="$guix_cv_liblz_libdir" -]) - dnl GUIX_CURRENT_LOCALSTATEDIR dnl dnl Determine the localstatedir of an existing Guix installation and set diff --git a/tests/lzlib.scm b/tests/lzlib.scm deleted file mode 100644 index 63d1e15641..0000000000 --- a/tests/lzlib.scm +++ /dev/null @@ -1,120 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Pierre Neidhardt -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (test-lzlib) - #:use-module (guix lzlib) - #:use-module (guix tests) - #:use-module (srfi srfi-64) - #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports) - #:use-module (ice-9 match)) - -;; Test the (guix lzlib) module. - -(define-syntax-rule (test-assert* description exp) - (begin - (unless (lzlib-available?) - (test-skip 1)) - (test-assert description exp))) - -(test-begin "lzlib") - -(define (compress-and-decompress data) - "DATA must be a bytevector." - (pk "Uncompressed bytes:" (bytevector-length data)) - (match (pipe) - ((parent . child) - (match (primitive-fork) - (0 ;compress - (dynamic-wind - (const #t) - (lambda () - (close-port parent) - (call-with-lzip-output-port child - (lambda (port) - (put-bytevector port data)))) - (lambda () - (primitive-exit 0)))) - (pid ;decompress - (begin - (close-port child) - (let ((received (call-with-lzip-input-port parent - (lambda (port) - (get-bytevector-all port))))) - (match (waitpid pid) - ((_ . status) - (pk "Status" status) - (pk "Length data" (bytevector-length data) "received" (bytevector-length received)) - ;; The following loop is a debug helper. - (let loop ((i 0)) - (if (and (< i (bytevector-length received)) - (= (bytevector-u8-ref received i) - (bytevector-u8-ref data i))) - (loop (+ 1 i)) - (pk "First diff at index" i))) - (and (zero? status) - (port-closed? parent) - (bytevector=? received data))))))))))) - -(test-assert* "null bytevector" - (compress-and-decompress (make-bytevector (+ (random 100000) - (* 20 1024))))) - -(test-assert* "random bytevector" - (compress-and-decompress (random-bytevector (+ (random 100000) - (* 20 1024))))) -(test-assert* "small bytevector" - (compress-and-decompress (random-bytevector 127))) - -(test-assert* "1 bytevector" - (compress-and-decompress (random-bytevector 1))) - -(test-assert* "Bytevector of size relative to Lzip internal buffers (2 * dictionary)" - (compress-and-decompress - (random-bytevector - (* 2 (dictionary-size+match-length-limit %default-compression-level))))) - -(test-assert* "Bytevector of size relative to Lzip internal buffers (64KiB)" - (compress-and-decompress (random-bytevector (* 64 1024)))) - -(test-assert* "Bytevector of size relative to Lzip internal buffers (64KiB-1)" - (compress-and-decompress (random-bytevector (1- (* 64 1024))))) - -(test-assert* "Bytevector of size relative to Lzip internal buffers (64KiB+1)" - (compress-and-decompress (random-bytevector (1+ (* 64 1024))))) - -(test-assert* "Bytevector of size relative to Lzip internal buffers (1MiB)" - (compress-and-decompress (random-bytevector (* 1024 1024)))) - -(test-assert* "Bytevector of size relative to Lzip internal buffers (1MiB-1)" - (compress-and-decompress (random-bytevector (1- (* 1024 1024))))) - -(test-assert* "Bytevector of size relative to Lzip internal buffers (1MiB+1)" - (compress-and-decompress (random-bytevector (1+ (* 1024 1024))))) - -(test-assert* "make-lzip-input-port/compressed" - (let* ((len (pk 'len (+ 10 (random 4000 %seed)))) - (data (random-bytevector len)) - (compressed (make-lzip-input-port/compressed - (open-bytevector-input-port data))) - (result (call-with-lzip-input-port compressed - get-bytevector-all))) - (pk (bytevector-length result) (bytevector-length data)) - (bytevector=? result data))) - -(test-end) diff --git a/tests/publish.scm b/tests/publish.scm index e43310ef00..1c3b2785fb 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -35,8 +35,8 @@ (define-module (test-publish) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (gcrypt pk-crypto) #:use-module ((guix pki) #:select (%public-key-file %private-key-file)) - #:use-module (guix zlib) - #:use-module (guix lzlib) + #:use-module (zlib) + #:use-module (lzlib) #:use-module (web uri) #:use-module (web client) #:use-module (web response) @@ -204,8 +204,6 @@ (define %gzip-magic-bytes (call-with-input-string nar (cut restore-file <> temp))) (call-with-input-file temp read-string)))) -(unless (zlib-available?) - (test-skip 1)) (test-equal "/nar/gzip/*" "bar" (call-with-temporary-output-file @@ -217,8 +215,6 @@ (define %gzip-magic-bytes (cut restore-file <> temp))) (call-with-input-file temp read-string)))) -(unless (zlib-available?) - (test-skip 1)) (test-equal "/nar/gzip/* is really gzip" %gzip-magic-bytes ;; Since 'gzdopen' (aka. 'call-with-gzip-input-port') transparently reads @@ -229,8 +225,6 @@ (define %gzip-magic-bytes (string-append "/nar/gzip/" (basename %item)))))) (get-bytevector-n nar (bytevector-length %gzip-magic-bytes)))) -(unless (lzlib-available?) - (test-skip 1)) (test-equal "/nar/lzip/*" "bar" (call-with-temporary-output-file @@ -242,8 +236,6 @@ (define %gzip-magic-bytes (cut restore-file <> temp))) (call-with-input-file temp read-string)))) -(unless (zlib-available?) - (test-skip 1)) (test-equal "/*.narinfo with compression" `(("StorePath" . ,%item) ("URL" . ,(string-append "nar/gzip/" (basename %item))) @@ -264,8 +256,6 @@ (define %gzip-magic-bytes (_ #f))) (recutils->alist body))))) -(unless (lzlib-available?) - (test-skip 1)) (test-equal "/*.narinfo with lzip compression" `(("StorePath" . ,%item) ("URL" . ,(string-append "nar/lzip/" (basename %item))) @@ -286,8 +276,6 @@ (define %gzip-magic-bytes (_ #f))) (recutils->alist body))))) -(unless (zlib-available?) - (test-skip 1)) (test-equal "/*.narinfo for a compressed file" '("none" "nar") ;compression-less nar ;; Assume 'guix publish -C' is already running on port 6799. @@ -300,8 +288,6 @@ (define %gzip-magic-bytes (list (assoc-ref info "Compression") (dirname (assoc-ref info "URL"))))) -(unless (and (zlib-available?) (lzlib-available?)) - (test-skip 1)) (test-equal "/*.narinfo with lzip + gzip" `((("StorePath" . ,%item) ("URL" . ,(string-append "nar/gzip/" (basename %item))) @@ -411,8 +397,6 @@ (define %gzip-magic-bytes (call-with-input-string "" port-sha256)))))) (response-code (http-get uri)))) -(unless (zlib-available?) - (test-skip 1)) (test-equal "with cache" (list #t `(("StorePath" . ,%item) @@ -469,8 +453,6 @@ (define %gzip-magic-bytes (stat:size (stat nar))) (response-code uncompressed))))))))) -(unless (and (zlib-available?) (lzlib-available?)) - (test-skip 1)) (test-equal "with cache, lzip + gzip" '(200 200 404) (call-with-temporary-directory @@ -515,8 +497,6 @@ (define %gzip-magic-bytes (response-code (http-get uncompressed)))))))))) -(unless (zlib-available?) - (test-skip 1)) (let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz" (random-text)))) (test-equal "with cache, uncompressed" @@ -596,9 +576,7 @@ (define %gzip-magic-bytes (item (add-text-to-store %store "random" (random-text))) (part (store-path-hash-part item)) (url (string-append base part ".narinfo")) - (cached (string-append cache - (if (zlib-available?) - "/gzip/" "/none/") + (cached (string-append cache "/gzip/" (basename item) ".narinfo")) (response (http-get url))) diff --git a/tests/substitute.scm b/tests/substitute.scm index a4246aff82..6560612c40 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -29,7 +29,6 @@ (define-module (test-substitute) #:use-module ((guix store) #:select (%store-prefix)) #:use-module ((guix ui) #:select (guix-warning-port)) #:use-module ((guix utils) #:select (call-with-compressed-output-port)) - #:use-module ((guix lzlib) #:select (lzlib-available?)) #:use-module ((guix build utils) #:select (mkdir-p delete-file-recursively dump-port)) #:use-module (guix tests http) @@ -508,8 +507,7 @@ (define (compress input output compression) (let ((nar (string-append %main-substitute-directory "/example.nar"))) (compress nar (string-append nar ".gz") 'gzip) - (when (lzlib-available?) - (compress nar (string-append nar ".lz") 'lzip))) + (compress nar (string-append nar ".lz") 'lzip)) (parameterize ((substitute-urls (list (string-append "file://" diff --git a/tests/utils.scm b/tests/utils.scm index f78ec356bd..009e2121ab 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -23,7 +23,6 @@ (define-module (test-utils) #:use-module (guix utils) #:use-module ((guix store) #:select (%store-prefix store-path-package-name)) #:use-module ((guix search-paths) #:select (string-tokenize*)) - #:use-module ((guix lzlib) #:select (lzlib-available?)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-64) @@ -215,7 +214,7 @@ (define (test-compression/decompression method run?) (for-each test-compression/decompression '(gzip xz lzip) - (list (const #t) (const #t) lzlib-available?)) + (list (const #t) (const #t) (const #t))) ;; This is actually in (guix store). (test-equal "store-path-package-name" diff --git a/tests/zlib.scm b/tests/zlib.scm deleted file mode 100644 index 7c595a422c..0000000000 --- a/tests/zlib.scm +++ /dev/null @@ -1,62 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2019 Ludovic Courtès -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (test-zlib) - #:use-module (guix zlib) - #:use-module (guix tests) - #:use-module (srfi srfi-64) - #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports) - #:use-module (ice-9 match)) - -;; Test the (guix zlib) module. - -(test-begin "zlib") - -(unless (zlib-available?) - (test-skip 1)) -(test-assert "compression/decompression pipe" - (let ((data (random-bytevector (+ (random 10000) - (* 20 1024))))) - (match (pipe) - ((parent . child) - (match (primitive-fork) - (0 ;compress - (dynamic-wind - (const #t) - (lambda () - (close-port parent) - (call-with-gzip-output-port child - (lambda (port) - (put-bytevector port data)))) - (lambda () - (primitive-exit 0)))) - (pid ;decompress - (begin - (close-port child) - (let ((received (call-with-gzip-input-port parent - (lambda (port) - (get-bytevector-all port)) - #:buffer-size (* 64 1024)))) - (match (waitpid pid) - ((_ . status) - (and (zero? status) - (port-closed? parent) - (bytevector=? received data)))))))))))) - -(test-end) -- cgit v1.2.3 From 7ba7d50f92416821ec4fc124a49d74149b6d4d33 Mon Sep 17 00:00:00 2001 From: Jakub Kądziołka Date: Wed, 19 Aug 2020 23:36:23 +0200 Subject: guix upgrade: Allow using --do-not-upgrade. * guix/scripts/upgrade.scm (%options): Add "do-not-upgrade" to list of options inherited from guix package. --- guix/scripts/upgrade.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm index 7f14a2fdbe..d2784669be 100644 --- a/guix/scripts/upgrade.scm +++ b/guix/scripts/upgrade.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Ludovic Courtès +;;; Copyright © 2020 Jakub Kądziołka ;;; ;;; This file is part of GNU Guix. ;;; @@ -60,7 +61,7 @@ (define %options ;; Preserve some of the 'guix package' options. (append (filter (lambda (option) (any (cut member <> (option-names option)) - '("profile" "dry-run" "verbosity"))) + '("profile" "dry-run" "verbosity" "do-not-upgrade"))) %package-options) %transformation-options -- cgit v1.2.3 From 54a87b2a0cce10be256571a975e116cb60fb0f76 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Mon, 24 Aug 2020 16:23:16 -0400 Subject: offload: Update help string. * guix/scripts/offload.scm (guix-offload): Update help string. --- guix/scripts/offload.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 77ff3d2694..20ae7a9469 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -779,7 +779,8 @@ (define not-coma (("--version") (show-version-and-exit "guix offload")) (("--help") - (format #t (G_ "Usage: guix offload SYSTEM PRINT-BUILD-TRACE + (format #t (G_ "Usage: guix offload SYSTEM MAX-SILENT-TIME \ +PRINT-BUILD-TRACE? BUILD-TIMEOUT Process build offload requests written on the standard input, possibly offloading builds to the machines listed in '~a'.~%") %machine-file) -- cgit v1.2.3 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 'guix') 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 @@ (define-module (gnu build linux-modules) #: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 @@ (define (key=value->pair str) (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 @@ (define %not-comma (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 @@ (define (module-aliases 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 @@ (define (normalize-module-name module) 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 @@ (define names ;; 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 @@ (define* (load-linux-module* file (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 @@ (define aliases ;;; 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 @@ (define mapping (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 @@ (define mapping (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 @@ (define %not-dash (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 @@ (define aliases (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 @@ (define installer-builder ;; 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 @@ (define-module (gnu machine ssh) #: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 @@ (define remote-exp '((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 @@ (define-module (gnu services) #: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 @@ (define actions (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 @@ (define-module (gnu services base) #: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 @@ (define (default-serial-port) 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 @@ (define agetty-shepherd-service (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 @@ (define udev-shepherd-service (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 @@ (define gcrypt-sqlite3&co (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 @@ (define init (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 @@ (define builder (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 @@ (define-module (gnu system shadow) #: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 @@ (define accounts (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 @@ (define (linux-module-database manifest) 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 v1.2.3 From 4b5a6fbc9b754c0ca70d033dd99f17c4f028733a Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Mon, 24 Aug 2020 16:26:14 -0400 Subject: offload: Modify the build-machine record to accept multiple systems. * guix/scripts/offload.scm ()[systems]: New field. [system]: Accessor changed to %build-machine-system. Default to #f. * guix/scripts/offload.scm (build-machine-system): Wrap %build-machine-system with a deprecation warning. (build-machine-systems): Access the new systems field or fallback to use build-machine-system, for backward compatibility. (machine-matches?): Adjust. * tests/offload.scm: Add tests... * Makefile.am (SCM_TESTS): ...and register them. * doc/guix.texi (Daemon Offload Setup): Update doc. --- Makefile.am | 1 + doc/guix.texi | 35 +++++++++++++----------- guix/scripts/offload.scm | 24 +++++++++++++--- tests/offload.scm | 71 ++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 111 insertions(+), 20 deletions(-) create mode 100644 tests/offload.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 4e50a33f82..9c38c2f83c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -433,6 +433,7 @@ SCM_TESTS = \ tests/monads.scm \ tests/nar.scm \ tests/networking.scm \ + tests/offload.scm \ tests/opam.scm \ tests/openpgp.scm \ tests/packages.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 91d3860978..0b79a49814 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1043,29 +1043,31 @@ When desired, the build daemon can @dfn{offload} derivation builds to other machines running Guix, using the @code{offload} @dfn{build hook}@footnote{This feature is available only when @uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH} is -present.}. When that -feature is enabled, a list of user-specified build machines is read from -@file{/etc/guix/machines.scm}; every time a build is requested, for -instance via @code{guix build}, the daemon attempts to offload it to one -of the machines that satisfy the constraints of the derivation, in -particular its system type---e.g., @file{x86_64-linux}. Missing -prerequisites for the build are copied over SSH to the target machine, -which then proceeds with the build; upon success the output(s) of the -build are copied back to the initial machine. +present.}. When that feature is enabled, a list of user-specified build +machines is read from @file{/etc/guix/machines.scm}; every time a build +is requested, for instance via @code{guix build}, the daemon attempts to +offload it to one of the machines that satisfy the constraints of the +derivation, in particular its system types---e.g., @code{x86_64-linux}. +A single machine can have multiple system types, either because its +architecture natively supports it, via emulation (@pxref{Transparent +Emulation with QEMU}), or both. Missing prerequisites for the build are +copied over SSH to the target machine, which then proceeds with the +build; upon success the output(s) of the build are copied back to the +initial machine. The @file{/etc/guix/machines.scm} file typically looks like this: @lisp (list (build-machine (name "eightysix.example.org") - (system "x86_64-linux") + (systems (list "x86_64-linux" "i686-linux")) (host-key "ssh-ed25519 AAAAC3Nza@dots{}") (user "bob") (speed 2.)) ;incredibly fast! (build-machine (name "armeight.example.org") - (system "aarch64-linux") + (systems (list "aarch64-linux")) (host-key "ssh-rsa AAAAB3Nza@dots{}") (user "alice") (private-key @@ -1075,8 +1077,8 @@ The @file{/etc/guix/machines.scm} file typically looks like this: @noindent In the example above we specify a list of two build machines, one for -the @code{x86_64} architecture and one for the @code{aarch64} -architecture. +the @code{x86_64} and @code{i686} architectures and one for the +@code{aarch64} architecture. In fact, this file is---not surprisingly!---a Scheme file that is evaluated when the @code{offload} hook is started. Its return value @@ -1096,8 +1098,9 @@ builds. The important fields are: @item name The host name of the remote machine. -@item system -The system type of the remote machine---e.g., @code{"x86_64-linux"}. +@item systems +The system types the remote machine supports---e.g., @code{(list +"x86_64-linux" "i686-linux")}. @item user The user account to use when connecting to the remote machine over SSH. @@ -25025,7 +25028,7 @@ Maximum number of backup files to keep. Defaults to @samp{3} @end deftypevr - +@node Transparent Emulation with QEMU @subsubheading Transparent Emulation with QEMU @cindex emulation diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 20ae7a9469..a56701f07a 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2020 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -66,14 +67,16 @@ (define-module (guix scripts offload) ;;; ;;; Code: - (define-record-type* build-machine make-build-machine build-machine? (name build-machine-name) ; string (port build-machine-port ; number (default 22)) - (system build-machine-system) ; string + (systems %build-machine-systems ; list of strings + (default #f)) ; drop default after system is removed + (system %build-machine-system ; deprecated + (default #f)) (user build-machine-user) ; string (private-key build-machine-private-key ; file name (default (user-openssh-private-key))) @@ -91,6 +94,19 @@ (define-record-type* (features build-machine-features ; list of strings (default '()))) +;;; Deprecated. +(define (build-machine-system machine) + (warning (G_ "The 'system' field is deprecated, \ +please use 'systems' instead.~%")) + (%build-machine-system machine)) + +;;; TODO: Remove after the deprecated 'system' field is removed. +(define (build-machine-systems machine) + (or (%build-machine-systems machine) + (list (build-machine-system machine)) + (leave (G_ "The build-machine object lacks a value for its 'systems' +field.")))) + (define-record-type* build-requirements make-build-requirements build-requirements? @@ -359,8 +375,8 @@ (define store (define (machine-matches? machine requirements) "Return #t if MACHINE matches REQUIREMENTS." - (and (string=? (build-requirements-system requirements) - (build-machine-system machine)) + (and (member (build-requirements-system requirements) + (build-machine-systems machine)) (lset<= string=? (build-requirements-features requirements) (build-machine-features machine)))) diff --git a/tests/offload.scm b/tests/offload.scm new file mode 100644 index 0000000000..5a5de4e8b9 --- /dev/null +++ b/tests/offload.scm @@ -0,0 +1,71 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Maxim Cournoyer +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (tests offload) + #:use-module (guix scripts offload) + #:use-module (srfi srfi-64)) + + +(test-begin "offload") + +(define-syntax-rule (expose-internal-definitions s1 s2 ...) + (begin + (define s1 (@@ (guix scripts offload) s1)) + (define s2 (@@ (guix scripts offload) s2)) ...)) + +(expose-internal-definitions machine-matches? + build-requirements-system + build-requirements-features + build-machine-system + build-machine-systems + %build-machine-system + %build-machine-systems + build-machine-features) + +(define (deprecated-build-machine system) + (build-machine + (name "m1") + (user "dummy") + (host-key "some-key") + (system system))) + +(define (new-build-machine systems) + (build-machine + (name "m1") + (user "dummy") + (host-key "some-key") + (systems systems))) + +;;; Test that deprecated build-machine definitions still work. +(test-assert (machine-matches? (deprecated-build-machine "i686-linux") + (build-requirements + (system "i686-linux")))) + + +(test-assert (machine-matches? (new-build-machine '("i686-linux")) + (build-requirements + (system "i686-linux")))) + +;;; A build machine can act as more than one system type, thanks to QEMU +;;; emulation. +(test-assert (machine-matches? (new-build-machine '("armhf-linux" + "aarch64-linux" + "i686-linux" + "x86_64-linux")) + (build-requirements + (system "armhf-linux")))) -- cgit v1.2.3 From 4c5edee1ef2aff2b8f3782ccb03723a6428bf600 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 25 Aug 2020 14:49:34 +0200 Subject: lint: Use 'with-error-handling'. This improves the error message when unable to access ~/.cache as reported by Jonathan Brielmaier in . * guix/scripts/lint.scm (guix-lint): Wrap body in 'with-error-handling'. --- guix/scripts/lint.scm | 43 ++++++++++++++++++++++--------------------- 1 file changed, 22 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 97ffd57301..5168a1ca17 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt ;;; Copyright © 2014, 2015 Eric Bavier -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Danny Milosavljevic ;;; Copyright © 2016 Hartmut Goebel @@ -174,23 +174,24 @@ (define (parse-options) (when (assoc-ref opts 'list?) (list-checkers-and-exit checkers)) - (let ((any-lint-checker-requires-store? - (any lint-checker-requires-store? checkers))) - - (define (call-maybe-with-store proc) - (if any-lint-checker-requires-store? - (with-store store - (proc store)) - (proc #f))) - - (call-maybe-with-store - (lambda (store) - (cond - ((null? args) - (fold-packages (lambda (p r) (run-checkers p checkers - #:store store)) '())) - (else - (for-each (lambda (spec) - (run-checkers (specification->package spec) checkers - #:store store)) - args)))))))) + (with-error-handling + (let ((any-lint-checker-requires-store? + (any lint-checker-requires-store? checkers))) + + (define (call-maybe-with-store proc) + (if any-lint-checker-requires-store? + (with-store store + (proc store)) + (proc #f))) + + (call-maybe-with-store + (lambda (store) + (cond + ((null? args) + (fold-packages (lambda (p r) (run-checkers p checkers + #:store store)) '())) + (else + (for-each (lambda (spec) + (run-checkers (specification->package spec) checkers + #:store store)) + args))))))))) -- cgit v1.2.3 From 0c9d22c13fef9056413338293747c0d32f0cd5a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 27 Aug 2020 14:58:45 +0200 Subject: pull: Avoid "Migrating profile" message on the first run. * guix/scripts/pull.scm (ensure-default-profile): Do not call 'migrate-generations' when %USER-PROFILE-DIRECTORY (~/.config/guix/current) does not exist. This avoids a confusing "Migrating profile" message when the user runs 'guix pull' for the first time. --- guix/scripts/pull.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 5b4ccf13fe..3b980b8f3f 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -507,6 +507,7 @@ (define (ensure-default-profile) ;; workaround, skip this code when $SUDO_USER is set. See ;; . (unless (or (getenv "SUDO_USER") + (not (file-exists? %user-profile-directory)) (string=? %profile-directory (dirname (canonicalize-profile %user-profile-directory)))) -- cgit v1.2.3 From 3d9ea605c8dfb7fc43689e12975218b032b3175a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 28 Aug 2020 15:05:17 +0200 Subject: store: 'with-store' returns as many values as its body. Fixes . Reported by Ricardo Wurmus . * guix/store.scm (call-with-store)[thunk]: Wrap call to PROC in 'call-with-values'. * tests/store.scm ("with-store, multiple values"): New test. --- guix/store.scm | 7 ++++--- tests/store.scm | 9 +++++++++ 2 files changed, 13 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 683e125b20..495dc1692c 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -628,9 +628,10 @@ (define (call-with-store proc) (define (thunk) (parameterize ((current-store-protocol-version (store-connection-version store))) - (let ((result (proc store))) - (close-connection store) - result))) + (call-with-values (lambda () (proc store)) + (lambda results + (close-connection store) + (apply values results))))) (cond-expand (guile-3 diff --git a/tests/store.scm b/tests/store.scm index ee3e01f33b..e168d3dcf6 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -141,6 +141,15 @@ (define %shell (string-append (%store-prefix) "/" (make-string 32 #\e) "-foobar")))) +(test-equal "with-store, multiple values" ; + '(1 2 3) + (call-with-values + (lambda () + (with-store s + (add-text-to-store s "foo" "bar") + (values 1 2 3))) + list)) + (test-assert "valid-path? error" (with-store s (guard (c ((store-protocol-error? c) #t)) -- cgit v1.2.3 From 3e339c44103f494174d9c20405563135a95cecf9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 28 Aug 2020 18:31:40 +0200 Subject: derivations: Avoid uses of 'display' in 'write-derivation'. This yields a 4% improvement on the wall-clock time of: guix build -e '(@@ (gnu packages libreoffice) libreoffice)' --no-grafts -d * guix/derivations.scm (write-sequence, write-list, write-tuple): Use 'put-char' instead of 'display'. (write-derivation): Use 'put-string' and 'put-char', and remove unused 'format' binding. --- guix/derivations.scm | 43 +++++++++++++++++++++---------------------- 1 file changed, 21 insertions(+), 22 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 7db61d272f..4fc2e9e768 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -26,6 +26,7 @@ (define-module (guix derivations) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (ice-9 binary-ports) + #:use-module ((ice-9 textual-ports) #:select (put-char put-string)) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) @@ -561,30 +562,29 @@ (define-inlinable (write-sequence lst write-item port) ((prefix (... ...) last) (for-each (lambda (item) (write-item item port) - (display "," port)) + (put-char port #\,)) prefix) (write-item last port)))) (define-inlinable (write-list lst write-item port) ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each ;; element. - (display "[" port) + (put-char port #\[) (write-sequence lst write-item port) - (display "]" port)) + (put-char port #\])) (define-inlinable (write-tuple lst write-item port) ;; Same, but write LST as a tuple. - (display "(" port) + (put-char port #\() (write-sequence lst write-item port) - (display ")" port)) + (put-char port #\))) (define (write-derivation drv port) "Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of Eelco Dolstra's PhD dissertation for an overview of a previous version of that form." - ;; Make sure we're using the faster implementation. - (define format simple-format) + ;; Use 'put-string', which does less work and is faster than 'display'. (define (write-string-list lst) (write-list lst write port)) @@ -605,42 +605,41 @@ (define (write-output output port) (define (write-input input port) (match input (($ obj sub-drvs) - (display "(\"" port) + (put-string port "(\"") ;; 'derivation/masked-inputs' produces objects that contain a string ;; instead of a , so we need to account for that. - (display (if (derivation? obj) - (derivation-file-name obj) - obj) - port) - (display "\"," port) + (put-string port (if (derivation? obj) + (derivation-file-name obj) + obj)) + (put-string port "\",") (write-string-list sub-drvs) - (display ")" port)))) + (put-char port #\))))) (define (write-env-var env-var port) (match env-var ((name . value) - (display "(" port) + (put-string port "(") (write name port) - (display "," port) + (put-string port ",") (write value port) - (display ")" port)))) + (put-string port ")")))) ;; Assume all the lists we are writing are already sorted. (match drv (($ outputs inputs sources system builder args env-vars) - (display "Derive(" port) + (put-string port "Derive(") (write-list outputs write-output port) - (display "," port) + (put-char port #\,) (write-list inputs write-input port) - (display "," port) + (put-char port #\,) (write-string-list sources) (simple-format port ",\"~a\",\"~a\"," system builder) (write-string-list args) - (display "," port) + (put-char port #\,) (write-list env-vars write-env-var port) - (display ")" port)))) + (put-char port #\))))) (define derivation->bytevector (lambda (drv) -- cgit v1.2.3 From 4ec66950f05e99f785c11fea2cbc1f2b079a7dbf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 28 Aug 2020 19:19:04 +0200 Subject: derivations: Avoid uses of 'write' in 'write-derivation'. This leads a 4% improvement on the wall-clock time of: guix build -e '(@@ (gnu packages libreoffice) libreoffice)' --no-grafts -d * guix/derivations.scm (escaped-string): New procedure. (write-derivation)[write-escaped-string]: New procedure. [write-string-list, write-output, write-env-var]: Use it. --- guix/derivations.scm | 47 ++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 40 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 4fc2e9e768..2fe684cc18 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -579,15 +579,48 @@ (define-inlinable (write-tuple lst write-item port) (write-sequence lst write-item port) (put-char port #\))) +(define %escape-char-set + ;; Characters that need to be escaped. + (char-set #\" #\\ #\newline #\return #\tab)) + +(define (escaped-string str) + "Escape double quote characters found in STR, if any." + (define escape + (match-lambda + (#\" "\\\"") + (#\\ "\\\\") + (#\newline "\\n") + (#\return "\\r") + (#\tab "\\t"))) + + (let loop ((str str) + (result '())) + (let ((index (string-index str %escape-char-set))) + (if index + (let ((rest (string-drop str (+ 1 index)))) + (loop rest + (cons* (escape (string-ref str index)) + (string-take str index) + result))) + (if (null? result) + str + (string-concatenate-reverse (cons str result))))))) + (define (write-derivation drv port) "Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of Eelco Dolstra's PhD dissertation for an overview of a previous version of that form." ;; Use 'put-string', which does less work and is faster than 'display'. + ;; Likewise, 'write-escaped-string' is faster than 'write'. + + (define (write-escaped-string str port) + (put-char port #\") + (put-string port (escaped-string str)) + (put-char port #\")) (define (write-string-list lst) - (write-list lst write port)) + (write-list lst write-escaped-string port)) (define (write-output output port) (match output @@ -599,7 +632,7 @@ (define (write-output output port) "") (or (and=> hash bytevector->base16-string) "")) - write + write-escaped-string port)))) (define (write-input input port) @@ -619,11 +652,11 @@ (define (write-input input port) (define (write-env-var env-var port) (match env-var ((name . value) - (put-string port "(") - (write name port) - (put-string port ",") - (write value port) - (put-string port ")")))) + (put-char port #\() + (write-escaped-string name port) + (put-char port #\,) + (write-escaped-string value port) + (put-char port #\))))) ;; Assume all the lists we are writing are already sorted. (match drv -- cgit v1.2.3 From 61fe9ced7da7eefceb931af0cb7363b721f5bdd6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 29 Aug 2020 16:05:05 +0200 Subject: copy, offload: Explicitly close SSH channels and sessions. Fixes . * guix/scripts/copy.scm (send-to-remote-host): Keep the result of 'connect-to-remote-daemon' in scope, and explicitly close it after the call to 'send-files'. (retrieve-from-remote-host): Explicitly close REMOTE and disconnect SESSION. * guix/scripts/offload.scm (transfer-and-offload): Explicitly close STORE and disconnect SESSION upon completion. --- guix/scripts/copy.scm | 8 ++++++-- guix/scripts/offload.scm | 2 ++ 2 files changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 16d2de30f7..274620fc1e 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -20,6 +20,7 @@ (define-module (guix scripts copy) #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix ssh) + #:use-module ((ssh session) #:select (disconnect!)) #:use-module (guix store) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix utils) @@ -71,9 +72,10 @@ (define (send-to-remote-host local target opts) (and (build-derivations local drv) (let* ((session (open-ssh-session host #:user user #:port (or port 22))) - (sent (send-files local items - (connect-to-remote-daemon session) + (remote (connect-to-remote-daemon session)) + (sent (send-files local items remote #:recursive? #t))) + (close-connection remote) (format #t "~{~a~%~}" sent) sent)))) @@ -93,6 +95,8 @@ (define (retrieve-from-remote-host local source opts) (options->derivations+files local opts)) ((retrieved) (retrieve-files local items remote #:recursive? #t))) + (close-connection remote) + (disconnect! session) (format #t "~{~a~%~}" retrieved) retrieved))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index a56701f07a..1e0e9d7905 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -365,6 +365,8 @@ (define store #:log-port (current-error-port) #:lock? #f))) + (close-connection store) + (disconnect! session) (format (current-error-port) "done with offloaded '~a'~%" (derivation-file-name drv))) -- cgit v1.2.3 From bc8be17c4dd1e7bb8eb98a0b7e5bcb0a536719b0 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Tue, 25 Aug 2020 10:52:21 +0200 Subject: environment: Set USER and LOGNAME in container MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/environment.scm (launch-environment/container): Set username environment variables. Signed-off-by: Ludovic Courtès --- guix/scripts/environment.scm | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index b8979cac19..1fb3505307 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -477,6 +477,7 @@ (define (optional-mapping->fs mapping) (group-entry (gid 65534) ;the overflow GID (name "overflow")))) (home-dir (password-entry-directory passwd)) + (logname (password-entry-name passwd)) (environ (filter (match-lambda ((variable . value) (find (cut regexp-exec <> variable) @@ -528,6 +529,10 @@ (define (optional-mapping->fs mapping) ;; The same variables as in Nix's 'build.cc'. '("TMPDIR" "TEMPDIR" "TMP" "TEMP")) + ;; Some programs expect USER and/or LOGNAME to be set. + (setenv "LOGNAME" logname) + (setenv "USER" logname) + ;; Create a dummy home directory. (mkdir-p home-dir) (setenv "HOME" home-dir) -- cgit v1.2.3 From b03267df6d5ec44e9617b6aab0df14a2e79f822e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 31 Aug 2020 11:36:26 +0200 Subject: ssh: 'send-files' displays a progress bar. * guix/store.scm (export-paths): Add #:start, #:progress, and #:finish parameters and honor them. * guix/ssh.scm (prepare-to-send, notify-transfer-progress) (notify-transfer-completion): New procedures. (send-files): Pass #:start, #:progress, and #:finish to 'export-paths'. --- guix/ssh.scm | 77 +++++++++++++++++++++++++++++++++++++++++++++++----------- guix/store.scm | 24 +++++++++++++++--- 2 files changed, 83 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/ssh.scm b/guix/ssh.scm index 24db171374..5f94528520 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -20,7 +20,11 @@ (define-module (guix ssh) #:use-module (guix store) #:use-module (guix inferior) #:use-module (guix i18n) - #:use-module ((guix diagnostics) #:select (&fix-hint formatted-message)) + #:use-module ((guix diagnostics) + #:select (info &fix-hint formatted-message)) + #:use-module ((guix progress) + #:select (progress-bar + erase-current-line current-terminal-columns)) #:use-module (gcrypt pk-crypto) #:use-module (ssh session) #:use-module (ssh auth) @@ -36,6 +40,7 @@ (define-module (guix ssh) #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 binary-ports) + #:use-module (ice-9 vlist) #:export (open-ssh-session authenticate-server* @@ -402,6 +407,55 @@ (define key (string->canonical-sexp ,(canonical-sexp->string key))) session become-command)) +(define (prepare-to-send store host log-port items) + "Notify the user that we're about to send ITEMS to HOST. Return three +values allowing 'notify-send-progress' to track the state of this transfer." + (let* ((count (length items)) + (sizes (fold (lambda (item result) + (vhash-cons item + (path-info-nar-size + (query-path-info store item)) + result)) + vlist-null + items)) + (total (vlist-fold (lambda (pair result) + (match pair + ((_ . size) (+ size result)))) + 0 + sizes))) + (info (N_ "sending ~a store item (~h MiB) to '~a'...~%" + "sending ~a store items (~h MiB) to '~a'...~%" count) + count + (inexact->exact (round (/ total (expt 2. 20)))) + host) + + (values log-port sizes total 0))) + +(define (notify-transfer-progress item port sizes total sent) + "Notify the user that we've already transferred SENT bytes out of TOTAL. +Use SIZES to determine the size of ITEM, which is about to be sent." + (define (display-bar %) + (erase-current-line port) + (format port "~3@a% ~a" + (inexact->exact (round (* 100. (/ sent total)))) + (progress-bar % (- (max (current-terminal-columns) 5) 5))) + (force-output port)) + + (let ((% (* 100. (/ sent total)))) + (match (vhash-assoc item sizes) + (#f + (display-bar %) + (values port sizes total sent)) + ((_ . size) + (display-bar %) + (values port sizes total (+ sent size)))))) + +(define (notify-transfer-completion port . args) + "Notify the user that the transfer has completed." + (apply notify-transfer-progress "" port args) ;display the 100% progress bar + (erase-current-line port) + (force-output port)) + (define* (send-files local files remote #:key recursive? @@ -412,7 +466,7 @@ (define* (send-files local files remote ;; Compute the subset of FILES missing on SESSION and send them. (let* ((files (if recursive? (requisites local files) files)) (session (channel-get-session (store-connection-socket remote))) - (missing (inferior-remote-eval + (missing (take files 20) #;(inferior-remote-eval `(begin (use-modules (guix) (srfi srfi-1) (srfi srfi-26)) @@ -421,11 +475,8 @@ (define* (send-files local files remote (remove (cut valid-path? store <>) ',files))) session)) - (count (length missing)) - (sizes (map (lambda (item) - (path-info-nar-size (query-path-info local item))) - missing)) - (port (store-import-channel session))) + (port (store-import-channel session)) + (host (session-get session 'host))) ;; Make sure everything alright on the remote side. (match (read port) (('importing) @@ -433,14 +484,12 @@ (define* (send-files local files remote (sexp (handle-import/export-channel-error sexp remote))) - (format log-port (N_ "sending ~a store item (~h MiB) to '~a'...~%" - "sending ~a store items (~h MiB) to '~a'...~%" count) - count - (inexact->exact (round (/ (reduce + 0 sizes) (expt 2. 20)))) - (session-get session 'host)) - ;; Send MISSING in topological order. - (export-paths local missing port) + (let ((tty? (isatty? log-port))) + (export-paths local missing port + #:start (cut prepare-to-send local host log-port <>) + #:progress (if tty? notify-transfer-progress (const #f)) + #:finish (if tty? notify-transfer-completion (const #f)))) ;; Tell the remote process that we're done. (In theory the end-of-archive ;; mark of 'export-paths' would be enough, but in practice it's not.) diff --git a/guix/store.scm b/guix/store.scm index 495dc1692c..6bb6f43f56 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1728,10 +1728,20 @@ (define* (export-path server path port #:key (sign? #t)) (or done? (loop (process-stderr server port)))) (= 1 (read-int s)))) -(define* (export-paths server paths port #:key (sign? #t) recursive?) +(define* (export-paths server paths port #:key (sign? #t) recursive? + (start (const #f)) + (progress (const #f)) + (finish (const #f))) "Export the store paths listed in PATHS to PORT, in topological order, signing them if SIGN? is true. When RECURSIVE? is true, export the closure of -PATHS---i.e., PATHS and all their dependencies." +PATHS---i.e., PATHS and all their dependencies. + +START, PROGRESS, and FINISH are used to track progress of the data transfer. +START is a one-argument that is passed the list of store items that will be +transferred; it returns values that are then used as the initial state +threaded through PROGRESS calls. PROGRESS is passed the store item about to +be sent, along with the values previously return by START or by PROGRESS +itself. FINISH is called when the last store item has been called." (define ordered (let ((sorted (topologically-sorted server paths))) ;; When RECURSIVE? is #f, filter out the references of PATHS. @@ -1739,14 +1749,20 @@ (define ordered sorted (filter (cut member <> paths) sorted)))) - (let loop ((paths ordered)) + (let loop ((paths ordered) + (state (call-with-values (lambda () (start ordered)) + list))) (match paths (() + (apply finish state) (write-int 0 port)) ((head tail ...) (write-int 1 port) (and (export-path server head port #:sign? sign?) - (loop tail)))))) + (loop tail + (call-with-values + (lambda () (apply progress head state)) + list))))))) (define-operation (query-failed-paths) "Return the list of store items for which a build failure is cached. -- cgit v1.2.3 From 83ec969cc7170634872d4ff3ffc0d4099a6765a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 31 Aug 2020 12:24:21 +0200 Subject: packages: printer gracefully handle #f values. Suggested by Robin Green . * guix/packages.scm (print-content-hash): Gracefully deal with cases with 'content-hash-value' returns #f, as is the case for 'linux-libre'. --- guix/packages.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 95d7c2cc0d..6598bd3149 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -228,7 +228,8 @@ (define-syntax content-hash (define (print-content-hash hash port) (format port "#" (content-hash-algorithm hash) - (bytevector->nix-base32-string (content-hash-value hash)))) + (and=> (content-hash-value hash) + bytevector->nix-base32-string))) (set-record-type-printer! print-content-hash) -- cgit v1.2.3 From a4e81ff325aa1e0381ec73a57e41a208317b60d6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 31 Aug 2020 14:54:52 +0200 Subject: guix system: reconfigure: Tell users about 'herd status'. * guix/scripts/system.scm (perform-action): Mention 'herd status' when 'upgrade-shepherd-services' completes. --- guix/scripts/system.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index f6d20382b6..7d6fc63a98 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -835,7 +835,9 @@ (define bootcfg (upgrade-shepherd-services local-eval os) (return (format #t (G_ "\ To complete the upgrade, run 'herd restart SERVICE' to stop, -upgrade, and restart each service that was not automatically restarted.\n")))))) +upgrade, and restart each service that was not automatically restarted.\n"))) + (return (format #t (G_ "\ +Run 'herd status' to view the list of services on your system.\n")))))) ((init) (newline) (format #t (G_ "initializing operating system under '~a'...~%") -- cgit v1.2.3 From 7e90e28a156ddc25e3822b931a608890caf3efee Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 31 Aug 2020 15:09:55 +0200 Subject: guix system: Clarify what happens where service upgrade fails. * guix/scripts/system.scm (report-shepherd-error): Use 'warning' instead of 'report-error'. Add extra 'warning' and 'display-hint' calls. --- guix/scripts/system.scm | 47 ++++++++++++++++++++++++++--------------------- 1 file changed, 26 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 7d6fc63a98..3222a53c8f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -271,28 +271,33 @@ (define-syntax-rule (with-shepherd-error-handling mbody ...) (define (report-shepherd-error error) "Report ERROR, a '&shepherd-error' error condition object." - (cond ((service-not-found-error? error) - (report-error (G_ "service '~a' could not be found~%") - (service-not-found-error-service error))) - ((action-not-found-error? error) - (report-error (G_ "service '~a' does not have an action '~a'~%") - (action-not-found-error-service error) - (action-not-found-error-action error))) - ((action-exception-error? error) - (report-error (G_ "exception caught while executing '~a' \ + (when error + (cond ((service-not-found-error? error) + (warning (G_ "service '~a' could not be found~%") + (service-not-found-error-service error))) + ((action-not-found-error? error) + (warning (G_ "service '~a' does not have an action '~a'~%") + (action-not-found-error-service error) + (action-not-found-error-action error))) + ((action-exception-error? error) + (warning (G_ "exception caught while executing '~a' \ on service '~a':~%") - (action-exception-error-action error) - (action-exception-error-service error)) - (print-exception (current-error-port) #f - (action-exception-error-key error) - (action-exception-error-arguments error))) - ((unknown-shepherd-error? error) - (report-error (G_ "something went wrong: ~s~%") - (unknown-shepherd-error-sexp error))) - ((shepherd-error? error) - (report-error (G_ "shepherd error~%"))) - ((not error) ;not an error - #t))) + (action-exception-error-action error) + (action-exception-error-service error)) + (print-exception (current-error-port) #f + (action-exception-error-key error) + (action-exception-error-arguments error))) + ((unknown-shepherd-error? error) + (warning (G_ "something went wrong: ~s~%") + (unknown-shepherd-error-sexp error))) + ((shepherd-error? error) + (warning (G_ "shepherd error~%")))) + + ;; Don't leave users out in the cold and explain what that means and what + ;; they can do. + (warning (G_ "some services could not be upgraded~%")) + (display-hint (G_ "To allow changes to all the system services to take +effect, you will need to reboot.")))) (define-syntax-rule (unless-file-not-found exp) (catch 'system-error -- cgit v1.2.3 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 'guix') 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 @@ (define-module (gnu system image) iso9660-image find-image - system-image)) + system-image + image-with-label)) ;;; @@ -407,6 +408,20 @@ (define root-uuid #: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