store: Add 'with-build-handler'.

* 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

@@ -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))

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 @@ (define-module (guix store)
             add-to-store
             add-file-tree-to-store
             binary-file
+            with-build-handler
             build-things
             build
             query-failed-paths
@@ -1222,6 +1223,46 @@ (define cache
             (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 @@ (define build-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."
+the derivation.  Return #t on success.
-      (let ((things (map (match-lambda
+
-                           ((drv . output) (string-append drv "!" output))
+When a handler is installed with 'with-build-handler', it is called any time
-                           (thing thing))
+'build-things' is called."
-                         things)))
+      (or (not (invoke-build-handler store things mode))
-        (parameterize ((current-store-protocol-version
+          (let ((things (map (match-lambda
-                        (store-connection-version store)))
+                               ((drv . output) (string-append drv "!" output))
-          (if (>= (store-connection-minor-version store) 15)
+                               (thing thing))
-              (build store things mode)
+                             things)))
-              (if (= mode (build-mode normal))
+            (parameterize ((current-store-protocol-version
-                  (build/old store things)
+                            (store-connection-version store)))
-                  (raise (condition (&store-protocol-error
+              (if (>= (store-connection-minor-version store) 15)
-                                     (message "unsupported build mode")
+                  (build store things mode)
-                                     (status  1)))))))))))
+                  (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.

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 @@ (define (same? x y)
          (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)))