From 8ed597f4a261fe188de82cd1f5daed83dba948eb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 4 Apr 2020 17:36:31 +0200
Subject: store: 'with-store' doesn't close the store upon abort.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

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 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 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"
-- 
cgit v1.2.3