aboutsummaryrefslogtreecommitdiff
path: root/guix/inferior.scm
diff options
context:
space:
mode:
authorKonrad Hinsen <konrad.hinsen@fastmail.net>2019-11-12 16:39:46 +0100
committerLudovic Courtès <ludo@gnu.org>2019-11-15 23:28:17 +0100
commit1d5485690ba75d6b355fd519caf40881a606678b (patch)
tree5698da3ac822254dd9c273eb751c2cd982ec990a /guix/inferior.scm
parentf675f8dec73d02e319e607559ed2316c299ae8c7 (diff)
downloadguix-1d5485690ba75d6b355fd519caf40881a606678b.tar
guix-1d5485690ba75d6b355fd519caf40881a606678b.tar.gz
inferior: 'cached-channel-instance' takes an open store connection.
* 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>
Diffstat (limited to 'guix/inferior.scm')
-rw-r--r--guix/inferior.scm99
1 files changed, 50 insertions, 49 deletions
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))