瀏覽代碼

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.
gn-latest-20200428
Ludovic Courtès 6 月之前
父節點
當前提交
041b340da4
沒有發現已知的金鑰在資料庫的簽署中 GPG Key ID: 90B11993D9AEBB5
共有 3 個文件被更改,包括 94 次插入16 次删除
  1. +1
    -0
      .dir-locals.el
  2. +60
    -15
      guix/store.scm
  3. +33
    -1
      tests/store.scm

+ 1
- 0
.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))


+ 60
- 15
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."
(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.


+ 33
- 1
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)))


Loading…
取消
儲存