diff options
| -rw-r--r-- | guix/store.scm | 12 | ||||
| -rw-r--r-- | tests/store.scm | 27 |
2 files changed, 34 insertions, 5 deletions
diff --git a/guix/store.scm b/guix/store.scm index ca8c0e5ef8..1dd5c9545b 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -623,14 +623,16 @@ connection. Use with care." (define (call-with-store proc) "Call PROC with an open store connection." (let ((store (open-connection))) - (dynamic-wind - (const #f) + (catch #t (lambda () (parameterize ((current-store-protocol-version (store-connection-version store))) - (proc store))) - (lambda () - (false-if-exception (close-connection store)))))) + (let ((result (proc store))) + (close-connection store) + result))) + (lambda (key . args) + (close-connection store) + (apply throw key args))))) (define-syntax-rule (with-store store exp ...) "Bind STORE to an open connection to the store and evaluate EXPs; diff --git a/tests/store.scm b/tests/store.scm index 0458a34746..0e80ccc239 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -412,6 +412,33 @@ (build-derivations %store (list d2)) '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" (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) (s (add-to-store %store "bash" #t "sha256" |