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