From 1d5485690ba75d6b355fd519caf40881a606678b Mon Sep 17 00:00:00 2001
From: Konrad Hinsen <konrad.hinsen@fastmail.net>
Date: Tue, 12 Nov 2019 16:39:46 +0100
Subject: inferior: 'cached-channel-instance' takes an open store connection.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* guix/inferior.scm (cached-channel-instance): Take an explicit 'store'
argument.
(inferior-for-channels): Wrap call to 'cached-channel-instance' in
'with-store'.
* guix/time-machine.scm (guix-time-machine): Wrap call to
'cached-channel-instance' in 'with-store'.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
---
 guix/inferior.scm             | 99 ++++++++++++++++++++++---------------------
 guix/scripts/time-machine.scm |  4 +-
 2 files changed, 53 insertions(+), 50 deletions(-)

(limited to 'guix')

diff --git a/guix/inferior.scm b/guix/inferior.scm
index be50e0ec26..71dae89e92 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -636,58 +636,57 @@ failing when GUIX is too old and lacks the 'guix repl' command."
   (make-parameter (string-append (cache-directory #:ensure? #f)
                                  "/inferiors")))
 
-(define* (cached-channel-instance channels
+(define* (cached-channel-instance store
+                                  channels
                                   #:key
                                   (cache-directory (%inferior-cache-directory))
                                   (ttl (* 3600 24 30)))
   "Return a directory containing a guix filetree defined by CHANNELS, a list of channels.
 The directory is a subdirectory of CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds.
 This procedure opens a new connection to the build daemon."
-  (with-store store
-    (let ()
-      (define instances
-        (latest-channel-instances store channels))
-
-      (define key
-        (bytevector->base32-string
-         (sha256
-          (string->utf8
-           (string-concatenate (map channel-instance-commit instances))))))
-
-      (define cached
-        (string-append cache-directory "/" key))
-
-      (define (base32-encoded-sha256? str)
-        (= (string-length str) 52))
-
-      (define (cache-entries directory)
-        (map (lambda (file)
-               (string-append directory "/" file))
-             (scandir directory base32-encoded-sha256?)))
-
-      (define symlink*
-        (lift2 symlink %store-monad))
-
-      (define add-indirect-root*
-        (store-lift add-indirect-root))
-
-      (mkdir-p cache-directory)
-      (maybe-remove-expired-cache-entries cache-directory
-                                          cache-entries
-                                          #:entry-expiration
-                                          (file-expiration-time ttl))
-
-      (if (file-exists? cached)
-          cached
-          (run-with-store store
-            (mlet %store-monad ((profile
-                                 (channel-instances->derivation instances)))
-              (mbegin %store-monad
-                (show-what-to-build* (list profile))
-                (built-derivations (list profile))
-                (symlink* (derivation->output-path profile) cached)
-                (add-indirect-root* cached)
-                (return cached))))))))
+  (define instances
+    (latest-channel-instances store channels))
+
+  (define key
+    (bytevector->base32-string
+     (sha256
+      (string->utf8
+       (string-concatenate (map channel-instance-commit instances))))))
+
+  (define cached
+    (string-append cache-directory "/" key))
+
+  (define (base32-encoded-sha256? str)
+    (= (string-length str) 52))
+
+  (define (cache-entries directory)
+    (map (lambda (file)
+           (string-append directory "/" file))
+         (scandir directory base32-encoded-sha256?)))
+
+  (define symlink*
+    (lift2 symlink %store-monad))
+
+  (define add-indirect-root*
+    (store-lift add-indirect-root))
+
+  (mkdir-p cache-directory)
+  (maybe-remove-expired-cache-entries cache-directory
+                                      cache-entries
+                                      #:entry-expiration
+                                      (file-expiration-time ttl))
+
+  (if (file-exists? cached)
+      cached
+      (run-with-store store
+        (mlet %store-monad ((profile
+                             (channel-instances->derivation instances)))
+          (mbegin %store-monad
+            (show-what-to-build* (list profile))
+            (built-derivations (list profile))
+            (symlink* (derivation->output-path profile) cached)
+            (add-indirect-root* cached)
+            (return cached))))))
 
 (define* (inferior-for-channels channels
                                 #:key
@@ -700,7 +699,9 @@ procedure opens a new connection to the build daemon.
 This is a convenience procedure that people may use in manifests passed to
 'guix package -m', for instance."
   (define cached
-    (cached-channel-instance channels
-                             #:cache-directory cache-directory
-                             #:ttl ttl))
+    (with-store store
+      (cached-channel-instance store
+                               channels
+                               #:cache-directory cache-directory
+                               #:ttl ttl)))
   (open-inferior cached))
diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm
index a6598fb0f7..a64badc27b 100644
--- a/guix/scripts/time-machine.scm
+++ b/guix/scripts/time-machine.scm
@@ -21,6 +21,7 @@
   #:use-module (guix scripts)
   #:use-module (guix inferior)
   #:use-module (guix channels)
+  #:use-module (guix store)
   #:use-module ((guix scripts pull) #:select (channel-list))
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
@@ -97,6 +98,7 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
            (channels     (channel-list opts))
            (command-line (assoc-ref opts 'exec)))
       (when command-line
-        (let* ((directory  (cached-channel-instance channels))
+        (let* ((directory  (with-store store
+                             (cached-channel-instance store channels)))
                (executable (string-append directory "/bin/guix")))
           (apply execl (cons* executable executable command-line)))))))
-- 
cgit v1.2.3