GNU bug report logs - #40130
[PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback

Previous Next

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


Report forwarded to guix-patches <at> gnu.org:
bug#40130; Package guix-patches. (Thu, 19 Mar 2020 10:57:02 GMT) Full text and rfc822 format available.

Acknowledgement sent to Ludovic Courtès <ludo <at> gnu.org>:
New bug report received and forwarded. Copy sent to 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





Information forwarded to 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





Information forwarded to 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





Information forwarded to 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





Information forwarded to 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





Information forwarded to 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





Information forwarded to 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





Information forwarded to 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





Information forwarded to 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





Reply sent to Ludovic Courtès <ludo <at> gnu.org>:
You have taken responsibility. (Sun, 22 Mar 2020 11:45:02 GMT) Full text and rfc822 format available.

Notification sent to Ludovic Courtès <ludo <at> gnu.org>:
bug acknowledged by developer. (Sun, 22 Mar 2020 11:45:02 GMT) Full text and rfc822 format available.

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’.




Information forwarded to 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




bug archived. Request was from 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.

This bug report was last modified 4 years and 1 day ago.

Previous Next


GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.