futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

store: Add 'with-build-handler'.

Browse Source 
* 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.
This commit is contained in:
Ludovic Courtès 2020-03-18 22:17:39 +01:00
parent 9a067fe7ee
commit 041b340da4
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 94 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.dir-locals.el
View File

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

75
guix/store.scm
View File

@ -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."
(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.

34
tests/store.scm
View File

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