diff --git a/.dir-locals.el b/.dir-locals.el
index 1976f7e60d7413b2a3358eea4a673c81740879ce..ce305602f23ffff5561de4eacd80649cae877994 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 2c3675dca64d77d50f94e14f035b1ea8530eeb5e..fdaae27914c44ba3b37639ed1b0d70d99713cfbf 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 @@ (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."
- (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."
+ (or (not (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 2b14a4af0a970c794505f930f171b42ecd4d0685..b61a981b28e64bdada8407c6893f559fc5532dd8 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 @@ (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)))