;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (guix inferior)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module ((guix diagnostics)
+ #:select (source-properties->location))
#:use-module ((guix utils)
#:select (%current-system
- source-properties->location
call-with-temporary-directory
- version>? version-prefix?))
+ version>? version-prefix?
+ cache-directory))
#:use-module ((guix store)
- #:select (nix-server-socket
- nix-server-major-version
- nix-server-minor-version
- store-lift))
+ #:select (store-connection-socket
+ store-connection-major-version
+ store-connection-minor-version
+ store-lift
+ &store-protocol-error))
#:use-module ((guix derivations)
#:select (read-derivation-from-file))
#:use-module (guix gexp)
+ #:use-module (guix search-paths)
+ #:use-module (guix profiles)
+ #:use-module (guix channels)
+ #:use-module ((guix git) #:select (update-cached-checkout))
+ #:use-module (guix monads)
+ #:use-module (guix store)
+ #:use-module (guix derivations)
+ #:use-module (guix base32)
+ #:use-module (gcrypt hash)
+ #:autoload (guix cache) (maybe-remove-expired-cache-entries
+ file-expiration-time)
+ #:autoload (guix ui) (show-what-to-build*)
+ #:autoload (guix build utils) (mkdir-p)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-71)
+ #:autoload (ice-9 ftw) (scandir)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 vlist)
#:use-module (ice-9 binary-ports)
+ #:use-module ((rnrs bytevectors) #:select (string->utf8))
#:export (inferior?
open-inferior
+ port->inferior
close-inferior
inferior-eval
+ inferior-eval-with-store
inferior-object?
+ inferior-exception?
+ inferior-exception-arguments
+ inferior-exception-inferior
+ inferior-exception-stack
+ read-repl-response
+
+ inferior-packages
+ inferior-available-packages
+ lookup-inferior-packages
inferior-package?
inferior-package-name
inferior-package-version
-
- inferior-packages
- lookup-inferior-packages
inferior-package-synopsis
inferior-package-description
inferior-package-home-page
inferior-package-location
- inferior-package-derivation))
+ inferior-package-inputs
+ inferior-package-native-inputs
+ inferior-package-propagated-inputs
+ inferior-package-transitive-propagated-inputs
+ inferior-package-native-search-paths
+ inferior-package-transitive-native-search-paths
+ inferior-package-search-paths
+ inferior-package-provenance
+ inferior-package-derivation
+
+ inferior-package->manifest-entry
+
+ gexp->derivation-in-inferior
+
+ %inferior-cache-directory
+ cached-channel-instance
+ inferior-for-channels))
;;; Commentary:
;;;
;; Inferior Guix process.
(define-record-type <inferior>
- (inferior pid socket version packages table)
+ (inferior pid socket close version packages table)
inferior?
(pid inferior-pid)
(socket inferior-socket)
+ (close inferior-close-socket) ;procedure
(version inferior-version) ;REPL protocol version
(packages inferior-package-promise) ;promise of inferior packages
(table inferior-package-table)) ;promise of vhash
-(define (inferior-pipe directory command)
+(define (write-inferior inferior port)
+ (match inferior
+ (($ <inferior> pid _ _ version)
+ (format port "#<inferior ~a ~a ~a>"
+ pid version
+ (number->string (object-address inferior) 16)))))
+
+(set-record-type-printer! <inferior> write-inferior)
+
+(define* (inferior-pipe directory command error-port)
"Return an input/output pipe on the Guix instance in DIRECTORY. This runs
'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if
it's an old Guix."
- (let ((pipe (with-error-to-port (%make-void-port "w")
+ (let ((pipe (with-error-to-port error-port
(lambda ()
(open-pipe* OPEN_BOTH
(string-append directory "/" command)
;; Older versions of Guix didn't have a 'guix repl' command, so
;; emulate it.
- (open-pipe* OPEN_BOTH "guile"
- "-L" (string-append directory "/share/guile/site/"
- (effective-version))
- "-C" (string-append directory "/share/guile/site/"
- (effective-version))
- "-C" (string-append directory "/lib/guile/"
- (effective-version) "/site-ccache")
- "-c"
- (object->string
- `(begin
- (primitive-load ,(search-path %load-path
- "guix/scripts/repl.scm"))
- ((@ (guix scripts repl) machine-repl))))))
+ (with-error-to-port error-port
+ (lambda ()
+ (open-pipe* OPEN_BOTH "guile"
+ "-L" (string-append directory "/share/guile/site/"
+ (effective-version))
+ "-C" (string-append directory "/share/guile/site/"
+ (effective-version))
+ "-C" (string-append directory "/lib/guile/"
+ (effective-version) "/site-ccache")
+ "-c"
+ (object->string
+ `(begin
+ (primitive-load ,(search-path %load-path
+ "guix/repl.scm"))
+ ((@ (guix repl) machine-repl))))))))
pipe)))
-(define* (open-inferior directory #:key (command "bin/guix"))
- "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or
-equivalent. Return #f if the inferior could not be launched."
- (define pipe
- (inferior-pipe directory command))
-
- (cond-expand
- ((and guile-2 (not guile-2.2)) #t)
- (else (setvbuf pipe 'line)))
+(define* (port->inferior pipe #:optional (close close-port))
+ "Given PIPE, an input/output port, return an inferior that talks over PIPE.
+PIPE is closed with CLOSE when 'close-inferior' is called on the returned
+inferior."
+ (setvbuf pipe 'line)
(match (read pipe)
(('repl-version 0 rest ...)
- (letrec ((result (inferior 'pipe pipe (cons 0 rest)
+ (letrec ((result (inferior 'pipe pipe close (cons 0 rest)
(delay (%inferior-packages result))
(delay (%inferior-package-table result)))))
+
+ ;; For protocol (0 1) and later, send the protocol version we support.
+ (match rest
+ ((n _ ...)
+ (when (>= n 1)
+ (send-inferior-request '(() repl-version 0 1 1) result)))
+ (_
+ #t))
+
(inferior-eval '(use-modules (guix)) result)
(inferior-eval '(use-modules (gnu)) result)
+ (inferior-eval '(use-modules (ice-9 match)) result)
+ (inferior-eval '(use-modules (srfi srfi-34)) result)
(inferior-eval '(define %package-table (make-hash-table))
result)
result))
(_
#f)))
+(define* (open-inferior directory
+ #:key (command "bin/guix")
+ (error-port (%make-void-port "w")))
+ "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or
+equivalent. Return #f if the inferior could not be launched."
+ (define pipe
+ (inferior-pipe directory command error-port))
+
+ (port->inferior pipe close-pipe))
+
(define (close-inferior inferior)
"Close INFERIOR."
- (close-pipe (inferior-socket inferior)))
+ (let ((close (inferior-close-socket inferior)))
+ (close (inferior-socket inferior))))
;; Non-self-quoting object of the inferior.
(define-record-type <inferior-object>
(set-record-type-printer! <inferior-object> write-inferior-object)
-(define (read-inferior-response inferior)
+;; Reified exception thrown by an inferior.
+(define-condition-type &inferior-exception &error
+ inferior-exception?
+ (arguments inferior-exception-arguments) ;key + arguments
+ (inferior inferior-exception-inferior) ;<inferior> | #f
+ (stack inferior-exception-stack)) ;list of (FILE COLUMN LINE)
+
+(define* (read-repl-response port #:optional inferior)
+ "Read a (guix repl) response from PORT and return it as a Scheme object.
+Raise '&inferior-exception' when an exception is read from PORT."
(define sexp->object
(match-lambda
(('value value)
(('non-self-quoting address string)
(inferior-object address string))))
- (match (read (inferior-socket inferior))
+ (match (read port)
(('values objects ...)
(apply values (map sexp->object objects)))
+ (('exception ('arguments key objects ...)
+ ('stack frames ...))
+ ;; Protocol (0 1 1) and later.
+ (raise (condition (&inferior-exception
+ (arguments (cons key (map sexp->object objects)))
+ (inferior inferior)
+ (stack frames)))))
(('exception key objects ...)
- (apply throw key (map sexp->object objects)))))
+ ;; Protocol (0 0).
+ (raise (condition (&inferior-exception
+ (arguments (cons key (map sexp->object objects)))
+ (inferior inferior)
+ (stack '())))))))
+
+(define (read-inferior-response inferior)
+ (read-repl-response (inferior-socket inferior)
+ inferior))
(define (send-inferior-request exp inferior)
(write exp (inferior-socket inferior))
vlist-null
(inferior-packages inferior)))
+(define (inferior-available-packages inferior)
+ "Return the list of name/version pairs corresponding to the set of packages
+available in INFERIOR.
+
+This is faster and less resource-intensive than calling 'inferior-packages'."
+ (if (inferior-eval '(defined? 'fold-available-packages)
+ inferior)
+ (inferior-eval '(fold-available-packages
+ (lambda* (name version result
+ #:key supported? deprecated?
+ #:allow-other-keys)
+ (if (and supported? (not deprecated?))
+ (acons name version result)
+ result))
+ '())
+ inferior)
+
+ ;; As a last resort, if INFERIOR is old and lacks
+ ;; 'fold-available-packages', fall back to 'inferior-packages'.
+ (map (lambda (package)
+ (cons (inferior-package-name package)
+ (inferior-package-version package)))
+ (inferior-packages inferior))))
+
(define* (lookup-inferior-packages inferior name #:optional version)
"Return the sorted list of inferior packages matching NAME in INFERIOR, with
highest version numbers first. If VERSION is true, return only packages with
loc)))
package-location))))
+(define (inferior-package-input-field package field)
+ "Return the input field FIELD (e.g., 'native-inputs') of PACKAGE, an
+inferior package."
+ (define field*
+ `(compose (lambda (inputs)
+ (map (match-lambda
+ ;; XXX: Origins are not handled.
+ ((label (? package? package) rest ...)
+ (let ((id (object-address package)))
+ (hashv-set! %package-table id package)
+ `(,label (package ,id
+ ,(package-name package)
+ ,(package-version package))
+ ,@rest)))
+ (x
+ x))
+ inputs))
+ ,field))
+
+ (define inputs
+ (inferior-package-field package field*))
+
+ (define inferior
+ (inferior-package-inferior package))
+
+ (map (match-lambda
+ ((label ('package id name version) . rest)
+ ;; XXX: eq?-ness of inferior packages is not preserved here.
+ `(,label ,(inferior-package inferior name version id)
+ ,@rest))
+ (x x))
+ inputs))
+
+(define inferior-package-inputs
+ (cut inferior-package-input-field <> 'package-inputs))
+
+(define inferior-package-native-inputs
+ (cut inferior-package-input-field <> 'package-native-inputs))
+
+(define inferior-package-propagated-inputs
+ (cut inferior-package-input-field <> 'package-propagated-inputs))
+
+(define inferior-package-transitive-propagated-inputs
+ (cut inferior-package-input-field <> 'package-transitive-propagated-inputs))
+
+(define (%inferior-package-search-paths package field)
+ "Return the list of search path specifications of PACKAGE, an inferior
+package."
+ (define paths
+ (inferior-package-field package
+ `(compose (lambda (paths)
+ (map (@ (guix search-paths)
+ search-path-specification->sexp)
+ paths))
+ ,field)))
+
+ (map sexp->search-path-specification paths))
+
+(define inferior-package-native-search-paths
+ (cut %inferior-package-search-paths <> 'package-native-search-paths))
+
+(define inferior-package-search-paths
+ (cut %inferior-package-search-paths <> 'package-search-paths))
+
+(define inferior-package-transitive-native-search-paths
+ (cut %inferior-package-search-paths <> 'package-transitive-native-search-paths))
+
+(define (inferior-package-provenance package)
+ "Return a \"provenance sexp\" for PACKAGE, an inferior package. The result
+is similar to the sexp returned by 'package-provenance' for regular packages."
+ (inferior-package-field package
+ '(let* ((describe
+ (false-if-exception
+ (resolve-interface '(guix describe))))
+ (provenance
+ (false-if-exception
+ (module-ref describe
+ 'package-provenance))))
+ (or provenance (const #f)))))
+
(define (proxy client backend) ;adapted from (guix ssh)
"Proxy communication between CLIENT and BACKEND until CLIENT closes the
connection, at which point CLIENT is closed (both CLIENT and BACKEND must be
input/output ports.)"
- (define (select* read write except)
- ;; This is a workaround for <https://bugs.gnu.org/30365> in Guile < 2.2.4:
- ;; since 'select' sometimes returns non-empty sets for no good reason,
- ;; call 'select' a second time with a zero timeout to filter out incorrect
- ;; replies.
- (match (select read write except)
- ((read write except)
- (select read write except 0))))
-
;; Use buffered ports so that 'get-bytevector-some' returns up to the
;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>.
- (setvbuf client _IOFBF 65536)
- (setvbuf backend _IOFBF 65536)
+ (setvbuf client 'block 65536)
+ (setvbuf backend 'block 65536)
(let loop ()
- (match (select* (list client backend) '() '())
+ (match (select (list client backend) '() '())
((reads () ())
(when (memq client reads)
(match (get-bytevector-some client)
(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.
+ ;; FIXME: This strategy doesn't work for remote inferiors (SSH).
(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))
+ (major (store-connection-major-version store))
+ (minor (store-connection-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))
+ (error? (if (defined? 'store-protocol-error?)
+ store-protocol-error?
+ nix-protocol-error?))
+ (error-message (if (defined? 'store-protocol-error-message)
+ store-protocol-error-message
+ nix-protocol-error-message)))
(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 ()
+ ;; Serialize '&store-protocol-error' conditions. The
+ ;; exception serialization mechanism that
+ ;; 'read-repl-response' expects is unsuitable for SRFI-35
+ ;; error conditions, hence this special case.
+ (guard (c ((error? c)
+ `(store-protocol-error ,(error-message c))))
+ `(result ,(proc store))))
+ (lambda ()
+ (close-connection store)
+ (close-port socket)))))
inferior)
(match (accept socket)
((client . address)
- (proxy client (nix-server-socket store))))
+ (proxy client (store-connection-socket store))))
(close-port socket)
- (read-derivation-from-file (read-inferior-response inferior))))))
+
+ (match (read-inferior-response inferior)
+ (('store-protocol-error message)
+ (raise (condition
+ (&store-protocol-error (message message)
+ (status 1)))))
+ (('result result)
+ result))))))
+
+(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))
target)
;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET.
(inferior-package->derivation package system #:target target))
+
+(define* (gexp->derivation-in-inferior name exp guix
+ #:key silent-failure?
+ #:allow-other-keys
+ #:rest rest)
+ "Return a derivation that evaluates EXP with GUIX, an instance of Guix as
+returned for example by 'channel-instances->derivation'. Other arguments are
+passed as-is to 'gexp->derivation'.
+
+When SILENT-FAILURE? is true, create an empty output directory instead of
+failing when GUIX is too old and lacks the 'guix repl' command."
+ (define script
+ ;; EXP wrapped with a proper (set! %load-path …) prologue.
+ (scheme-file "inferior-script.scm" exp))
+
+ (define trampoline
+ ;; This is a crude way to run EXP on GUIX. TODO: use 'raw-derivation' and
+ ;; make 'guix repl' the "builder"; this will require "opening up" the
+ ;; mechanisms behind 'gexp->derivation', and adding '-l' to 'guix repl'.
+ #~(begin
+ (use-modules (ice-9 popen))
+
+ (let ((pipe (open-pipe* OPEN_WRITE
+ #+(file-append guix "/bin/guix")
+ "repl" "-t" "machine")))
+
+ ;; XXX: EXP presumably refers to #$output but that reference is lost
+ ;; so explicitly reference it here.
+ #$output
+
+ (write `(primitive-load #$script) pipe)
+
+ (unless (zero? (close-pipe pipe))
+ (if #$silent-failure?
+ (mkdir #$output)
+ (error "inferior failed" #+guix))))))
+
+ (define (drop-extra-keyword lst)
+ (let loop ((lst lst)
+ (result '()))
+ (match lst
+ (()
+ (reverse result))
+ ((#:silent-failure? _ . rest)
+ (loop rest result))
+ ((kw value . tail)
+ (loop tail (cons* value kw result))))))
+
+ (apply gexp->derivation name trampoline
+ (drop-extra-keyword rest)))
+
+\f
+;;;
+;;; Manifest entries.
+;;;
+
+(define* (inferior-package->manifest-entry package
+ #:optional (output "out")
+ #:key (properties '()))
+ "Return a manifest entry for the OUTPUT of package PACKAGE."
+ (define cache
+ (make-hash-table))
+
+ (define-syntax-rule (memoized package output exp)
+ ;; Memoize the entry returned by EXP for PACKAGE/OUTPUT. This is
+ ;; important as the same package may be traversed many times through
+ ;; propagated inputs, and querying the inferior is costly. Use
+ ;; 'hash'/'equal?', which is okay since <inferior-package> is simple.
+ (let ((compute (lambda () exp))
+ (key (cons package output)))
+ (or (hash-ref cache key)
+ (let ((result (compute)))
+ (hash-set! cache key result)
+ result))))
+
+ (let loop ((package package)
+ (output output)
+ (parent (delay #f)))
+ (memoized package output
+ ;; For each dependency, keep a promise pointing to its "parent" entry.
+ (letrec* ((deps (map (match-lambda
+ ((label package)
+ (loop package "out" (delay entry)))
+ ((label package output)
+ (loop package output (delay entry))))
+ (inferior-package-propagated-inputs package)))
+ (entry (manifest-entry
+ (name (inferior-package-name package))
+ (version (inferior-package-version package))
+ (output output)
+ (item package)
+ (dependencies (delete-duplicates deps))
+ (search-paths
+ (inferior-package-transitive-native-search-paths package))
+ (parent parent)
+ (properties properties))))
+ entry))))
+
+\f
+;;;
+;;; Cached inferiors.
+;;;
+
+(define %inferior-cache-directory
+ ;; Directory for cached inferiors (GC roots).
+ (make-parameter (string-append (cache-directory #:ensure? #f)
+ "/inferiors")))
+
+(define (channel-full-commit channel)
+ "Return the commit designated by CHANNEL as quickly as possible. If
+CHANNEL's 'commit' field is a full SHA1, return it as-is; if it's a SHA1
+prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip."
+ (let ((commit (channel-commit channel))
+ (branch (channel-branch channel)))
+ (if (and commit (= (string-length commit) 40))
+ commit
+ (let* ((ref (if commit `(commit . ,commit) `(branch . ,branch)))
+ (cache commit relation
+ (update-cached-checkout (channel-url channel)
+ #:ref ref
+ #:check-out? #f)))
+ commit))))
+
+(define* (cached-channel-instance store
+ channels
+ #:key
+ (authenticate? #t)
+ (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. AUTHENTICATE?
+determines whether CHANNELS are authenticated."
+ (define commits
+ ;; Since computing the instances of CHANNELS is I/O-intensive, use a
+ ;; cheaper way to get the commit list of CHANNELS. This limits overhead
+ ;; to the minimum in case of a cache hit.
+ (map channel-full-commit channels))
+
+ (define key
+ (bytevector->base32-string
+ (sha256
+ (string->utf8 (string-concatenate commits)))))
+
+ (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/safe old new)
+ (catch 'system-error
+ (lambda ()
+ (symlink old new))
+ (lambda args
+ (unless (= EEXIST (system-error-errno args))
+ (apply throw args)))))
+
+ (define symlink*
+ (lift2 symlink/safe %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 ((instances
+ -> (latest-channel-instances store channels
+ #:authenticate?
+ authenticate?))
+ (profile
+ (channel-instances->derivation instances)))
+ (mbegin %store-monad
+ (show-what-to-build* (list profile))
+ (built-derivations (list profile))
+ ;; Note: Caching is fine even when AUTHENTICATE? is false because
+ ;; we always call 'latest-channel-instances?'.
+ (symlink* (derivation->output-path profile) cached)
+ (add-indirect-root* cached)
+ (return cached))))))
+
+(define* (inferior-for-channels channels
+ #:key
+ (cache-directory (%inferior-cache-directory))
+ (ttl (* 3600 24 30)))
+ "Return an inferior for CHANNELS, a list of channels. Use the cache at
+CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds. This
+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
+ (with-store store
+ (cached-channel-instance store
+ channels
+ #:cache-directory cache-directory
+ #:ttl ttl)))
+ (open-inferior cached))
+
+;;; Local Variables:
+;;; eval: (put 'memoized 'scheme-indent-function 1)
+;;; End:
HCoop / jackhill / guix / guix.git / blobdiff