984 lines
39 KiB
Scheme
984 lines
39 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2018-2023 Ludovic Courtès <ludo@gnu.org>
|
||
;;;
|
||
;;; This file is part of GNU Guix.
|
||
;;;
|
||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||
;;; under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(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
|
||
call-with-temporary-directory
|
||
version>? version-prefix?
|
||
cache-directory))
|
||
#:use-module ((guix store)
|
||
#: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 commit-id?))
|
||
#: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) (build-notifier)
|
||
#: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 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
|
||
inferior-protocol-error?
|
||
inferior-protocol-error-inferior
|
||
read-repl-response
|
||
|
||
inferior-packages
|
||
inferior-available-packages
|
||
lookup-inferior-packages
|
||
|
||
inferior-package?
|
||
inferior-package-name
|
||
inferior-package-version
|
||
inferior-package-synopsis
|
||
inferior-package-description
|
||
inferior-package-home-page
|
||
inferior-package-location
|
||
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-replacement
|
||
inferior-package-provenance
|
||
inferior-package-derivation
|
||
|
||
inferior-package->manifest-entry
|
||
|
||
gexp->derivation-in-inferior
|
||
|
||
%inferior-cache-directory
|
||
cached-channel-instance
|
||
inferior-for-channels))
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; This module provides a way to spawn Guix "inferior" processes and to talk
|
||
;;; to them. It allows us, from one instance of Guix, to interact with
|
||
;;; another instance of Guix coming from a different commit.
|
||
;;;
|
||
;;; Code:
|
||
|
||
;; Inferior Guix process.
|
||
(define-record-type <inferior>
|
||
(inferior pid socket close version packages table
|
||
bridge-socket)
|
||
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
|
||
|
||
;; Bridging with a store.
|
||
(bridge-socket inferior-bridge-socket ;#f | port
|
||
set-inferior-bridge-socket!))
|
||
|
||
(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 (open-bidirectional-pipe command . args)
|
||
"Open a bidirectional pipe to COMMAND invoked with ARGS and return it, as a
|
||
regular file port (socket).
|
||
|
||
This is equivalent to (open-pipe* OPEN_BOTH ...) except that the result is a
|
||
regular file port that can be passed to 'select' ('open-pipe*' returns a
|
||
custom binary port)."
|
||
;; Make sure the sockets are close-on-exec; failing to do that, a second
|
||
;; inferior (for instance) would inherit the underlying file descriptor, and
|
||
;; thus (close-port PARENT) in the original process would have no effect:
|
||
;; the REPL process wouldn't get EOF on standard input.
|
||
(match (socketpair AF_UNIX (logior SOCK_STREAM SOCK_CLOEXEC) 0)
|
||
((parent . child)
|
||
(if (defined? 'spawn)
|
||
(let* ((void (open-fdes "/dev/null" O_WRONLY))
|
||
(pid (catch 'system-error
|
||
(lambda ()
|
||
(spawn command (cons command args)
|
||
#:input child
|
||
#:output child
|
||
#:error (if (file-port? (current-error-port))
|
||
(current-error-port)
|
||
void)))
|
||
(const #f)))) ;can't exec, for instance ENOENT
|
||
(close-fdes void)
|
||
(close-port child)
|
||
(values parent pid))
|
||
(match (primitive-fork) ;Guile < 3.0.9
|
||
(0
|
||
(dynamic-wind
|
||
(lambda ()
|
||
#t)
|
||
(lambda ()
|
||
(close-port parent)
|
||
(close-fdes 0)
|
||
(close-fdes 1)
|
||
(close-fdes 2)
|
||
(dup2 (fileno child) 0)
|
||
(dup2 (fileno child) 1)
|
||
;; Mimic 'open-pipe*'.
|
||
(if (file-port? (current-error-port))
|
||
(let ((error-port-fileno
|
||
(fileno (current-error-port))))
|
||
(unless (eq? error-port-fileno 2)
|
||
(dup2 error-port-fileno
|
||
2)))
|
||
(dup2 (open-fdes "/dev/null" O_WRONLY)
|
||
2))
|
||
(apply execlp command command args))
|
||
(lambda ()
|
||
(primitive-_exit 127))))
|
||
(pid
|
||
(close-port child)
|
||
(values parent pid)))))))
|
||
|
||
(define* (inferior-pipe directory command error-port)
|
||
"Return two values: an input/output pipe on the Guix instance in DIRECTORY
|
||
and its PID. This runs 'DIRECTORY/COMMAND repl' if it exists, or falls back
|
||
to some other method if it's an old Guix."
|
||
(let ((pipe pid (with-error-to-port error-port
|
||
(lambda ()
|
||
(open-bidirectional-pipe
|
||
(string-append directory "/" command)
|
||
"repl" "-t" "machine")))))
|
||
(if (eof-object? (peek-char pipe))
|
||
(begin
|
||
(close-port pipe)
|
||
|
||
;; Older versions of Guix didn't have a 'guix repl' command, so
|
||
;; emulate it.
|
||
(with-error-to-port error-port
|
||
(lambda ()
|
||
(open-bidirectional-pipe
|
||
"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))))))))
|
||
(values pipe pid))))
|
||
|
||
(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 close (cons 0 rest)
|
||
(delay (%inferior-packages result))
|
||
(delay (%inferior-package-table result))
|
||
#f)))
|
||
|
||
;; 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)
|
||
(inferior-eval '(begin
|
||
(define %store-table (make-hash-table))
|
||
(define (cached-store-connection store-id version)
|
||
;; Cache connections to store ID. This ensures that
|
||
;; the caches within <store-connection> (in
|
||
;; particular the object cache) are reused across
|
||
;; calls to 'inferior-eval-with-store', which makes a
|
||
;; significant difference when it is called
|
||
;; repeatedly.
|
||
(or (hashv-ref %store-table store-id)
|
||
|
||
;; '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 %bridge-socket
|
||
#:version
|
||
version)
|
||
(open-connection))))
|
||
(hashv-set! %store-table store-id store)
|
||
store))))
|
||
result)
|
||
(inferior-eval '(begin
|
||
(define store-protocol-error?
|
||
(if (defined? 'store-protocol-error?)
|
||
store-protocol-error?
|
||
nix-protocol-error?))
|
||
(define store-protocol-error-message
|
||
(if (defined? 'store-protocol-error-message)
|
||
store-protocol-error-message
|
||
nix-protocol-error-message)))
|
||
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."
|
||
(let ((pipe pid (inferior-pipe directory command error-port)))
|
||
(port->inferior pipe
|
||
(lambda (port)
|
||
(close-port port)
|
||
(waitpid pid)))))
|
||
|
||
(define (close-inferior inferior)
|
||
"Close INFERIOR."
|
||
(let ((close (inferior-close-socket inferior)))
|
||
(close (inferior-socket inferior))
|
||
|
||
;; Close and delete the store bridge, if any.
|
||
(when (inferior-bridge-socket inferior)
|
||
(close-port (inferior-bridge-socket inferior)))))
|
||
|
||
;; Non-self-quoting object of the inferior.
|
||
(define-record-type <inferior-object>
|
||
(inferior-object address appearance)
|
||
inferior-object?
|
||
(address inferior-object-address)
|
||
(appearance inferior-object-appearance))
|
||
|
||
(define (write-inferior-object object port)
|
||
(match object
|
||
(($ <inferior-object> _ appearance)
|
||
(format port "#<inferior-object ~a>" appearance))))
|
||
|
||
(set-record-type-printer! <inferior-object> write-inferior-object)
|
||
|
||
;; 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-condition-type &inferior-protocol-error &error
|
||
inferior-protocol-error?
|
||
(inferior inferior-protocol-error-inferior)) ;<inferior>
|
||
|
||
(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)
|
||
value)
|
||
(('non-self-quoting address string)
|
||
(inferior-object address string))))
|
||
|
||
(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 ...)
|
||
;; Protocol (0 0).
|
||
(raise (condition (&inferior-exception
|
||
(arguments (cons key (map sexp->object objects)))
|
||
(inferior inferior)
|
||
(stack '())))))
|
||
(_
|
||
;; Protocol error.
|
||
(raise (condition (&inferior-protocol-error
|
||
(inferior inferior)))))))
|
||
|
||
(define (read-inferior-response inferior)
|
||
(read-repl-response (inferior-socket inferior)
|
||
inferior))
|
||
|
||
(define (send-inferior-request exp inferior)
|
||
(write exp (inferior-socket inferior))
|
||
(newline (inferior-socket inferior)))
|
||
|
||
(define (inferior-eval exp inferior)
|
||
"Evaluate EXP in INFERIOR."
|
||
(send-inferior-request exp inferior)
|
||
(read-inferior-response inferior))
|
||
|
||
|
||
;;;
|
||
;;; Inferior packages.
|
||
;;;
|
||
|
||
(define-record-type <inferior-package>
|
||
(inferior-package inferior name version id)
|
||
inferior-package?
|
||
(inferior inferior-package-inferior)
|
||
(name inferior-package-name)
|
||
(version inferior-package-version)
|
||
(id inferior-package-id))
|
||
|
||
(define (write-inferior-package package port)
|
||
(match package
|
||
(($ <inferior-package> _ name version)
|
||
(format port "#<inferior-package ~a@~a ~a>"
|
||
name version
|
||
(number->string (object-address package) 16)))))
|
||
|
||
(set-record-type-printer! <inferior-package> write-inferior-package)
|
||
|
||
(define (%inferior-packages inferior)
|
||
"Compute the list of inferior packages from INFERIOR."
|
||
(let ((result (inferior-eval
|
||
'(fold-packages (lambda (package result)
|
||
(let ((id (object-address package)))
|
||
(hashv-set! %package-table id package)
|
||
(cons (list (package-name package)
|
||
(package-version package)
|
||
id)
|
||
result)))
|
||
'())
|
||
inferior)))
|
||
(map (match-lambda
|
||
((name version id)
|
||
(inferior-package inferior name version id)))
|
||
result)))
|
||
|
||
(define (inferior-packages inferior)
|
||
"Return the list of packages known to INFERIOR."
|
||
(force (inferior-package-promise inferior)))
|
||
|
||
(define (%inferior-package-table inferior)
|
||
"Compute a package lookup table for INFERIOR."
|
||
(fold (lambda (package table)
|
||
(vhash-cons (inferior-package-name package) package
|
||
table))
|
||
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
|
||
a version number prefixed by VERSION."
|
||
;; This is the counterpart of 'find-packages-by-name'.
|
||
(sort (filter (lambda (package)
|
||
(or (not version)
|
||
(version-prefix? version
|
||
(inferior-package-version package))))
|
||
(vhash-fold* cons '() name
|
||
(force (inferior-package-table inferior))))
|
||
(lambda (p1 p2)
|
||
(version>? (inferior-package-version p1)
|
||
(inferior-package-version p2)))))
|
||
|
||
(define (inferior-package-field package getter)
|
||
"Return the field of PACKAGE, an inferior package, accessed with GETTER."
|
||
(let ((inferior (inferior-package-inferior package))
|
||
(id (inferior-package-id package)))
|
||
(inferior-eval `(,getter (hashv-ref %package-table ,id))
|
||
inferior)))
|
||
|
||
(define* (inferior-package-synopsis package #:key (translate? #t))
|
||
"Return the Texinfo synopsis of PACKAGE, an inferior package. When
|
||
TRANSLATE? is true, translate it to the current locale's language."
|
||
(inferior-package-field package
|
||
(if translate?
|
||
'(compose (@ (guix ui) P_) package-synopsis)
|
||
'package-synopsis)))
|
||
|
||
(define* (inferior-package-description package #:key (translate? #t))
|
||
"Return the Texinfo description of PACKAGE, an inferior package. When
|
||
TRANSLATE? is true, translate it to the current locale's language."
|
||
(inferior-package-field package
|
||
(if translate?
|
||
'(compose (@ (guix ui) P_) package-description)
|
||
'package-description)))
|
||
|
||
(define (inferior-package-home-page package)
|
||
"Return the home page of PACKAGE."
|
||
(inferior-package-field package 'package-home-page))
|
||
|
||
(define (inferior-package-location package)
|
||
"Return the source code location of PACKAGE, either #f or a <location>
|
||
record."
|
||
(source-properties->location
|
||
(inferior-package-field package
|
||
'(compose (lambda (loc)
|
||
(and loc
|
||
(location->source-properties
|
||
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-replacement package)
|
||
"Return the replacement for PACKAGE. This will either be an inferior
|
||
package, or #f."
|
||
(match (inferior-package-field
|
||
package
|
||
'(compose (match-lambda
|
||
((? package? package)
|
||
(let ((id (object-address package)))
|
||
(hashv-set! %package-table id package)
|
||
(list id
|
||
(package-name package)
|
||
(package-version package))))
|
||
(#f #f))
|
||
package-replacement))
|
||
(#f #f)
|
||
((id name version)
|
||
(inferior-package (inferior-package-inferior package)
|
||
name
|
||
version
|
||
id))))
|
||
|
||
(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 inferior store) ;adapted from (guix ssh)
|
||
"Proxy communication between INFERIOR and STORE, until the connection to
|
||
STORE is closed or INFERIOR has data available for input (a REPL response)."
|
||
(define client
|
||
(inferior-bridge-socket inferior))
|
||
(define backend
|
||
(store-connection-socket store))
|
||
(define response-port
|
||
(inferior-socket inferior))
|
||
|
||
;; 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 'block 65536)
|
||
(setvbuf backend 'block 65536)
|
||
|
||
;; RESPONSE-PORT may typically contain a leftover newline that 'read' didn't
|
||
;; consume. Drain it so that 'select' doesn't immediately stop.
|
||
(drain-input response-port)
|
||
|
||
(let loop ()
|
||
(match (select (list client backend response-port) '() '())
|
||
((reads () ())
|
||
(when (memq client reads)
|
||
(match (get-bytevector-some client)
|
||
((? eof-object?)
|
||
#t)
|
||
(bv
|
||
(put-bytevector backend bv)
|
||
(force-output backend))))
|
||
(when (memq backend reads)
|
||
(match (get-bytevector-some backend)
|
||
(bv
|
||
(put-bytevector client bv)
|
||
(force-output client))))
|
||
(unless (or (port-closed? client)
|
||
(memq response-port reads))
|
||
(loop))))))
|
||
|
||
(define (open-store-bridge! inferior)
|
||
"Open a \"store bridge\" for INFERIOR--a named socket in /tmp that will be
|
||
used to proxy store RPCs from the inferior to the store of the calling
|
||
process."
|
||
;; Create a named socket in /tmp to 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)))
|
||
(bind socket AF_UNIX name)
|
||
(listen socket 2)
|
||
|
||
(send-inferior-request
|
||
`(define %bridge-socket
|
||
(let ((socket (socket AF_UNIX SOCK_STREAM 0)))
|
||
(connect socket AF_UNIX ,name)
|
||
socket))
|
||
inferior)
|
||
(match (accept socket)
|
||
((client . address)
|
||
(close-port socket)
|
||
(set-inferior-bridge-socket! inferior client)))
|
||
(read-inferior-response inferior)))))
|
||
|
||
(define (ensure-store-bridge! inferior)
|
||
"Ensure INFERIOR has a connected bridge."
|
||
(or (inferior-bridge-socket inferior)
|
||
(begin
|
||
(open-store-bridge! inferior)
|
||
(inferior-bridge-socket inferior))))
|
||
|
||
(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."
|
||
(let* ((major (store-connection-major-version store))
|
||
(minor (store-connection-minor-version store))
|
||
(proto (logior major minor))
|
||
|
||
;; The address of STORE itself is not a good identifier because it
|
||
;; keeps changing through the use of "functional caches". The
|
||
;; address of its socket port makes more sense.
|
||
(store-id (object-address (store-connection-socket store))))
|
||
(ensure-store-bridge! inferior)
|
||
(send-inferior-request
|
||
`(let ((proc ,code)
|
||
(store (cached-store-connection ,store-id ,proto)))
|
||
;; 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 ((store-protocol-error? c)
|
||
`(store-protocol-error
|
||
,(store-protocol-error-message c))))
|
||
`(result ,(proc store))))
|
||
inferior)
|
||
(proxy inferior store)
|
||
|
||
(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))
|
||
|
||
(define-gexp-compiler (package-compiler (package <inferior-package>) system
|
||
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)))
|
||
|
||
|
||
;;;
|
||
;;; 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))))
|
||
|
||
|
||
;;;
|
||
;;; 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 (commit-id? commit))
|
||
commit
|
||
(let* ((ref (if commit `(tag-or-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))
|
||
(reference-channels '())
|
||
(validate-channels (const #t)))
|
||
"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.
|
||
|
||
VALIDATE-CHANNELS must be a four-argument procedure used to validate channel
|
||
instances against REFERENCE-CHANNELS; it is passed as #:validate-pull to
|
||
'latest-channel-instances' and should raise an exception in case a target
|
||
channel commit is deemed \"invalid\"."
|
||
(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))
|
||
|
||
(define add-temp-root*
|
||
(store-lift add-temp-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?
|
||
#:current-channels
|
||
reference-channels
|
||
#:validate-pull
|
||
validate-channels))
|
||
(profile
|
||
(channel-instances->derivation instances)))
|
||
(mbegin %store-monad
|
||
;; It's up to the caller to install a build handler to report
|
||
;; what's going to be built.
|
||
(built-derivations (list profile))
|
||
|
||
;; Cache if and only if AUTHENTICATE? is true.
|
||
(if authenticate?
|
||
(mbegin %store-monad
|
||
(symlink* (derivation->output-path profile) cached)
|
||
(add-indirect-root* cached)
|
||
(return cached))
|
||
(mbegin %store-monad
|
||
(add-temp-root* (derivation->output-path profile))
|
||
(return (derivation->output-path profile)))))))))
|
||
|
||
(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
|
||
;; XXX: Install a build notifier out of convenience, so users know
|
||
;; what's going on. However, we cannot be sure that its options, such
|
||
;; as #:use-substitutes?, correspond to the daemon's default settings.
|
||
(with-build-handler (build-notifier)
|
||
(cached-channel-instance store
|
||
channels
|
||
#:cache-directory cache-directory
|
||
#:ttl ttl))))
|
||
(open-inferior cached))
|
||
|
||
;;; Local Variables:
|
||
;;; eval: (put 'memoized 'scheme-indent-function 1)
|
||
;;; End:
|