Package: guix-patches;
Reported by: Ludovic Courtès <ludo <at> gnu.org>
Date: Thu, 19 Mar 2020 10:57:02 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 40130 in the body.
You can then email your comments to 40130 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org
:bug#40130
; Package guix-patches
.
(Thu, 19 Mar 2020 10:57:02 GMT) Full text and rfc822 format available.Ludovic Courtès <ludo <at> gnu.org>
:guix-patches <at> gnu.org
.
(Thu, 19 Mar 2020 10:57:02 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: guix-patches <at> gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback Date: Thu, 19 Mar 2020 11:56:42 +0100
Hello Guix! This patch series is to always display upfront what’s going to happen, even in the presence of “dynamic dependencies” (grafts), as was reported at: https://issues.guix.gnu.org/issue/28310 With this patch, any time ‘build-things’ is called, we have an opportunity to display what’s going to happen and to choose whether or not to actually build things (dry runs). I’m wondering whether/how this mechanism could be extended to address: https://issues.guix.gnu.org/issue/22990 We’ll see! Ludo’. Ludovic Courtès (8): syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent. store: Add 'with-build-handler'. ui: Add a notification build handler. guix build: Use 'with-build-handler'. deploy: Use 'with-build-handler'. pack: Use 'with-build-handler'. guix package, pull: Use 'with-build-handler'. guix system: Use 'with-build-handler'. .dir-locals.el | 1 + guix/build/syscalls.scm | 64 ++++++------- guix/scripts/build.scm | 114 +++++++++++------------ guix/scripts/deploy.scm | 34 +++---- guix/scripts/pack.scm | 196 +++++++++++++++++++-------------------- guix/scripts/package.scm | 29 +++--- guix/scripts/pull.scm | 118 ++++++++++++----------- guix/scripts/system.scm | 80 ++++++++-------- guix/store.scm | 75 ++++++++++++--- guix/ui.scm | 38 ++++++++ tests/store.scm | 34 ++++++- 11 files changed, 447 insertions(+), 336 deletions(-) -- 2.25.1
guix-patches <at> gnu.org
:bug#40130
; Package guix-patches
.
(Thu, 19 Mar 2020 11:04:02 GMT) Full text and rfc822 format available.Message #8 received at 40130 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 40130 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 1/8] syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent. Date: Thu, 19 Mar 2020 12:02:45 +0100
* guix/build/syscalls.scm (call-with-file-lock) (call-with-file-lock/no-wait): Initialize PORT in the 'dynamic-wind' "in" handler. This allows us to re-enter a captured continuation and have the lock grabbed anew. --- guix/build/syscalls.scm | 64 +++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 31 deletions(-) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index ae79a9708f..0938ec0ff1 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1104,47 +1104,49 @@ exception if it's already taken." #t) (define (call-with-file-lock file thunk) - (let ((port (catch 'system-error - (lambda () - (lock-file file)) - (lambda args - ;; When using the statically-linked Guile in the initrd, - ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore - ;; that error since we're typically the only process running - ;; at this point. - (if (= ENOSYS (system-error-errno args)) - #f - (apply throw args)))))) + (let ((port #f)) (dynamic-wind (lambda () - #t) + (set! port + (catch 'system-error + (lambda () + (lock-file file)) + (lambda args + ;; When using the statically-linked Guile in the initrd, + ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore + ;; that error since we're typically the only process running + ;; at this point. + (if (= ENOSYS (system-error-errno args)) + #f + (apply throw args)))))) thunk (lambda () (when port (unlock-file port)))))) (define (call-with-file-lock/no-wait file thunk handler) - (let ((port (catch #t - (lambda () - (lock-file file #:wait? #f)) - (lambda (key . args) - (match key - ('flock-error - (apply handler args) - ;; No open port to the lock, so return #f. - #f) - ('system-error - ;; When using the statically-linked Guile in the initrd, - ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore - ;; that error since we're typically the only process running - ;; at this point. - (if (= ENOSYS (system-error-errno (cons key args))) - #f - (apply throw key args))) - (_ (apply throw key args))))))) + (let ((port #f)) (dynamic-wind (lambda () - #t) + (set! port + (catch #t + (lambda () + (lock-file file #:wait? #f)) + (lambda (key . args) + (match key + ('flock-error + (apply handler args) + ;; No open port to the lock, so return #f. + #f) + ('system-error + ;; When using the statically-linked Guile in the initrd, + ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore + ;; that error since we're typically the only process running + ;; at this point. + (if (= ENOSYS (system-error-errno (cons key args))) + #f + (apply throw key args))) + (_ (apply throw key args))))))) thunk (lambda () (when port -- 2.25.1
guix-patches <at> gnu.org
:bug#40130
; Package guix-patches
.
(Thu, 19 Mar 2020 11:04:02 GMT) Full text and rfc822 format available.Message #11 received at 40130 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 40130 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 2/8] store: Add 'with-build-handler'. Date: Thu, 19 Mar 2020 12:02:46 +0100
* guix/store.scm (current-build-prompt): New variable. (call-with-build-handler, invoke-build-handler): New procedures. (with-build-handler): New macro. * tests/store.scm ("with-build-handler"): New test. --- .dir-locals.el | 1 + guix/store.scm | 75 +++++++++++++++++++++++++++++++++++++++---------- tests/store.scm | 34 +++++++++++++++++++++- 3 files changed, 94 insertions(+), 16 deletions(-) diff --git a/.dir-locals.el b/.dir-locals.el index 1976f7e60d..ce305602f2 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -68,6 +68,7 @@ (eval . (put 'with-derivation-substitute 'scheme-indent-function 2)) (eval . (put 'with-status-report 'scheme-indent-function 1)) (eval . (put 'with-status-verbosity 'scheme-indent-function 1)) + (eval . (put 'with-build-handler 'scheme-indent-function 1)) (eval . (put 'mlambda 'scheme-indent-function 1)) (eval . (put 'mlambdaq 'scheme-indent-function 1)) diff --git a/guix/store.scm b/guix/store.scm index 2c3675dca6..59c1548efc 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo <at> gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo <at> gnu.org> ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke <at> gnu.org> ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe <at> gmail.com> ;;; Copyright © 2020 Florian Pelz <pelzflorian <at> pelzflorian.de> @@ -104,6 +104,7 @@ add-to-store add-file-tree-to-store binary-file + with-build-handler build-things build query-failed-paths @@ -1222,6 +1223,46 @@ an arbitrary directory layout in the store without creating a derivation." (hash-set! cache tree result) result))))) +(define current-build-prompt + ;; When true, this is the prompt to abort to when 'build-things' is called. + (make-parameter #f)) + +(define (call-with-build-handler handler thunk) + "Register HANDLER as a \"build handler\" and invoke THUNK." + (define tag + (make-prompt-tag "build handler")) + + (parameterize ((current-build-prompt tag)) + (call-with-prompt tag + thunk + (lambda (k . args) + ;; Since HANDLER may call K, which in turn may call 'build-things' + ;; again, reinstate a prompt (thus, it's not a tail call.) + (call-with-build-handler handler + (lambda () + (apply handler k args))))))) + +(define (invoke-build-handler store things mode) + "Abort to 'current-build-prompt' if it is set." + (or (not (current-build-prompt)) + (abort-to-prompt (current-build-prompt) store things mode))) + +(define-syntax-rule (with-build-handler handler exp ...) + "Register HANDLER as a \"build handler\" and invoke THUNK. When +'build-things' is called within the dynamic extent of the call to THUNK, +HANDLER is invoked like so: + + (HANDLER CONTINUE STORE THINGS MODE) + +where CONTINUE is the continuation, and the remaining arguments are those that +were passed to 'build-things'. + +Build handlers are useful to announce a build plan with 'show-what-to-build' +and to implement dry runs (by not invoking CONTINUE) in a way that gracefully +deals with \"dynamic dependencies\" such as grafts---derivations that depend +on the build output of a previous derivation." + (call-with-build-handler handler (lambda () exp ...))) + (define build-things (let ((build (operation (build-things (string-list things) (integer mode)) @@ -1236,20 +1277,24 @@ outputs, and return when the worker is done building them. Elements of THINGS that are not derivations can only be substituted and not built locally. Alternately, an element of THING can be a derivation/output name pair, in which case the daemon will attempt to substitute just the requested output of -the derivation. Return #t on success." - (let ((things (map (match-lambda - ((drv . output) (string-append drv "!" output)) - (thing thing)) - things))) - (parameterize ((current-store-protocol-version - (store-connection-version store))) - (if (>= (store-connection-minor-version store) 15) - (build store things mode) - (if (= mode (build-mode normal)) - (build/old store things) - (raise (condition (&store-protocol-error - (message "unsupported build mode") - (status 1))))))))))) +the derivation. Return #t on success. + +When a handler is installed with 'with-build-handler', it is called any time +'build-things' is called." + (and (invoke-build-handler store things mode) + (let ((things (map (match-lambda + ((drv . output) (string-append drv "!" output)) + (thing thing)) + things))) + (parameterize ((current-store-protocol-version + (store-connection-version store))) + (if (>= (store-connection-minor-version store) 15) + (build store things mode) + (if (= mode (build-mode normal)) + (build/old store things) + (raise (condition (&store-protocol-error + (message "unsupported build mode") + (status 1)))))))))))) (define-operation (add-temp-root (store-path path)) "Make PATH a temporary root for the duration of the current session. diff --git a/tests/store.scm b/tests/store.scm index 2b14a4af0a..b61a981b28 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo <at> gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo <at> gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -380,6 +380,38 @@ (equal? (valid-derivers %store o) (list (derivation-file-name d)))))) +(test-equal "with-build-handler" + 'success + (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) + (s (add-to-store %store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d1 (derivation %store "the-thing" + s `("-e" ,b) + #:env-vars `(("foo" . ,(random-text))) + #:sources (list b s))) + (d2 (derivation %store "the-thing" + s `("-e" ,b) + #:env-vars `(("foo" . ,(random-text)) + ("bar" . "baz")) + #:sources (list b s))) + (o1 (derivation->output-path d1)) + (o2 (derivation->output-path d2))) + (with-build-handler + (let ((counter 0)) + (lambda (continue store things mode) + (match things + ((drv) + (set! counter (+ 1 counter)) + (if (string=? drv (derivation-file-name d1)) + (continue #t) + (and (string=? drv (derivation-file-name d2)) + (= counter 2) + 'success)))))) + (build-derivations %store (list d1)) + (build-derivations %store (list d2)) + 'fail))) + (test-assert "topologically-sorted, one item" (let* ((a (add-text-to-store %store "a" "a")) (b (add-text-to-store %store "b" "b" (list a))) -- 2.25.1
guix-patches <at> gnu.org
:bug#40130
; Package guix-patches
.
(Thu, 19 Mar 2020 11:04:03 GMT) Full text and rfc822 format available.Message #14 received at 40130 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 40130 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 3/8] ui: Add a notification build handler. Date: Thu, 19 Mar 2020 12:02:47 +0100
* guix/ui.scm (build-notifier): New variable. --- guix/ui.scm | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/guix/ui.scm b/guix/ui.scm index 6f1ca9c0b2..47ada9dde2 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -93,6 +93,7 @@ string->number* size->number show-derivation-outputs + build-notifier show-what-to-build show-what-to-build* show-manifest-transaction @@ -1045,6 +1046,43 @@ check and report what is prerequisites are available for download." (define show-what-to-build* (store-lift show-what-to-build)) +(define* (build-notifier #:key (dry-run? #f) (use-substitutes? #t)) + "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 +any build happening." + (define not-comma + (char-set-complement (char-set #\,))) + + (define (read-derivation-from-file* item) + (catch 'system-error + (lambda () + (read-derivation-from-file item)) + (const #f))) + + (lambda (continuation store things mode) + (define inputs + ;; List of derivation inputs to build. Filter out non-existent '.drv' + ;; files because the daemon transparently tries to substitute them. + (filter-map (match-lambda + (((? derivation-path? drv) . output) + (let ((drv (read-derivation-from-file* drv)) + (outputs (string-tokenize output not-comma))) + (and drv (derivation-input drv outputs)))) + ((? derivation-path? drv) + (and=> (read-derivation-from-file* drv) + derivation-input)) + (_ + #f)) + things)) + + (show-what-to-build store inputs + #:dry-run? dry-run? + #:use-substitutes? use-substitutes? + #:mode mode) + (unless dry-run? + (continuation #t)))) + (define (right-arrow port) "Return either a string containing the 'RIGHT ARROW' character, or an ASCII replacement if PORT is not Unicode-capable." -- 2.25.1
guix-patches <at> gnu.org
:bug#40130
; Package guix-patches
.
(Thu, 19 Mar 2020 11:04:03 GMT) Full text and rfc822 format available.Message #17 received at 40130 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 40130 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 4/8] guix build: Use 'with-build-handler'. Date: Thu, 19 Mar 2020 12:02:48 +0100
Fixes <https://bugs.gnu.org/28310>. Reported by Andreas Enge <andreas <at> enge.fr>. * guix/scripts/build.scm (guix-build): Wrap 'parameterize' in 'with-build-handler'. Remove explicit call to 'show-what-to-build'. Call 'build-derivations' regardless of whether OPTS contains 'dry-run?'. --- guix/scripts/build.scm | 114 ++++++++++++++++++++--------------------- 1 file changed, 55 insertions(+), 59 deletions(-) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index da2a675ce2..af18d8b6f9 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -952,64 +952,60 @@ needed." ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) - (parameterize ((current-terminal-columns (terminal-columns)) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (parameterize ((current-terminal-columns (terminal-columns)) - ;; Set grafting upfront in case the user's input - ;; depends on it (e.g., a manifest or code snippet that - ;; calls 'gexp->derivation'). - (%graft? graft?)) - (let* ((mode (assoc-ref opts 'build-mode)) - (drv (options->derivations store opts)) - (urls (map (cut string-append <> "/log") - (if (assoc-ref opts 'substitutes?) - (or (assoc-ref opts 'substitute-urls) - ;; XXX: This does not necessarily match the - ;; daemon's substitute URLs. - %default-substitute-urls) - '()))) - (items (filter-map (match-lambda - (('argument . (? store-path? file)) - ;; If FILE is a .drv that's not in - ;; store, keep it so that it can be - ;; substituted. - (and (or (not (derivation-path? file)) - (not (file-exists? file))) - file)) - (_ #f)) - opts)) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) + ;; Set grafting upfront in case the user's input + ;; depends on it (e.g., a manifest or code snippet that + ;; calls 'gexp->derivation'). + (%graft? graft?)) + (let* ((mode (assoc-ref opts 'build-mode)) + (drv (options->derivations store opts)) + (urls (map (cut string-append <> "/log") + (if (assoc-ref opts 'substitutes?) + (or (assoc-ref opts 'substitute-urls) + ;; XXX: This does not necessarily match the + ;; daemon's substitute URLs. + %default-substitute-urls) + '()))) + (items (filter-map (match-lambda + (('argument . (? store-path? file)) + ;; If FILE is a .drv that's not in + ;; store, keep it so that it can be + ;; substituted. + (and (or (not (derivation-path? file)) + (not (file-exists? file))) + file)) + (_ #f)) + opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) - (unless (or (assoc-ref opts 'log-file?) - (assoc-ref opts 'derivations-only?)) - (show-what-to-build store drv - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?) - #:mode mode)) - - (cond ((assoc-ref opts 'log-file?) - ;; Pass 'show-build-log' the output file names, not the - ;; derivation file names, because there can be several - ;; derivations leading to the same output. - (for-each (cut show-build-log store <> urls) - (delete-duplicates - (append (map derivation->output-path drv) - items)))) - ((assoc-ref opts 'derivations-only?) - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root store <> <>) - (map (compose list derivation-file-name) drv) - roots)) - ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations store (append drv items) - mode) - (for-each show-derivation-outputs drv) - (for-each (cut register-root store <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots)))))))))) + (cond ((assoc-ref opts 'log-file?) + ;; Pass 'show-build-log' the output file names, not the + ;; derivation file names, because there can be several + ;; derivations leading to the same output. + (for-each (cut show-build-log store <> urls) + (delete-duplicates + (append (map derivation->output-path drv) + items)))) + ((assoc-ref opts 'derivations-only?) + (format #t "~{~a~%~}" (map derivation-file-name drv)) + (for-each (cut register-root store <> <>) + (map (compose list derivation-file-name) drv) + roots)) + (else + (and (build-derivations store (append drv items) + mode) + (for-each show-derivation-outputs drv) + (for-each (cut register-root store <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots))))))))))) -- 2.25.1
guix-patches <at> gnu.org
:bug#40130
; Package guix-patches
.
(Thu, 19 Mar 2020 11:04:04 GMT) Full text and rfc822 format available.Message #20 received at 40130 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 40130 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 5/8] deploy: Use 'with-build-handler'. Date: Thu, 19 Mar 2020 12:02:49 +0100
Until now, 'guix deploy' would never display what is going to be built. * guix/scripts/deploy.scm (guix-deploy): Wrap 'for-each' in 'with-build-handler'. --- guix/scripts/deploy.scm | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index ad05c333dc..a82dde00a4 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -108,19 +108,21 @@ Perform the deployment specified by FILE.\n")) (with-status-verbosity (assoc-ref opts 'verbosity) (with-store store (set-build-options-from-command-line store opts) - (for-each (lambda (machine) - (info (G_ "deploying to ~a...~%") - (machine-display-name machine)) - (parameterize ((%graft? (assq-ref opts 'graft?))) - (guard (c ((message-condition? c) - (report-error (G_ "failed to deploy ~a: ~a~%") - (machine-display-name machine) - (condition-message c))) - ((deploy-error? c) - (when (deploy-error-should-roll-back c) - (info (G_ "rolling back ~a...~%") - (machine-display-name machine)) - (run-with-store store (roll-back-machine machine))) - (apply throw (deploy-error-captured-args c)))) - (run-with-store store (deploy-machine machine))))) - machines))))) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?)) + (for-each (lambda (machine) + (info (G_ "deploying to ~a...~%") + (machine-display-name machine)) + (parameterize ((%graft? (assq-ref opts 'graft?))) + (guard (c ((message-condition? c) + (report-error (G_ "failed to deploy ~a: ~a~%") + (machine-display-name machine) + (condition-message c))) + ((deploy-error? c) + (when (deploy-error-should-roll-back c) + (info (G_ "rolling back ~a...~%") + (machine-display-name machine)) + (run-with-store store (roll-back-machine machine))) + (apply throw (deploy-error-captured-args c)))) + (run-with-store store (deploy-machine machine))))) + machines)))))) -- 2.25.1
guix-patches <at> gnu.org
:bug#40130
; Package guix-patches
.
(Thu, 19 Mar 2020 11:04:04 GMT) Full text and rfc822 format available.Message #23 received at 40130 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 40130 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 6/8] pack: Use 'with-build-handler'. Date: Thu, 19 Mar 2020 12:02:50 +0100
* guix/scripts/pack.scm (guix-pack): Wrap 'parameterize' in 'with-build-handler'. Remove explicit call to 'show-what-to-build'. Call 'build-derivations' regardless of whether OPTS contains 'dry-run?'. --- guix/scripts/pack.scm | 196 +++++++++++++++++++++--------------------- 1 file changed, 97 insertions(+), 99 deletions(-) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 652b4c63c4..6829d7265f 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1022,108 +1022,106 @@ Create a bundle of PACKAGE.\n")) ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2)) - (assoc-ref opts 'system) - #:graft? (assoc-ref opts 'graft?)))) - (let* ((dry-run? (assoc-ref opts 'dry-run?)) - (derivation? (assoc-ref opts 'derivation-only?)) - (relocatable? (assoc-ref opts 'relocatable?)) - (proot? (eq? relocatable? 'proot)) - (manifest (let ((manifest (manifest-from-args store opts))) - ;; Note: We cannot honor '--bootstrap' here because - ;; 'glibc-bootstrap' lacks 'libc.a'. - (if relocatable? - (map-manifest-entries - (cut wrapped-manifest-entry <> #:proot? proot?) - manifest) - manifest))) - (pack-format (assoc-ref opts 'format)) - (name (string-append (symbol->string pack-format) - "-pack")) - (target (assoc-ref opts 'target)) - (bootstrap? (assoc-ref opts 'bootstrap?)) - (compressor (if bootstrap? - bootstrap-xz - (assoc-ref opts 'compressor))) - (archiver (if (equal? pack-format 'squashfs) - squashfs-tools - (if bootstrap? - %bootstrap-coreutils&co - tar))) - (symlinks (assoc-ref opts 'symlinks)) - (build-image (match (assq-ref %formats pack-format) - ((? procedure? proc) proc) - (#f - (leave (G_ "~a: unknown pack format~%") - pack-format)))) - (localstatedir? (assoc-ref opts 'localstatedir?)) - (entry-point (assoc-ref opts 'entry-point)) - (profile-name (assoc-ref opts 'profile-name)) - (gc-root (assoc-ref opts 'gc-root))) - (define (lookup-package package) - (manifest-lookup manifest (manifest-pattern (name package)))) + (with-build-handler (build-notifier #:dry-run? + (assoc-ref opts 'dry-run?) + #:use-substitutes? + (assoc-ref opts 'substitutes?)) + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2)) + (assoc-ref opts 'system) + #:graft? (assoc-ref opts 'graft?)))) + (let* ((derivation? (assoc-ref opts 'derivation-only?)) + (relocatable? (assoc-ref opts 'relocatable?)) + (proot? (eq? relocatable? 'proot)) + (manifest (let ((manifest (manifest-from-args store opts))) + ;; Note: We cannot honor '--bootstrap' here because + ;; 'glibc-bootstrap' lacks 'libc.a'. + (if relocatable? + (map-manifest-entries + (cut wrapped-manifest-entry <> #:proot? proot?) + manifest) + manifest))) + (pack-format (assoc-ref opts 'format)) + (name (string-append (symbol->string pack-format) + "-pack")) + (target (assoc-ref opts 'target)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (compressor (if bootstrap? + bootstrap-xz + (assoc-ref opts 'compressor))) + (archiver (if (equal? pack-format 'squashfs) + squashfs-tools + (if bootstrap? + %bootstrap-coreutils&co + tar))) + (symlinks (assoc-ref opts 'symlinks)) + (build-image (match (assq-ref %formats pack-format) + ((? procedure? proc) proc) + (#f + (leave (G_ "~a: unknown pack format~%") + pack-format)))) + (localstatedir? (assoc-ref opts 'localstatedir?)) + (entry-point (assoc-ref opts 'entry-point)) + (profile-name (assoc-ref opts 'profile-name)) + (gc-root (assoc-ref opts 'gc-root))) + (define (lookup-package package) + (manifest-lookup manifest (manifest-pattern (name package)))) - (when (null? (manifest-entries manifest)) - (warning (G_ "no packages specified; building an empty pack~%"))) + (when (null? (manifest-entries manifest)) + (warning (G_ "no packages specified; building an empty pack~%"))) - (when (and (eq? pack-format 'squashfs) - (not (any lookup-package '("bash" "bash-minimal")))) - (warning (G_ "Singularity requires you to provide a shell~%")) - (display-hint (G_ "Add @code{bash} or @code{bash-minimal} \ + (when (and (eq? pack-format 'squashfs) + (not (any lookup-package '("bash" "bash-minimal")))) + (warning (G_ "Singularity requires you to provide a shell~%")) + (display-hint (G_ "Add @code{bash} or @code{bash-minimal} \ to your package list."))) - (run-with-store store - (mlet* %store-monad ((profile (profile-derivation - manifest + (run-with-store store + (mlet* %store-monad ((profile (profile-derivation + manifest - ;; Always produce relative - ;; symlinks for Singularity (see - ;; <https://bugs.gnu.org/34913>). - #:relative-symlinks? - (or relocatable? - (eq? 'squashfs pack-format)) + ;; Always produce relative + ;; symlinks for Singularity (see + ;; <https://bugs.gnu.org/34913>). + #:relative-symlinks? + (or relocatable? + (eq? 'squashfs pack-format)) - #:hooks (if bootstrap? - '() - %default-profile-hooks) - #:locales? (not bootstrap?) - #:target target)) - (drv (build-image name profile - #:target - target - #:compressor - compressor - #:symlinks - symlinks - #:localstatedir? - localstatedir? - #:entry-point - entry-point - #:profile-name - profile-name - #:archiver - archiver))) - (mbegin %store-monad - (munless derivation? - (show-what-to-build* (list drv) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? dry-run?)) - (mwhen derivation? - (return (format #t "~a~%" - (derivation-file-name drv)))) - (munless (or derivation? dry-run?) - (built-derivations (list drv)) - (mwhen gc-root - (register-root* (match (derivation->output-paths drv) - (((names . items) ...) - items)) - gc-root)) - (return (format #t "~a~%" - (derivation->output-path drv)))))) - #:system (assoc-ref opts 'system)))))))) + #:hooks (if bootstrap? + '() + %default-profile-hooks) + #:locales? (not bootstrap?) + #:target target)) + (drv (build-image name profile + #:target + target + #:compressor + compressor + #:symlinks + symlinks + #:localstatedir? + localstatedir? + #:entry-point + entry-point + #:profile-name + profile-name + #:archiver + archiver))) + (mbegin %store-monad + (mwhen derivation? + (return (format #t "~a~%" + (derivation-file-name drv)))) + (munless derivation? + (built-derivations (list drv)) + (mwhen gc-root + (register-root* (match (derivation->output-paths drv) + (((names . items) ...) + items)) + gc-root)) + (return (format #t "~a~%" + (derivation->output-path drv)))))) + #:system (assoc-ref opts 'system))))))))) -- 2.25.1
guix-patches <at> gnu.org
:bug#40130
; Package guix-patches
.
(Thu, 19 Mar 2020 11:04:04 GMT) Full text and rfc822 format available.Message #26 received at 40130 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 40130 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 7/8] guix package, pull: Use 'with-build-handler'. Date: Thu, 19 Mar 2020 12:02:51 +0100
* guix/scripts/package.scm (build-and-use-profile): Remove #:dry-run? and #:use-substitutes?. Remove call to 'show-what-to-build' and 'dry-run?' special case. (process-actions): Adjust accordingly. (guix-package*): Wrap 'parameterize' in 'with-build-handler'. * guix/scripts/pull.scm (build-and-install): Remove #:use-substitutes? and #:dry-run? and adjust 'update-profile' call accordingly. Remove 'dry-run?' conditional. (guix-pull): Wrap body in 'with-build-handler'. --- guix/scripts/package.scm | 29 +++++----- guix/scripts/pull.scm | 118 +++++++++++++++++++-------------------- 2 files changed, 71 insertions(+), 76 deletions(-) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index d2f4f1ccd3..dd7e6bb7e1 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -134,8 +134,7 @@ denote ranges as interpreted by 'matching-generations'." #:key (hooks %default-profile-hooks) allow-collisions? - bootstrap? use-substitutes? - dry-run?) + bootstrap?) "Build a new generation of PROFILE, a file name, using the packages specified in MANIFEST, a manifest object. When ALLOW-COLLISIONS? is true, do not treat collisions in MANIFEST as an error. HOOKS is a list of \"profile @@ -146,12 +145,8 @@ hooks\" run when building the profile." #:hooks (if bootstrap? '() hooks) #:locales? (not bootstrap?)))) (prof (derivation->output-path prof-drv))) - (show-what-to-build store (list prof-drv) - #:use-substitutes? use-substitutes? - #:dry-run? dry-run?) (cond - (dry-run? #t) ((and (file-exists? profile) (and=> (readlink* profile) (cut string=? prof <>))) (format (current-error-port) (G_ "nothing to be done~%"))) @@ -922,9 +917,7 @@ processed, #f otherwise." #:dry-run? dry-run?) (build-and-use-profile store profile new #:allow-collisions? allow-collisions? - #:bootstrap? bootstrap? - #:use-substitutes? substitutes? - #:dry-run? dry-run?))))) + #:bootstrap? bootstrap?))))) ;;; @@ -953,10 +946,14 @@ option processing with 'parse-command-line'." (%graft? (assoc-ref opts 'graft?))) (with-status-verbosity (assoc-ref opts 'verbosity) (set-build-options-from-command-line (%store) opts) - (parameterize ((%guile-for-build - (package-derivation - (%store) - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2))))) - (process-actions (%store) opts))))))) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (parameterize ((%guile-for-build + (package-derivation + (%store) + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2))))) + (process-actions (%store) opts)))))))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 51d4da209a..7fc23e1b47 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -389,8 +389,7 @@ previous generation. Return true if there are news to display." (display-channel-news profile)) -(define* (build-and-install instances profile - #:key use-substitutes? dry-run?) +(define* (build-and-install instances profile) "Build the tool from SOURCE, and install it in PROFILE. When DRY-RUN? is true, display what would be built without actually building it." (define update-profile @@ -403,29 +402,27 @@ true, display what would be built without actually building it." (mlet %store-monad ((manifest (channel-instances->manifest instances))) (mbegin %store-monad (update-profile profile manifest - #:use-substitutes? use-substitutes? - #:hooks %channel-profile-hooks - #:dry-run? dry-run?) - (munless dry-run? - (return (newline)) - (return - (let ((more? (list (display-profile-news profile #:concise? #t) - (display-channel-news-headlines profile)))) - (when (any ->bool more?) - (display-hint - (G_ "Run @command{guix pull --news} to read all the news."))))) - (if guix-command - (let ((new (map (cut string-append <> "/bin/guix") - (list (user-friendly-profile profile) - profile)))) - ;; Is the 'guix' command previously in $PATH the same as the new - ;; one? If the answer is "no", then suggest 'hash guix'. - (unless (member guix-command new) - (display-hint (format #f (G_ "After setting @code{PATH}, run + #:hooks %channel-profile-hooks) + + (return + (let ((more? (list (display-profile-news profile #:concise? #t) + (display-channel-news-headlines profile)))) + (newline) + (when (any ->bool more?) + (display-hint + (G_ "Run @command{guix pull --news} to read all the news."))))) + (if guix-command + (let ((new (map (cut string-append <> "/bin/guix") + (list (user-friendly-profile profile) + profile)))) + ;; Is the 'guix' command previously in $PATH the same as the new + ;; one? If the answer is "no", then suggest 'hash guix'. + (unless (member guix-command new) + (display-hint (format #f (G_ "After setting @code{PATH}, run @command{hash guix} to make sure your shell refers to @file{~a}.") - (first new)))) - (return #f)) - (return #f)))))) + (first new)))) + (return #f)) + (return #f))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." @@ -760,10 +757,12 @@ Use '~/.config/guix/channels.scm' instead.")) (define (guix-pull . args) (with-error-handling (with-git-error-handling - (let* ((opts (parse-command-line args %options - (list %default-options))) - (channels (channel-list opts)) - (profile (or (assoc-ref opts 'profile) %current-profile))) + (let* ((opts (parse-command-line args %options + (list %default-options))) + (substitutes? (assoc-ref opts 'substitutes?)) + (dry-run? (assoc-ref opts 'dry-run?)) + (channels (channel-list opts)) + (profile (or (assoc-ref opts 'profile) %current-profile))) (cond ((assoc-ref opts 'query) (process-query opts profile)) ((assoc-ref opts 'generation) @@ -773,38 +772,37 @@ Use '~/.config/guix/channels.scm' instead.")) (with-status-verbosity (assoc-ref opts 'verbosity) (parameterize ((%current-system (assoc-ref opts 'system)) (%graft? (assoc-ref opts 'graft?))) - (set-build-options-from-command-line store opts) - (ensure-default-profile) - (honor-x509-certificates store) + (with-build-handler (build-notifier #:use-substitutes? + substitutes? + #:dry-run? dry-run?) + (set-build-options-from-command-line store opts) + (ensure-default-profile) + (honor-x509-certificates store) - (let ((instances (latest-channel-instances store channels))) - (format (current-error-port) - (N_ "Building from this channel:~%" - "Building from these channels:~%" - (length instances))) - (for-each (lambda (instance) - (let ((channel - (channel-instance-channel instance))) - (format (current-error-port) - " ~10a~a\t~a~%" - (channel-name channel) - (channel-url channel) - (string-take - (channel-instance-commit instance) - 7)))) - instances) - (parameterize ((%guile-for-build - (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2))))) - (with-profile-lock profile - (run-with-store store - (build-and-install instances profile - #:dry-run? - (assoc-ref opts 'dry-run?) - #:use-substitutes? - (assoc-ref opts 'substitutes?))))))))))))))) + (let ((instances (latest-channel-instances store channels))) + (format (current-error-port) + (N_ "Building from this channel:~%" + "Building from these channels:~%" + (length instances))) + (for-each (lambda (instance) + (let ((channel + (channel-instance-channel instance))) + (format (current-error-port) + " ~10a~a\t~a~%" + (channel-name channel) + (channel-url channel) + (string-take + (channel-instance-commit instance) + 7)))) + instances) + (parameterize ((%guile-for-build + (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2))))) + (with-profile-lock profile + (run-with-store store + (build-and-install instances profile))))))))))))))) ;;; pull.scm ends here -- 2.25.1
guix-patches <at> gnu.org
:bug#40130
; Package guix-patches
.
(Thu, 19 Mar 2020 11:04:05 GMT) Full text and rfc822 format available.Message #29 received at 40130 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 40130 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 8/8] guix system: Use 'with-build-handler'. Date: Thu, 19 Mar 2020 12:02:52 +0100
* guix/scripts/system.scm (reinstall-bootloader): Remove call to 'show-what-to-build*'. (perform-action): Call 'build-derivations' instead of 'maybe-build'. (process-action): Wrap 'run-with-store' in 'with-build-handler'. --- guix/scripts/system.scm | 80 +++++++++++++++++++++-------------------- 1 file changed, 41 insertions(+), 39 deletions(-) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index ac2475c551..8d1938281a 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo <at> gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo <at> gnu.org> ;;; Copyright © 2016 Alex Kost <alezost <at> gmail.com> ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich <at> gmail.com> ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe <at> gmail.com> @@ -403,7 +403,6 @@ STORE is an open connection to the store." #:old-entries old-entries))) (drvs -> (list bootcfg))) (mbegin %store-monad - (show-what-to-build* drvs) (built-derivations drvs) ;; Only install bootloader configuration file. (install-bootloader local-eval bootloader-config bootcfg @@ -837,8 +836,7 @@ static checks." (% (if derivations-only? (return (for-each (compose println derivation-file-name) drvs)) - (maybe-build drvs #:dry-run? dry-run? - #:use-substitutes? use-substitutes?)))) + (built-derivations drvs)))) (if (or dry-run? derivations-only?) (return #f) @@ -1139,42 +1137,46 @@ resulting from command-line parsing." (with-store store (set-build-options-from-command-line store opts) - (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (case action - ((extension-graph) - (export-extension-graph os (current-output-port))) - ((shepherd-graph) - (export-shepherd-graph os (current-output-port))) - (else - (unless (memq action '(build init)) - (warn-about-old-distro #:suggested-command - "guix system reconfigure")) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (case action + ((extension-graph) + (export-extension-graph os (current-output-port))) + ((shepherd-graph) + (export-shepherd-graph os (current-output-port))) + (else + (unless (memq action '(build init)) + (warn-about-old-distro #:suggested-command + "guix system reconfigure")) - (perform-action action os - #:dry-run? dry? - #:derivations-only? (assoc-ref opts - 'derivations-only?) - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:skip-safety-checks? - (assoc-ref opts 'skip-safety-checks?) - #:file-system-type (assoc-ref opts 'file-system-type) - #:image-size (assoc-ref opts 'image-size) - #:full-boot? (assoc-ref opts 'full-boot?) - #:container-shared-network? - (assoc-ref opts 'container-shared-network?) - #:mappings (filter-map (match-lambda - (('file-system-mapping . m) - m) - (_ #f)) - opts) - #:install-bootloader? bootloader? - #:target target-file - #:bootloader-target bootloader-target - #:gc-root (assoc-ref opts 'gc-root))))) - #:target target - #:system system)) + (perform-action action os + #:dry-run? dry? + #:derivations-only? (assoc-ref opts + 'derivations-only?) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:skip-safety-checks? + (assoc-ref opts 'skip-safety-checks?) + #:file-system-type (assoc-ref opts 'file-system-type) + #:image-size (assoc-ref opts 'image-size) + #:full-boot? (assoc-ref opts 'full-boot?) + #:container-shared-network? + (assoc-ref opts 'container-shared-network?) + #:mappings (filter-map (match-lambda + (('file-system-mapping . m) + m) + (_ #f)) + opts) + #:install-bootloader? bootloader? + #:target target-file + #:bootloader-target bootloader-target + #:gc-root (assoc-ref opts 'gc-root))))) + #:target target + #:system system))) (warn-about-disk-space))) (define (resolve-subcommand name) -- 2.25.1
Ludovic Courtès <ludo <at> gnu.org>
:Ludovic Courtès <ludo <at> gnu.org>
:Message #34 received at 40130-done <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 40130-done <at> debbugs.gnu.org Subject: Re: [bug#40130] [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback Date: Sun, 22 Mar 2020 12:44:43 +0100
Ludovic Courtès <ludo <at> gnu.org> skribis: > This patch series is to always display upfront what’s going to > happen, even in the presence of “dynamic dependencies” (grafts), > as was reported at: > > https://issues.guix.gnu.org/issue/28310 > > With this patch, any time ‘build-things’ is called, we have an > opportunity to display what’s going to happen and to choose > whether or not to actually build things (dry runs). Pushed with a0f480d623f71b7f0d93de192b86038317dc625b along with related changes. Ludo’.
guix-patches <at> gnu.org
:bug#40130
; Package guix-patches
.
(Sun, 22 Mar 2020 12:45:02 GMT) Full text and rfc822 format available.Message #37 received at 40130-done <at> debbugs.gnu.org (full text, mbox):
From: Ricardo Wurmus <rekado <at> elephly.net> To: Ludovic Courtès <ludo <at> gnu.org> Cc: 40130-done <at> debbugs.gnu.org Subject: Re: bug#40130: [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback Date: Sun, 22 Mar 2020 13:44:13 +0100
Ludovic Courtès <ludo <at> gnu.org> writes: > Ludovic Courtès <ludo <at> gnu.org> skribis: > >> This patch series is to always display upfront what’s going to >> happen, even in the presence of “dynamic dependencies” (grafts), >> as was reported at: >> >> https://issues.guix.gnu.org/issue/28310 >> >> With this patch, any time ‘build-things’ is called, we have an >> opportunity to display what’s going to happen and to choose >> whether or not to actually build things (dry runs). > > Pushed with a0f480d623f71b7f0d93de192b86038317dc625b along with related > changes. Thank you for this improvement that used to be always out of reach! (I don’t fully understand it yet, which is why I couldn’t give any comments sooner, but I’ll try <take the time to study this later.) -- Ricardo
Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org
.
(Mon, 20 Apr 2020 11:24:06 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.