[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/03: store: 'with-store' doesn't close the store upon abort.
From: |
guix-commits |
Subject: |
02/03: store: 'with-store' doesn't close the store upon abort. |
Date: |
Sat, 4 Apr 2020 12:52:53 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit 8ed597f4a261fe188de82cd1f5daed83dba948eb
Author: Ludovic Courtès <address@hidden>
AuthorDate: Sat Apr 4 17:36:31 2020 +0200
store: 'with-store' doesn't close the store upon abort.
Fixes <https://bugs.gnu.org/40428>.
Reported by Marius Bakke <address@hidden> and 白い熊.
Regression introduced with the first uses of 'with-build-handler' in
commit 62195b9a8fd6846117c5d7698842748300d13e31 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.
---
guix/store.scm | 12 +++++++-----
tests/store.scm | 27 +++++++++++++++++++++++++++
2 files changed, 34 insertions(+), 5 deletions(-)
diff --git a/guix/store.scm b/guix/store.scm
index ca8c0e5..1dd5c95 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 0458a34..0e80ccc 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"