unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
* [bug#40130] [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback
@ 2020-03-19 10:56 Ludovic Courtès
  2020-03-19 11:02 ` [bug#40130] [PATCH 1/8] syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent Ludovic Courtès
  2020-03-22 11:44 ` bug#40130: [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback Ludovic Courtès
  0 siblings, 2 replies; 11+ messages in thread
From: Ludovic Courtès @ 2020-03-19 10:56 UTC (permalink / raw)
  To: 40130; +Cc: Ludovic Courtès

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

^ permalink raw reply	[flat|nested] 11+ messages in thread

* [bug#40130] [PATCH 1/8] syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent.
  2020-03-19 10:56 [bug#40130] [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback Ludovic Courtès
@ 2020-03-19 11:02 ` Ludovic Courtès
  2020-03-19 11:02   ` [bug#40130] [PATCH 2/8] store: Add 'with-build-handler' Ludovic Courtès
                     ` (6 more replies)
  2020-03-22 11:44 ` bug#40130: [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback Ludovic Courtès
  1 sibling, 7 replies; 11+ messages in thread
From: Ludovic Courtès @ 2020-03-19 11:02 UTC (permalink / raw)
  To: 40130; +Cc: Ludovic Courtès

* 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

^ permalink raw reply related	[flat|nested] 11+ messages in thread

* [bug#40130] [PATCH 2/8] store: Add 'with-build-handler'.
  2020-03-19 11:02 ` [bug#40130] [PATCH 1/8] syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent Ludovic Courtès
@ 2020-03-19 11:02   ` Ludovic Courtès
  2020-03-19 11:02   ` [bug#40130] [PATCH 3/8] ui: Add a notification build handler Ludovic Courtès
                     ` (5 subsequent siblings)
  6 siblings, 0 replies; 11+ messages in thread
From: Ludovic Courtès @ 2020-03-19 11:02 UTC (permalink / raw)
  To: 40130; +Cc: Ludovic Courtès

* 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@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2020 Florian Pelz <pelzflorian@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@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@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

^ permalink raw reply related	[flat|nested] 11+ messages in thread

* [bug#40130] [PATCH 3/8] ui: Add a notification build handler.
  2020-03-19 11:02 ` [bug#40130] [PATCH 1/8] syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent Ludovic Courtès
  2020-03-19 11:02   ` [bug#40130] [PATCH 2/8] store: Add 'with-build-handler' Ludovic Courtès
@ 2020-03-19 11:02   ` Ludovic Courtès
  2020-03-19 11:02   ` [bug#40130] [PATCH 4/8] guix build: Use 'with-build-handler' Ludovic Courtès
                     ` (4 subsequent siblings)
  6 siblings, 0 replies; 11+ messages in thread
From: Ludovic Courtès @ 2020-03-19 11:02 UTC (permalink / raw)
  To: 40130; +Cc: Ludovic Courtès

* 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

^ permalink raw reply related	[flat|nested] 11+ messages in thread

* [bug#40130] [PATCH 4/8] guix build: Use 'with-build-handler'.
  2020-03-19 11:02 ` [bug#40130] [PATCH 1/8] syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent Ludovic Courtès
  2020-03-19 11:02   ` [bug#40130] [PATCH 2/8] store: Add 'with-build-handler' Ludovic Courtès
  2020-03-19 11:02   ` [bug#40130] [PATCH 3/8] ui: Add a notification build handler Ludovic Courtès
@ 2020-03-19 11:02   ` Ludovic Courtès
  2020-03-19 11:02   ` [bug#40130] [PATCH 5/8] deploy: " Ludovic Courtès
                     ` (3 subsequent siblings)
  6 siblings, 0 replies; 11+ messages in thread
From: Ludovic Courtès @ 2020-03-19 11:02 UTC (permalink / raw)
  To: 40130; +Cc: Ludovic Courtès

Fixes <https://bugs.gnu.org/28310>.
Reported by Andreas Enge <andreas@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

^ permalink raw reply related	[flat|nested] 11+ messages in thread

* [bug#40130] [PATCH 5/8] deploy: Use 'with-build-handler'.
  2020-03-19 11:02 ` [bug#40130] [PATCH 1/8] syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent Ludovic Courtès
                     ` (2 preceding siblings ...)
  2020-03-19 11:02   ` [bug#40130] [PATCH 4/8] guix build: Use 'with-build-handler' Ludovic Courtès
@ 2020-03-19 11:02   ` Ludovic Courtès
  2020-03-19 11:02   ` [bug#40130] [PATCH 6/8] pack: " Ludovic Courtès
                     ` (2 subsequent siblings)
  6 siblings, 0 replies; 11+ messages in thread
From: Ludovic Courtès @ 2020-03-19 11:02 UTC (permalink / raw)
  To: 40130; +Cc: Ludovic Courtès

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

^ permalink raw reply related	[flat|nested] 11+ messages in thread

* [bug#40130] [PATCH 6/8] pack: Use 'with-build-handler'.
  2020-03-19 11:02 ` [bug#40130] [PATCH 1/8] syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent Ludovic Courtès
                     ` (3 preceding siblings ...)
  2020-03-19 11:02   ` [bug#40130] [PATCH 5/8] deploy: " Ludovic Courtès
@ 2020-03-19 11:02   ` Ludovic Courtès
  2020-03-19 11:02   ` [bug#40130] [PATCH 7/8] guix package, pull: " Ludovic Courtès
  2020-03-19 11:02   ` [bug#40130] [PATCH 8/8] guix system: " Ludovic Courtès
  6 siblings, 0 replies; 11+ messages in thread
From: Ludovic Courtès @ 2020-03-19 11:02 UTC (permalink / raw)
  To: 40130; +Cc: Ludovic Courtès

* 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

^ permalink raw reply related	[flat|nested] 11+ messages in thread

* [bug#40130] [PATCH 7/8] guix package, pull: Use 'with-build-handler'.
  2020-03-19 11:02 ` [bug#40130] [PATCH 1/8] syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent Ludovic Courtès
                     ` (4 preceding siblings ...)
  2020-03-19 11:02   ` [bug#40130] [PATCH 6/8] pack: " Ludovic Courtès
@ 2020-03-19 11:02   ` Ludovic Courtès
  2020-03-19 11:02   ` [bug#40130] [PATCH 8/8] guix system: " Ludovic Courtès
  6 siblings, 0 replies; 11+ messages in thread
From: Ludovic Courtès @ 2020-03-19 11:02 UTC (permalink / raw)
  To: 40130; +Cc: Ludovic Courtès

* 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?)))))
 
 \f
 ;;;
@@ -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

^ permalink raw reply related	[flat|nested] 11+ messages in thread

* [bug#40130] [PATCH 8/8] guix system: Use 'with-build-handler'.
  2020-03-19 11:02 ` [bug#40130] [PATCH 1/8] syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent Ludovic Courtès
                     ` (5 preceding siblings ...)
  2020-03-19 11:02   ` [bug#40130] [PATCH 7/8] guix package, pull: " Ludovic Courtès
@ 2020-03-19 11:02   ` Ludovic Courtès
  6 siblings, 0 replies; 11+ messages in thread
From: Ludovic Courtès @ 2020-03-19 11:02 UTC (permalink / raw)
  To: 40130; +Cc: Ludovic Courtès

* 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@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@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

^ permalink raw reply related	[flat|nested] 11+ messages in thread

* bug#40130: [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback
  2020-03-19 10:56 [bug#40130] [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback Ludovic Courtès
  2020-03-19 11:02 ` [bug#40130] [PATCH 1/8] syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent Ludovic Courtès
@ 2020-03-22 11:44 ` Ludovic Courtès
  2020-03-22 12:44   ` [bug#40130] " Ricardo Wurmus
  1 sibling, 1 reply; 11+ messages in thread
From: Ludovic Courtès @ 2020-03-22 11:44 UTC (permalink / raw)
  To: 40130-done

Ludovic Courtès <ludo@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’.

^ permalink raw reply	[flat|nested] 11+ messages in thread

* [bug#40130] [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback
  2020-03-22 11:44 ` bug#40130: [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback Ludovic Courtès
@ 2020-03-22 12:44   ` Ricardo Wurmus
  0 siblings, 0 replies; 11+ messages in thread
From: Ricardo Wurmus @ 2020-03-22 12:44 UTC (permalink / raw)
  To: Ludovic Courtès; +Cc: 40130-done


Ludovic Courtès <ludo@gnu.org> writes:

> Ludovic Courtès <ludo@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

^ permalink raw reply	[flat|nested] 11+ messages in thread

end of thread, other threads:[~2020-03-22 12:45 UTC | newest]

Thread overview: 11+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2020-03-19 10:56 [bug#40130] [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback Ludovic Courtès
2020-03-19 11:02 ` [bug#40130] [PATCH 1/8] syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent Ludovic Courtès
2020-03-19 11:02   ` [bug#40130] [PATCH 2/8] store: Add 'with-build-handler' Ludovic Courtès
2020-03-19 11:02   ` [bug#40130] [PATCH 3/8] ui: Add a notification build handler Ludovic Courtès
2020-03-19 11:02   ` [bug#40130] [PATCH 4/8] guix build: Use 'with-build-handler' Ludovic Courtès
2020-03-19 11:02   ` [bug#40130] [PATCH 5/8] deploy: " Ludovic Courtès
2020-03-19 11:02   ` [bug#40130] [PATCH 6/8] pack: " Ludovic Courtès
2020-03-19 11:02   ` [bug#40130] [PATCH 7/8] guix package, pull: " Ludovic Courtès
2020-03-19 11:02   ` [bug#40130] [PATCH 8/8] guix system: " Ludovic Courtès
2020-03-22 11:44 ` bug#40130: [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback Ludovic Courtès
2020-03-22 12:44   ` [bug#40130] " Ricardo Wurmus

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).