[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 (srfi srfi-1)
  #: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-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 '(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 (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)
e1a4ffda	35	#:use-module (srfi srfi-1)
2ca299ca LC	36	#:use-module (ice-9 match)
2ca299ca LC	37	#:use-module (ice-9 popen)
e1a4ffda	38	#:use-module (ice-9 vlist)
9daf046c	39	#:use-module (ice-9 binary-ports)
2ca299ca LC	40	#:export (inferior?
	41	open-inferior
	42	close-inferior
	43	inferior-eval
	44	inferior-object?
	45
	46	inferior-package?
	47	inferior-package-name
	48	inferior-package-version
	49
	50	inferior-packages
e1a4ffda	51	lookup-inferior-packages
2ca299ca	52	inferior-package-synopsis
7e1d2290 LC	53	inferior-package-description
7e1d2290 LC	54	inferior-package-home-page
9daf046c LC	55	inferior-package-location
9daf046c LC	56	inferior-package-derivation))
2ca299ca LC	57
	58	;;; Commentary:
	59	;;;
	60	;;; This module provides a way to spawn Guix "inferior" processes and to talk
	61	;;; to them. It allows us, from one instance of Guix, to interact with
	62	;;; another instance of Guix coming from a different commit.
	63	;;;
	64	;;; Code:
	65
	66	;; Inferior Guix process.
	67	(define-record-type <inferior>
e1a4ffda	68	(inferior pid socket version packages table)
2ca299ca LC	69	inferior?
	70	(pid inferior-pid)
	71	(socket inferior-socket)
e1a4ffda LC	72	(version inferior-version) ;REPL protocol version
	73	(packages inferior-package-promise) ;promise of inferior packages
	74	(table inferior-package-table)) ;promise of vhash
2ca299ca LC	75
	76	(define (inferior-pipe directory command)
	77	"Return an input/output pipe on the Guix instance in DIRECTORY. This runs
	78	'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if
	79	it's an old Guix."
	80	(let ((pipe (with-error-to-port (%make-void-port "w")
	81	(lambda ()
	82	(open-pipe* OPEN_BOTH
	83	(string-append directory "/" command)
	84	"repl" "-t" "machine")))))
	85	(if (eof-object? (peek-char pipe))
	86	(begin
	87	(close-pipe pipe)
	88
	89	;; Older versions of Guix didn't have a 'guix repl' command, so
	90	;; emulate it.
	91	(open-pipe* OPEN_BOTH "guile"
	92	"-L" (string-append directory "/share/guile/site/"
	93	(effective-version))
	94	"-C" (string-append directory "/share/guile/site/"
	95	(effective-version))
	96	"-C" (string-append directory "/lib/guile/"
	97	(effective-version) "/site-ccache")
	98	"-c"
	99	(object->string
	100	`(begin
	101	(primitive-load ,(search-path %load-path
	102	"guix/scripts/repl.scm"))
	103	((@ (guix scripts repl) machine-repl))))))
	104	pipe)))
	105
	106	(define* (open-inferior directory #:key (command "bin/guix"))
	107	"Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or
	108	equivalent. Return #f if the inferior could not be launched."
	109	(define pipe
	110	(inferior-pipe directory command))
	111
a81b59b1 LC	112	(cond-expand
	113	((and guile-2 (not guile-2.2)) #t)
	114	(else (setvbuf pipe 'line)))
	115
2ca299ca LC	116	(match (read pipe)
2ca299ca LC	117	(('repl-version 0 rest ...)
e1a4ffda LC	118	(letrec ((result (inferior 'pipe pipe (cons 0 rest)
	119	(delay (%inferior-packages result))
	120	(delay (%inferior-package-table result)))))
2ca299ca LC	121	(inferior-eval '(use-modules (guix)) result)
	122	(inferior-eval '(use-modules (gnu)) result)
	123	(inferior-eval '(define %package-table (make-hash-table))
	124	result)
	125	result))
	126	(_
	127	#f)))
	128
	129	(define (close-inferior inferior)
	130	"Close INFERIOR."
	131	(close-pipe (inferior-socket inferior)))
	132
	133	;; Non-self-quoting object of the inferior.
	134	(define-record-type <inferior-object>
	135	(inferior-object address appearance)
	136	inferior-object?
	137	(address inferior-object-address)
	138	(appearance inferior-object-appearance))
	139
	140	(define (write-inferior-object object port)
	141	(match object
	142	(($ <inferior-object> _ appearance)
	143	(format port "#<inferior-object ~a>" appearance))))
	144
	145	(set-record-type-printer! <inferior-object> write-inferior-object)
	146
9daf046c	147	(define (read-inferior-response inferior)
2ca299ca LC	148	(define sexp->object
	149	(match-lambda
	150	(('value value)
	151	value)
	152	(('non-self-quoting address string)
	153	(inferior-object address string))))
	154
2ca299ca LC	155	(match (read (inferior-socket inferior))
	156	(('values objects ...)
	157	(apply values (map sexp->object objects)))
	158	(('exception key objects ...)
	159	(apply throw key (map sexp->object objects)))))
	160
9daf046c LC	161	(define (send-inferior-request exp inferior)
	162	(write exp (inferior-socket inferior))
	163	(newline (inferior-socket inferior)))
	164
	165	(define (inferior-eval exp inferior)
	166	"Evaluate EXP in INFERIOR."
	167	(send-inferior-request exp inferior)
	168	(read-inferior-response inferior))
	169
2ca299ca LC	170	\f
	171	;;;
	172	;;; Inferior packages.
	173	;;;
	174
	175	(define-record-type <inferior-package>
	176	(inferior-package inferior name version id)
	177	inferior-package?
	178	(inferior inferior-package-inferior)
	179	(name inferior-package-name)
	180	(version inferior-package-version)
	181	(id inferior-package-id))
	182
	183	(define (write-inferior-package package port)
	184	(match package
	185	(($ <inferior-package> _ name version)
	186	(format port "#<inferior-package ~a@~a ~a>"
	187	name version
	188	(number->string (object-address package) 16)))))
	189
	190	(set-record-type-printer! <inferior-package> write-inferior-package)
	191
e1a4ffda LC	192	(define (%inferior-packages inferior)
e1a4ffda LC	193	"Compute the list of inferior packages from INFERIOR."
2ca299ca LC	194	(let ((result (inferior-eval
	195	'(fold-packages (lambda (package result)
	196	(let ((id (object-address package)))
	197	(hashv-set! %package-table id package)
	198	(cons (list (package-name package)
	199	(package-version package)
	200	id)
	201	result)))
	202	'())
	203	inferior)))
	204	(map (match-lambda
	205	((name version id)
	206	(inferior-package inferior name version id)))
	207	result)))
	208
e1a4ffda LC	209	(define (inferior-packages inferior)
	210	"Return the list of packages known to INFERIOR."
	211	(force (inferior-package-promise inferior)))
	212
	213	(define (%inferior-package-table inferior)
	214	"Compute a package lookup table for INFERIOR."
	215	(fold (lambda (package table)
	216	(vhash-cons (inferior-package-name package) package
	217	table))
	218	vlist-null
	219	(inferior-packages inferior)))
	220
	221	(define* (lookup-inferior-packages inferior name #:optional version)
	222	"Return the sorted list of inferior packages matching NAME in INFERIOR, with
	223	highest version numbers first. If VERSION is true, return only packages with
	224	a version number prefixed by VERSION."
	225	;; This is the counterpart of 'find-packages-by-name'.
	226	(sort (filter (lambda (package)
	227	(or (not version)
	228	(version-prefix? version
	229	(inferior-package-version package))))
	230	(vhash-fold* cons '() name
	231	(force (inferior-package-table inferior))))
	232	(lambda (p1 p2)
	233	(version>? (inferior-package-version p1)
	234	(inferior-package-version p2)))))
	235
2ca299ca LC	236	(define (inferior-package-field package getter)
	237	"Return the field of PACKAGE, an inferior package, accessed with GETTER."
	238	(let ((inferior (inferior-package-inferior package))
	239	(id (inferior-package-id package)))
	240	(inferior-eval `(,getter (hashv-ref %package-table ,id))
	241	inferior)))
	242
	243	(define* (inferior-package-synopsis package #:key (translate? #t))
	244	"Return the Texinfo synopsis of PACKAGE, an inferior package. When
	245	TRANSLATE? is true, translate it to the current locale's language."
	246	(inferior-package-field package
	247	(if translate?
	248	'(compose (@ (guix ui) P_) package-synopsis)
	249	'package-synopsis)))
	250
	251	(define* (inferior-package-description package #:key (translate? #t))
	252	"Return the Texinfo description of PACKAGE, an inferior package. When
	253	TRANSLATE? is true, translate it to the current locale's language."
	254	(inferior-package-field package
	255	(if translate?
	256	'(compose (@ (guix ui) P_) package-description)
	257	'package-description)))
7e1d2290 LC	258
	259	(define (inferior-package-home-page package)
	260	"Return the home page of PACKAGE."
	261	(inferior-package-field package 'package-home-page))
	262
	263	(define (inferior-package-location package)
	264	"Return the source code location of PACKAGE, either #f or a <location>
	265	record."
	266	(source-properties->location
	267	(inferior-package-field package
	268	'(compose (lambda (loc)
	269	(and loc
	270	(location->source-properties
	271	loc)))
	272	package-location))))
9daf046c LC	273
	274	(define (proxy client backend) ;adapted from (guix ssh)
	275	"Proxy communication between CLIENT and BACKEND until CLIENT closes the
	276	connection, at which point CLIENT is closed (both CLIENT and BACKEND must be
	277	input/output ports.)"
	278	(define (select* read write except)
	279	;; This is a workaround for <https://bugs.gnu.org/30365> in Guile < 2.2.4:
	280	;; since 'select' sometimes returns non-empty sets for no good reason,
	281	;; call 'select' a second time with a zero timeout to filter out incorrect
	282	;; replies.
	283	(match (select read write except)
	284	((read write except)
	285	(select read write except 0))))
	286
	287	;; Use buffered ports so that 'get-bytevector-some' returns up to the
	288	;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>.
	289	(setvbuf client _IOFBF 65536)
	290	(setvbuf backend _IOFBF 65536)
	291
	292	(let loop ()
	293	(match (select* (list client backend) '() '())
	294	((reads () ())
	295	(when (memq client reads)
	296	(match (get-bytevector-some client)
	297	((? eof-object?)
	298	(close-port client))
	299	(bv
	300	(put-bytevector backend bv)
	301	(force-output backend))))
	302	(when (memq backend reads)
	303	(match (get-bytevector-some backend)
	304	(bv
	305	(put-bytevector client bv)
	306	(force-output client))))
	307	(unless (port-closed? client)
	308	(loop))))))
	309
	310	(define* (inferior-package-derivation store package
	311	#:optional
	312	(system (%current-system))
	313	#:key target)
	314	"Return the derivation for PACKAGE, an inferior package, built for SYSTEM
	315	and cross-built for TARGET if TARGET is true. The inferior corresponding to
	316	PACKAGE must be live."
	317	;; Create a named socket in /tmp and let the inferior of PACKAGE connect to
	318	;; it and use it as its store. This ensures the inferior uses the same
	319	;; store, with the same options, the same per-session GC roots, etc.
	320	(call-with-temporary-directory
	321	(lambda (directory)
	322	(chmod directory #o700)
	323	(let* ((name (string-append directory "/inferior"))
	324	(socket (socket AF_UNIX SOCK_STREAM 0))
	325	(inferior (inferior-package-inferior package))
	326	(major (nix-server-major-version store))
	327	(minor (nix-server-minor-version store))
	328	(proto (logior major minor)))
	329	(bind socket AF_UNIX name)
	330	(listen socket 1024)
	331	(send-inferior-request
	332	`(let ((socket (socket AF_UNIX SOCK_STREAM 0)))
	333	(connect socket AF_UNIX ,name)
	334
	335	;; 'port->connection' appeared in June 2018 and we can hardly
	336	;; emulate it on older versions. Thus fall back to
337	;; 'open-connection', at the risk of talking to the wrong daemon or
338	;; having our build result reclaimed (XXX).
339	(let* ((store (if (defined? 'port->connection)
340	(port->connection socket #:version ,proto)
341	(open-connection)))
342	(package (hashv-ref %package-table
343	,(inferior-package-id package)))
344	(drv ,(if target
345	`(package-cross-derivation store package
346	,target
347	,system)
348	`(package-derivation store package
349	,system))))
350	(close-connection store)
351	(close-port socket)
352	(derivation-file-name drv)))
353	inferior)
354	(match (accept socket)
355	((client . address)
356	(proxy client (nix-server-socket store))))
357	(close-port socket)
358	(read-derivation-from-file (read-inferior-response inferior))))))
359
360	(define inferior-package->derivation
361	(store-lift inferior-package-derivation))
362
363	(define-gexp-compiler (package-compiler (package <inferior-package>) system
364	target)
365	;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET.
366	(inferior-package->derivation package system #:target target))