inferior: Add 'inferior-eval-with-store'.

* guix/inferior.scm (inferior-eval-with-store): New procedure, with code
formerly in 'inferior-package-derivation'.
(inferior-package-derivation): Rewrite in terms of
'inferior-eval-with-store'.
* tests/inferior.scm ("inferior-eval-with-store"): New test.

2 files changed, 52 insertions, 27 deletions

diff --git a/guix/inferior.scm b/guix/inferior.scm
index 1dbb9e16992..ccc1c27cb26 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -56,6 +56,7 @@
             open-inferior
             close-inferior
             inferior-eval
+            inferior-eval-with-store
             inferior-object?
 
             inferior-packages
@@ -402,55 +403,70 @@ input/output ports.)"
        (unless (port-closed? client)
          (loop))))))
 
-(define* (inferior-package-derivation store package
-                                      #:optional
-                                      (system (%current-system))
-                                      #:key target)
-  "Return the derivation for PACKAGE, an inferior package, built for SYSTEM
-and cross-built for TARGET if TARGET is true.  The inferior corresponding to
-PACKAGE must be live."
-  ;; Create a named socket in /tmp and let the inferior of PACKAGE connect to
-  ;; it and use it as its store.  This ensures the inferior uses the same
-  ;; store, with the same options, the same per-session GC roots, etc.
+(define (inferior-eval-with-store inferior store code)
+  "Evaluate CODE in INFERIOR, passing it STORE as its argument.  CODE must
+thus be the code of a one-argument procedure that accepts a store."
+  ;; Create a named socket in /tmp and let INFERIOR connect to it and use it
+  ;; as its store.  This ensures the inferior uses the same store, with the
+  ;; same options, the same per-session GC roots, etc.
   (call-with-temporary-directory
    (lambda (directory)
      (chmod directory #o700)
      (let* ((name     (string-append directory "/inferior"))
             (socket   (socket AF_UNIX SOCK_STREAM 0))
-            (inferior (inferior-package-inferior package))
             (major    (nix-server-major-version store))
             (minor    (nix-server-minor-version store))
             (proto    (logior major minor)))
        (bind socket AF_UNIX name)
        (listen socket 1024)
        (send-inferior-request
-        `(let ((socket (socket AF_UNIX SOCK_STREAM 0)))
+        `(let ((proc   ,code)
+               (socket (socket AF_UNIX SOCK_STREAM 0)))
            (connect socket AF_UNIX ,name)
 
            ;; 'port->connection' appeared in June 2018 and we can hardly
            ;; emulate it on older versions.  Thus fall back to
            ;; 'open-connection', at the risk of talking to the wrong daemon or
            ;; having our build result reclaimed (XXX).
-           (let* ((store   (if (defined? 'port->connection)
-                               (port->connection socket #:version ,proto)
-                               (open-connection)))
-                  (package (hashv-ref %package-table
-                                      ,(inferior-package-id package)))
-                  (drv     ,(if target
-                                `(package-cross-derivation store package
-                                                           ,target
-                                                           ,system)
-                                `(package-derivation store package
-                                                     ,system))))
-             (close-connection store)
-             (close-port socket)
-             (derivation-file-name drv)))
+           (let ((store (if (defined? 'port->connection)
+                            (port->connection socket #:version ,proto)
+                            (open-connection))))
+             (dynamic-wind
+               (const #t)
+               (lambda ()
+                 (proc store))
+               (lambda ()
+                 (close-connection store)
+                 (close-port socket)))))
         inferior)
        (match (accept socket)
          ((client . address)
           (proxy client (nix-server-socket store))))
        (close-port socket)
-       (read-derivation-from-file (read-inferior-response inferior))))))
+       (read-inferior-response inferior)))))
+
+(define* (inferior-package-derivation store package
+                                      #:optional
+                                      (system (%current-system))
+                                      #:key target)
+  "Return the derivation for PACKAGE, an inferior package, built for SYSTEM
+and cross-built for TARGET if TARGET is true.  The inferior corresponding to
+PACKAGE must be live."
+  (define proc
+    `(lambda (store)
+       (let* ((package (hashv-ref %package-table
+                                  ,(inferior-package-id package)))
+              (drv     ,(if target
+                            `(package-cross-derivation store package
+                                                       ,target
+                                                       ,system)
+                            `(package-derivation store package
+                                                 ,system))))
+         (derivation-file-name drv))))
+
+  (and=> (inferior-eval-with-store (inferior-package-inferior package) store
+                                   proc)
+         read-derivation-from-file))
 
 (define inferior-package->derivation
   (store-lift inferior-package-derivation))
diff --git a/tests/inferior.scm b/tests/inferior.scm
index d1d5c00a773..d5a894ca8ff 100644
--- a/tests/inferior.scm
+++ b/tests/inferior.scm
@@ -157,6 +157,15 @@
     (close-inferior inferior)
     result))
 
+(test-equal "inferior-eval-with-store"
+  (add-text-to-store %store "foo" "Hello, world!")
+  (let* ((inferior (open-inferior %top-builddir
+                                  #:command "scripts/guix")))
+    (inferior-eval-with-store inferior %store
+                              '(lambda (store)
+                                 (add-text-to-store store "foo"
+                                                    "Hello, world!")))))
+
 (test-equal "inferior-package-derivation"
   (map derivation-file-name
        (list (package-derivation %store %bootstrap-guile "x86_64-linux")