ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

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