From 94c0e61fe759924625c9e27d3da8c7c0c767ea2b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 26 Nov 2018 11:48:33 +0100
Subject: 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.
---
 guix/inferior.scm | 70 ++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 43 insertions(+), 27 deletions(-)

(limited to 'guix/inferior.scm')

diff --git a/guix/inferior.scm b/guix/inferior.scm
index 1dbb9e1699..ccc1c27cb2 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))
-- 
cgit v1.2.3