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>
This commit is contained in:
parent
f675f8dec7
commit
1d5485690b
@ -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 instances
|
||||
(latest-channel-instances store channels))
|
||||
|
||||
(define key
|
||||
(bytevector->base32-string
|
||||
(sha256
|
||||
(string->utf8
|
||||
(string-concatenate (map channel-instance-commit instances))))))
|
||||
(define key
|
||||
(bytevector->base32-string
|
||||
(sha256
|
||||
(string->utf8
|
||||
(string-concatenate (map channel-instance-commit instances))))))
|
||||
|
||||
(define cached
|
||||
(string-append cache-directory "/" key))
|
||||
(define cached
|
||||
(string-append cache-directory "/" key))
|
||||
|
||||
(define (base32-encoded-sha256? str)
|
||||
(= (string-length str) 52))
|
||||
(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 (cache-entries directory)
|
||||
(map (lambda (file)
|
||||
(string-append directory "/" file))
|
||||
(scandir directory base32-encoded-sha256?)))
|
||||
|
||||
(define symlink*
|
||||
(lift2 symlink %store-monad))
|
||||
(define symlink*
|
||||
(lift2 symlink %store-monad))
|
||||
|
||||
(define add-indirect-root*
|
||||
(store-lift add-indirect-root))
|
||||
(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))
|
||||
(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))))))))
|
||||
(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))
|
||||
|
@ -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)))))))
|
||||
|
Loading…
Reference in New Issue
Block a user