[jackhill/guix/guix.git] / guix / inferior.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 ((guix utils)
                #:select (%current-system
                          source-properties->location
                          call-with-temporary-directory
                          version>? version-prefix?))
  #:use-module ((guix store)
                #:select (nix-server-socket
                          nix-server-major-version
                          nix-server-minor-version
                          store-lift))
  #:use-module ((guix derivations)
                #:select (read-derivation-from-file))
  #:use-module (guix gexp)
  #:use-module (guix search-paths)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 binary-ports)
  #:export (inferior?
            open-inferior
            close-inferior
            inferior-eval
            inferior-object?

            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-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-derivation))

;;; 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 version packages table)
  inferior?
  (pid      inferior-pid)
  (socket   inferior-socket)
  (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)
  "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")
                (lambda ()
                  (open-pipe* OPEN_BOTH
                              (string-append directory "/" command)
                              "repl" "-t" "machine")))))
    (if (eof-object? (peek-char pipe))
        (begin
          (close-pipe pipe)

          ;; 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))))))
        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)))

  (match (read pipe)
    (('repl-version 0 rest ...)
     (letrec ((result (inferior 'pipe pipe (cons 0 rest)
                                (delay (%inferior-packages result))
                                (delay (%inferior-package-table result)))))
       (inferior-eval '(use-modules (guix)) result)
       (inferior-eval '(use-modules (gnu)) result)
       (inferior-eval '(use-modules (ice-9 match)) result)
       (inferior-eval '(define %package-table (make-hash-table))
                      result)
       result))
    (_
     #f)))

(define (close-inferior inferior)
  "Close INFERIOR."
  (close-pipe (inferior-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)

(define (read-inferior-response inferior)
  (define sexp->object
    (match-lambda
      (('value value)
       value)
      (('non-self-quoting address string)
       (inferior-object address string))))

  (match (read (inferior-socket inferior))
    (('values objects ...)
     (apply values (map sexp->object objects)))
    (('exception key objects ...)
     (apply throw key (map sexp->object objects)))))

(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))

\f
;;;
;;; 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* (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 specificiations 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 (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)

  (let loop ()
    (match (select* (list client backend) '() '())
      ((reads () ())
       (when (memq client reads)
         (match (get-bytevector-some client)
           ((? eof-object?)
            (close-port client))
           (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 (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.
  (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))
            (proto    (logior major minor)))
       (bind socket AF_UNIX name)
       (listen socket 1024)
       (send-inferior-request
        `(let ((socket (socket AF_UNIX SOCK_STREAM 0)))
           (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)))
        inferior)
       (match (accept socket)
         ((client . address)
          (proxy client (nix-server-socket store))))
       (close-port socket)
       (read-derivation-from-file (read-inferior-response inferior))))))

(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))
Commit	Line	Data
2ca299ca LC	1	;;; GNU Guix --- Functional package management for GNU
	2	;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (guix inferior)
	20	#:use-module (srfi srfi-9)
	21	#:use-module (srfi srfi-9 gnu)
9daf046c LC	22	#:use-module ((guix utils)
	23	#:select (%current-system
	24	source-properties->location
e1a4ffda LC	25	call-with-temporary-directory
e1a4ffda LC	26	version>? version-prefix?))
9daf046c LC	27	#:use-module ((guix store)
	28	#:select (nix-server-socket
	29	nix-server-major-version
	30	nix-server-minor-version
	31	store-lift))
	32	#:use-module ((guix derivations)
	33	#:select (read-derivation-from-file))
	34	#:use-module (guix gexp)
eee8b303	35	#:use-module (guix search-paths)
e1a4ffda	36	#:use-module (srfi srfi-1)
6030396a	37	#:use-module (srfi srfi-26)
2ca299ca LC	38	#:use-module (ice-9 match)
2ca299ca LC	39	#:use-module (ice-9 popen)
e1a4ffda	40	#:use-module (ice-9 vlist)
9daf046c	41	#:use-module (ice-9 binary-ports)
2ca299ca LC	42	#:export (inferior?
	43	open-inferior
	44	close-inferior
	45	inferior-eval
	46	inferior-object?
	47
	48	inferior-package?
	49	inferior-package-name
	50	inferior-package-version
	51
	52	inferior-packages
e1a4ffda	53	lookup-inferior-packages
2ca299ca	54	inferior-package-synopsis
7e1d2290 LC	55	inferior-package-description
7e1d2290 LC	56	inferior-package-home-page
9daf046c	57	inferior-package-location
6030396a LC	58	inferior-package-inputs
	59	inferior-package-native-inputs
	60	inferior-package-propagated-inputs
	61	inferior-package-transitive-propagated-inputs
eee8b303 LC	62	inferior-package-native-search-paths
	63	inferior-package-transitive-native-search-paths
	64	inferior-package-search-paths
9daf046c	65	inferior-package-derivation))
2ca299ca LC	66
	67	;;; Commentary:
	68	;;;
	69	;;; This module provides a way to spawn Guix "inferior" processes and to talk
	70	;;; to them. It allows us, from one instance of Guix, to interact with
	71	;;; another instance of Guix coming from a different commit.
	72	;;;
	73	;;; Code:
	74
	75	;; Inferior Guix process.
	76	(define-record-type <inferior>
e1a4ffda	77	(inferior pid socket version packages table)
2ca299ca LC	78	inferior?
	79	(pid inferior-pid)
	80	(socket inferior-socket)
e1a4ffda LC	81	(version inferior-version) ;REPL protocol version
	82	(packages inferior-package-promise) ;promise of inferior packages
	83	(table inferior-package-table)) ;promise of vhash
2ca299ca LC	84
	85	(define (inferior-pipe directory command)
	86	"Return an input/output pipe on the Guix instance in DIRECTORY. This runs
	87	'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if
	88	it's an old Guix."
	89	(let ((pipe (with-error-to-port (%make-void-port "w")
	90	(lambda ()
	91	(open-pipe* OPEN_BOTH
	92	(string-append directory "/" command)
	93	"repl" "-t" "machine")))))
	94	(if (eof-object? (peek-char pipe))
	95	(begin
	96	(close-pipe pipe)
	97
	98	;; Older versions of Guix didn't have a 'guix repl' command, so
	99	;; emulate it.
	100	(open-pipe* OPEN_BOTH "guile"
	101	"-L" (string-append directory "/share/guile/site/"
	102	(effective-version))
	103	"-C" (string-append directory "/share/guile/site/"
	104	(effective-version))
	105	"-C" (string-append directory "/lib/guile/"
	106	(effective-version) "/site-ccache")
	107	"-c"
	108	(object->string
	109	`(begin
	110	(primitive-load ,(search-path %load-path
	111	"guix/scripts/repl.scm"))
	112	((@ (guix scripts repl) machine-repl))))))
	113	pipe)))
	114
	115	(define* (open-inferior directory #:key (command "bin/guix"))
	116	"Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or
	117	equivalent. Return #f if the inferior could not be launched."
	118	(define pipe
	119	(inferior-pipe directory command))
	120
a81b59b1 LC	121	(cond-expand
	122	((and guile-2 (not guile-2.2)) #t)
	123	(else (setvbuf pipe 'line)))
	124
2ca299ca LC	125	(match (read pipe)
2ca299ca LC	126	(('repl-version 0 rest ...)
e1a4ffda LC	127	(letrec ((result (inferior 'pipe pipe (cons 0 rest)
	128	(delay (%inferior-packages result))
	129	(delay (%inferior-package-table result)))))
2ca299ca LC	130	(inferior-eval '(use-modules (guix)) result)
2ca299ca LC	131	(inferior-eval '(use-modules (gnu)) result)
6030396a	132	(inferior-eval '(use-modules (ice-9 match)) result)
2ca299ca LC	133	(inferior-eval '(define %package-table (make-hash-table))
	134	result)
	135	result))
	136	(_
	137	#f)))
	138
	139	(define (close-inferior inferior)
	140	"Close INFERIOR."
	141	(close-pipe (inferior-socket inferior)))
	142
	143	;; Non-self-quoting object of the inferior.
	144	(define-record-type <inferior-object>
	145	(inferior-object address appearance)
	146	inferior-object?
	147	(address inferior-object-address)
	148	(appearance inferior-object-appearance))
	149
	150	(define (write-inferior-object object port)
	151	(match object
	152	(($ <inferior-object> _ appearance)
	153	(format port "#<inferior-object ~a>" appearance))))
	154
	155	(set-record-type-printer! <inferior-object> write-inferior-object)
	156
9daf046c	157	(define (read-inferior-response inferior)
2ca299ca LC	158	(define sexp->object
	159	(match-lambda
	160	(('value value)
	161	value)
	162	(('non-self-quoting address string)
	163	(inferior-object address string))))
	164
2ca299ca LC	165	(match (read (inferior-socket inferior))
	166	(('values objects ...)
	167	(apply values (map sexp->object objects)))
	168	(('exception key objects ...)
	169	(apply throw key (map sexp->object objects)))))
	170
9daf046c LC	171	(define (send-inferior-request exp inferior)
	172	(write exp (inferior-socket inferior))
	173	(newline (inferior-socket inferior)))
	174
	175	(define (inferior-eval exp inferior)
	176	"Evaluate EXP in INFERIOR."
	177	(send-inferior-request exp inferior)
	178	(read-inferior-response inferior))
	179
2ca299ca LC	180	\f
	181	;;;
	182	;;; Inferior packages.
	183	;;;
	184
	185	(define-record-type <inferior-package>
	186	(inferior-package inferior name version id)
	187	inferior-package?
	188	(inferior inferior-package-inferior)
	189	(name inferior-package-name)
	190	(version inferior-package-version)
	191	(id inferior-package-id))
	192
	193	(define (write-inferior-package package port)
	194	(match package
	195	(($ <inferior-package> _ name version)
	196	(format port "#<inferior-package ~a@~a ~a>"
	197	name version
	198	(number->string (object-address package) 16)))))
	199
	200	(set-record-type-printer! <inferior-package> write-inferior-package)
	201
e1a4ffda LC	202	(define (%inferior-packages inferior)
e1a4ffda LC	203	"Compute the list of inferior packages from INFERIOR."
2ca299ca LC	204	(let ((result (inferior-eval
	205	'(fold-packages (lambda (package result)
	206	(let ((id (object-address package)))
	207	(hashv-set! %package-table id package)
	208	(cons (list (package-name package)
	209	(package-version package)
	210	id)
	211	result)))
	212	'())
	213	inferior)))
	214	(map (match-lambda
	215	((name version id)
	216	(inferior-package inferior name version id)))
	217	result)))
	218
e1a4ffda LC	219	(define (inferior-packages inferior)
	220	"Return the list of packages known to INFERIOR."
	221	(force (inferior-package-promise inferior)))
	222
	223	(define (%inferior-package-table inferior)
	224	"Compute a package lookup table for INFERIOR."
	225	(fold (lambda (package table)
	226	(vhash-cons (inferior-package-name package) package
	227	table))
	228	vlist-null
	229	(inferior-packages inferior)))
	230
	231	(define* (lookup-inferior-packages inferior name #:optional version)
	232	"Return the sorted list of inferior packages matching NAME in INFERIOR, with
	233	highest version numbers first. If VERSION is true, return only packages with
	234	a version number prefixed by VERSION."
	235	;; This is the counterpart of 'find-packages-by-name'.
	236	(sort (filter (lambda (package)
	237	(or (not version)
	238	(version-prefix? version
	239	(inferior-package-version package))))
	240	(vhash-fold* cons '() name
	241	(force (inferior-package-table inferior))))
	242	(lambda (p1 p2)
	243	(version>? (inferior-package-version p1)
	244	(inferior-package-version p2)))))
	245
2ca299ca LC	246	(define (inferior-package-field package getter)
	247	"Return the field of PACKAGE, an inferior package, accessed with GETTER."
	248	(let ((inferior (inferior-package-inferior package))
	249	(id (inferior-package-id package)))
	250	(inferior-eval `(,getter (hashv-ref %package-table ,id))
	251	inferior)))
	252
	253	(define* (inferior-package-synopsis package #:key (translate? #t))
	254	"Return the Texinfo synopsis of PACKAGE, an inferior package. When
	255	TRANSLATE? is true, translate it to the current locale's language."
	256	(inferior-package-field package
	257	(if translate?
	258	'(compose (@ (guix ui) P_) package-synopsis)
	259	'package-synopsis)))
	260
	261	(define* (inferior-package-description package #:key (translate? #t))
	262	"Return the Texinfo description of PACKAGE, an inferior package. When
	263	TRANSLATE? is true, translate it to the current locale's language."
	264	(inferior-package-field package
	265	(if translate?
	266	'(compose (@ (guix ui) P_) package-description)
	267	'package-description)))
7e1d2290 LC	268
	269	(define (inferior-package-home-page package)
	270	"Return the home page of PACKAGE."
	271	(inferior-package-field package 'package-home-page))
	272
	273	(define (inferior-package-location package)
	274	"Return the source code location of PACKAGE, either #f or a <location>
	275	record."
	276	(source-properties->location
	277	(inferior-package-field package
	278	'(compose (lambda (loc)
	279	(and loc
	280	(location->source-properties
	281	loc)))
	282	package-location))))
9daf046c	283
6030396a LC	284	(define (inferior-package-input-field package field)
	285	"Return the input field FIELD (e.g., 'native-inputs') of PACKAGE, an
	286	inferior package."
	287	(define field*
	288	`(compose (lambda (inputs)
	289	(map (match-lambda
	290	;; XXX: Origins are not handled.
	291	((label (? package? package) rest ...)
	292	(let ((id (object-address package)))
	293	(hashv-set! %package-table id package)
	294	`(,label (package ,id
	295	,(package-name package)
	296	,(package-version package))
	297	,@rest)))
	298	(x
	299	x))
	300	inputs))
	301	,field))
	302
	303	(define inputs
	304	(inferior-package-field package field*))
	305
	306	(define inferior
	307	(inferior-package-inferior package))
	308
	309	(map (match-lambda
	310	((label ('package id name version) . rest)
	311	;; XXX: eq?-ness of inferior packages is not preserved here.
	312	`(,label ,(inferior-package inferior name version id)
	313	,@rest))
	314	(x x))
	315	inputs))
	316
	317	(define inferior-package-inputs
	318	(cut inferior-package-input-field <> 'package-inputs))
	319
	320	(define inferior-package-native-inputs
	321	(cut inferior-package-input-field <> 'package-native-inputs))
	322
	323	(define inferior-package-propagated-inputs
	324	(cut inferior-package-input-field <> 'package-propagated-inputs))
	325
	326	(define inferior-package-transitive-propagated-inputs
	327	(cut inferior-package-input-field <> 'package-transitive-propagated-inputs))
	328
eee8b303 LC	329	(define (%inferior-package-search-paths package field)
	330	"Return the list of search path specificiations of PACKAGE, an inferior
	331	package."
	332	(define paths
	333	(inferior-package-field package
	334	`(compose (lambda (paths)
	335	(map (@ (guix search-paths)
	336	search-path-specification->sexp)
	337	paths))
	338	,field)))
	339
	340	(map sexp->search-path-specification paths))
	341
	342	(define inferior-package-native-search-paths
	343	(cut %inferior-package-search-paths <> 'package-native-search-paths))
	344
	345	(define inferior-package-search-paths
	346	(cut %inferior-package-search-paths <> 'package-search-paths))
	347
	348	(define inferior-package-transitive-native-search-paths
	349	(cut %inferior-package-search-paths <> 'package-transitive-native-search-paths))
	350
9daf046c LC	351	(define (proxy client backend) ;adapted from (guix ssh)
	352	"Proxy communication between CLIENT and BACKEND until CLIENT closes the
	353	connection, at which point CLIENT is closed (both CLIENT and BACKEND must be
	354	input/output ports.)"
	355	(define (select* read write except)
	356	;; This is a workaround for <https://bugs.gnu.org/30365> in Guile < 2.2.4:
	357	;; since 'select' sometimes returns non-empty sets for no good reason,
	358	;; call 'select' a second time with a zero timeout to filter out incorrect
	359	;; replies.
	360	(match (select read write except)
	361	((read write except)
	362	(select read write except 0))))
	363
	364	;; Use buffered ports so that 'get-bytevector-some' returns up to the
	365	;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>.
	366	(setvbuf client _IOFBF 65536)
	367	(setvbuf backend _IOFBF 65536)
	368
	369	(let loop ()
	370	(match (select* (list client backend) '() '())
	371	((reads () ())
	372	(when (memq client reads)
	373	(match (get-bytevector-some client)
	374	((? eof-object?)
	375	(close-port client))
	376	(bv
	377	(put-bytevector backend bv)
	378	(force-output backend))))
	379	(when (memq backend reads)
	380	(match (get-bytevector-some backend)
	381	(bv
	382	(put-bytevector client bv)
	383	(force-output client))))
	384	(unless (port-closed? client)
	385	(loop))))))
	386
	387	(define* (inferior-package-derivation store package
	388	#:optional
	389	(system (%current-system))
	390	#:key target)
	391	"Return the derivation for PACKAGE, an inferior package, built for SYSTEM
	392	and cross-built for TARGET if TARGET is true. The inferior corresponding to
	393	PACKAGE must be live."
	394	;; Create a named socket in /tmp and let the inferior of PACKAGE connect to
	395	;; it and use it as its store. This ensures the inferior uses the same
	396	;; store, with the same options, the same per-session GC roots, etc.
	397	(call-with-temporary-directory
	398	(lambda (directory)
	399	(chmod directory #o700)
	400	(let* ((name (string-append directory "/inferior"))
	401	(socket (socket AF_UNIX SOCK_STREAM 0))
	402	(inferior (inferior-package-inferior package))
	403	(major (nix-server-major-version store))
	404	(minor (nix-server-minor-version store))
	405	(proto (logior major minor)))
	406	(bind socket AF_UNIX name)
	407	(listen socket 1024)
	408	(send-inferior-request
	409	`(let ((socket (socket AF_UNIX SOCK_STREAM 0)))
	410	(connect socket AF_UNIX ,name)
	411
	412	;; 'port->connection' appeared in June 2018 and we can hardly
	413	;; emulate it on older versions. Thus fall back to
	414	;; 'open-connection', at the risk of talking to the wrong daemon or
415	;; having our build result reclaimed (XXX).
416	(let* ((store (if (defined? 'port->connection)
417	(port->connection socket #:version ,proto)
418	(open-connection)))
419	(package (hashv-ref %package-table
420	,(inferior-package-id package)))
421	(drv ,(if target
422	`(package-cross-derivation store package
423	,target
424	,system)
425	`(package-derivation store package
426	,system))))
427	(close-connection store)
428	(close-port socket)
429	(derivation-file-name drv)))
430	inferior)
431	(match (accept socket)
432	((client . address)
433	(proxy client (nix-server-socket store))))
434	(close-port socket)
435	(read-derivation-from-file (read-inferior-response inferior))))))
436
437	(define inferior-package->derivation
438	(store-lift inferior-package-derivation))
439
440	(define-gexp-compiler (package-compiler (package <inferior-package>) system
441	target)
442	;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET.
443	(inferior-package->derivation package system #:target target))