From 2015d3f042870860efef10e801b93eacc0742d38 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 28 Oct 2021 19:21:50 +0200
Subject: store: 'map/accumulate-builds' handler checks the store received.

This is a followup to b19250eec6f92308f237a09a43e8e3e2355345b9,
providing a proper fix for <https://issues.guix.gnu.org/46756>.

* guix/remote.scm (remote-eval): Revert b19250eec6f92308f237a09a43e8e3e2355345b9.
* guix/store.scm (build-accumulator): Turn into a procedure.  Call
CONTINUE when the store is not eq? to the initial store.
(map/accumulate-builds): Adjust accordingly.
* tests/store.scm ("map/accumulate-builds and different store"): New test.
---
 guix/remote.scm | 11 +----------
 guix/store.scm  | 18 ++++++++++++------
 tests/store.scm | 28 ++++++++++++++++++++++++++++
 3 files changed, 41 insertions(+), 16 deletions(-)

diff --git a/guix/remote.scm b/guix/remote.scm
index 37e9827084..f6adb22846 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -146,15 +146,6 @@ (define sources
                                sources)))
           (mbegin %store-monad
             ((store-lift send-files) to-send remote #:recursive? #t)
-
-            ;; Build handlers are not tied to a specific <store-connection>.
-            ;; If a handler is already installed, it might want to go ahead
-            ;; and build, but on the local <store-connection> instead of
-            ;; REMOTE.  To avoid that, install a build handler that does
-            ;; nothing.
-            (return (with-build-handler (lambda (continue . _)
-                                          (continue #t))
-                      (build-derivations remote inputs)))
-
+            (return (build-derivations remote inputs))
             (return (close-connection remote))
             (return (%remote-eval lowered session become-command)))))))
diff --git a/guix/store.scm b/guix/store.scm
index 89a719bcfc..7388953d15 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1349,11 +1349,14 @@ (define-record-type <unresolved>
   (things       unresolved-things)
   (continuation unresolved-continuation))
 
-(define (build-accumulator continue store things mode)
-  "This build handler accumulates THINGS and returns an <unresolved> object."
-  (if (= mode (build-mode normal))
-      (unresolved things continue)
-      (continue #t)))
+(define (build-accumulator expected-store)
+  "Return a build handler that accumulates THINGS and returns an <unresolved>
+object, only for build requests on EXPECTED-STORE."
+  (lambda (continue store things mode)
+    (if (and (eq? store expected-store)
+             (= mode (build-mode normal)))
+        (unresolved things continue)
+        (continue #t))))
 
 (define* (map/accumulate-builds store proc lst
                                 #:key (cutoff 30))
@@ -1366,13 +1369,16 @@ (define* (map/accumulate-builds store proc lst
   ;; stumbling upon the same .drv build requests with many incoming edges.
   ;; See <https://bugs.gnu.org/49439>.
 
+  (define accumulator
+    (build-accumulator store))
+
   (define-values (result rest)
     (let loop ((lst lst)
                (result '())
                (unresolved 0))
       (match lst
         ((head . tail)
-         (match (with-build-handler build-accumulator
+         (match (with-build-handler accumulator
                   (proc head))
            ((? unresolved? obj)
             (if (>= unresolved cutoff)
diff --git a/tests/store.scm b/tests/store.scm
index 95f47c3af3..2150a0048c 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -490,6 +490,34 @@ (define lst
             (equal? (map derivation-file-name (drop d 16)) batch3)
             lst)))))
 
+(test-equal "map/accumulate-builds and different store"
+  '(d2)                               ;see <https://issues.guix.gnu.org/46756>
+  (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 "first"
+                         s `("-e" ,b)
+                         #:env-vars `(("foo" . ,(random-text)))
+                         #:sources (list b s)))
+         (d2 (derivation %store "second"
+                         s `("-e" ,b)
+                         #:env-vars `(("foo" . ,(random-text))
+                                      ("bar" . "baz"))
+                         #:sources (list b s))))
+    (with-store alternate-store
+      (with-build-handler (lambda (continue store things mode)
+                            ;; If this handler is called, it means that
+                            ;; 'map/accumulate-builds' triggered a build,
+                            ;; which it shouldn't since the inner
+                            ;; 'build-derivations' call is for another store.
+                            'failed)
+        (map/accumulate-builds %store
+                               (lambda (drv)
+                                 (build-derivations alternate-store (list d2))
+                                 'd2)
+                               (list d1))))))
+
 (test-assert "mapm/accumulate-builds"
   (let* ((d1 (run-with-store %store
                (gexp->derivation "foo" #~(mkdir #$output))))
-- 
cgit v1.2.3