mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
store: 'with-store' doesn't close the store upon abort.
Fixes <https://bugs.gnu.org/40428>.
Reported by Marius Bakke <mbakke@fastmail.com> and 白い熊.
Regression introduced with the first uses of 'with-build-handler' in
commit 62195b9a8f
and subsequent.
* guix/store.scm (call-with-store): Use 'catch #t' instead of
'dynamic-wind'. This ensures STORE remains open when a non-local exit
other than an exception occurs, such as an abort to the build handler
prompt.
* tests/store.scm ("with-build-handler + with-store"): New test.
This commit is contained in:
parent
d8c8bfcc1f
commit
8ed597f4a2
2 changed files with 34 additions and 5 deletions
|
@ -623,14 +623,16 @@ (define (close-connection server)
|
||||||
(define (call-with-store proc)
|
(define (call-with-store proc)
|
||||||
"Call PROC with an open store connection."
|
"Call PROC with an open store connection."
|
||||||
(let ((store (open-connection)))
|
(let ((store (open-connection)))
|
||||||
(dynamic-wind
|
(catch #t
|
||||||
(const #f)
|
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(parameterize ((current-store-protocol-version
|
(parameterize ((current-store-protocol-version
|
||||||
(store-connection-version store)))
|
(store-connection-version store)))
|
||||||
(proc store)))
|
(let ((result (proc store)))
|
||||||
(lambda ()
|
(close-connection store)
|
||||||
(false-if-exception (close-connection store))))))
|
result)))
|
||||||
|
(lambda (key . args)
|
||||||
|
(close-connection store)
|
||||||
|
(apply throw key args)))))
|
||||||
|
|
||||||
(define-syntax-rule (with-store store exp ...)
|
(define-syntax-rule (with-store store exp ...)
|
||||||
"Bind STORE to an open connection to the store and evaluate EXPs;
|
"Bind STORE to an open connection to the store and evaluate EXPs;
|
||||||
|
|
|
@ -412,6 +412,33 @@ (define (same? x y)
|
||||||
(build-derivations %store (list d2))
|
(build-derivations %store (list d2))
|
||||||
'fail)))
|
'fail)))
|
||||||
|
|
||||||
|
(test-equal "with-build-handler + with-store"
|
||||||
|
'success
|
||||||
|
;; Check that STORE remains valid when the build handler invokes CONTINUE,
|
||||||
|
;; even though 'with-build-handler' is outside the dynamic extent of
|
||||||
|
;; 'with-store'.
|
||||||
|
(with-build-handler (lambda (continue store things mode)
|
||||||
|
(match things
|
||||||
|
((drv)
|
||||||
|
(and (string-suffix? "thingie.drv" drv)
|
||||||
|
(not (port-closed?
|
||||||
|
(store-connection-socket store)))
|
||||||
|
(continue #t)))))
|
||||||
|
(with-store store
|
||||||
|
(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))))
|
||||||
|
(d (derivation store "thingie"
|
||||||
|
s `("-e" ,b)
|
||||||
|
#:env-vars `(("foo" . ,(random-text)))
|
||||||
|
#:sources (list b s))))
|
||||||
|
(build-derivations store (list d))
|
||||||
|
|
||||||
|
;; Here STORE's socket should still be open.
|
||||||
|
(and (valid-path? store (derivation->output-path d))
|
||||||
|
'success)))))
|
||||||
|
|
||||||
(test-assert "map/accumulate-builds"
|
(test-assert "map/accumulate-builds"
|
||||||
(let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
|
(let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
|
||||||
(s (add-to-store %store "bash" #t "sha256"
|
(s (add-to-store %store "bash" #t "sha256"
|
||||||
|
|
Loading…
Reference in a new issue