1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
19 (define-module (guix inferior)
20 #:use-module (srfi srfi-9)
21 #:use-module (srfi srfi-9 gnu)
22 #:use-module ((guix utils)
23 #:select (%current-system
24 source-properties->location
25 call-with-temporary-directory
26 version>? version-prefix?))
27 #:use-module ((guix store)
28 #:select (nix-server-socket
29 nix-server-major-version
30 nix-server-minor-version
32 #:use-module ((guix derivations)
33 #:select (read-derivation-from-file))
34 #:use-module (guix gexp)
35 #:use-module (srfi srfi-1)
36 #:use-module (srfi srfi-26)
37 #:use-module (ice-9 match)
38 #:use-module (ice-9 popen)
39 #:use-module (ice-9 vlist)
40 #:use-module (ice-9 binary-ports)
49 inferior-package-version
52 lookup-inferior-packages
53 inferior-package-synopsis
54 inferior-package-description
55 inferior-package-home-page
56 inferior-package-location
57 inferior-package-inputs
58 inferior-package-native-inputs
59 inferior-package-propagated-inputs
60 inferior-package-transitive-propagated-inputs
61 inferior-package-derivation))
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.
71 ;; Inferior Guix process.
72 (define-record-type <inferior>
73 (inferior pid socket version packages table)
76 (socket inferior-socket)
77 (version inferior-version) ;REPL protocol version
78 (packages inferior-package-promise) ;promise of inferior packages
79 (table inferior-package-table)) ;promise of vhash
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
85 (let ((pipe (with-error-to-port (%make-void-port "w")
88 (string-append directory "/" command)
89 "repl" "-t" "machine")))))
90 (if (eof-object? (peek-char pipe))
94 ;; Older versions of Guix didn't have a 'guix repl' command, so
96 (open-pipe* OPEN_BOTH "guile"
97 "-L" (string-append directory "/share/guile/site/"
99 "-C" (string-append directory "/share/guile/site/"
101 "-C" (string-append directory "/lib/guile/"
102 (effective-version) "/site-ccache")
106 (primitive-load ,(search-path %load-path
107 "guix/scripts/repl.scm"))
108 ((@ (guix scripts repl) machine-repl))))))
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."
115 (inferior-pipe directory command))
118 ((and guile-2 (not guile-2.2)) #t)
119 (else (setvbuf pipe 'line)))
122 (('repl-version 0 rest ...)
123 (letrec ((result (inferior 'pipe pipe (cons 0 rest)
124 (delay (%inferior-packages result))
125 (delay (%inferior-package-table result)))))
126 (inferior-eval '(use-modules (guix)) result)
127 (inferior-eval '(use-modules (gnu)) result)
128 (inferior-eval '(use-modules (ice-9 match)) result)
129 (inferior-eval '(define %package-table (make-hash-table))
135 (define (close-inferior inferior)
137 (close-pipe (inferior-socket inferior)))
139 ;; Non-self-quoting object of the inferior.
140 (define-record-type <inferior-object>
141 (inferior-object address appearance)
143 (address inferior-object-address)
144 (appearance inferior-object-appearance))
146 (define (write-inferior-object object port)
148 (($ <inferior-object> _ appearance)
149 (format port "#<inferior-object ~a>" appearance))))
151 (set-record-type-printer! <inferior-object> write-inferior-object)
153 (define (read-inferior-response inferior)
158 (('non-self-quoting address string)
159 (inferior-object address string))))
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)))))
167 (define (send-inferior-request exp inferior)
168 (write exp (inferior-socket inferior))
169 (newline (inferior-socket inferior)))
171 (define (inferior-eval exp inferior)
172 "Evaluate EXP in INFERIOR."
173 (send-inferior-request exp inferior)
174 (read-inferior-response inferior))
178 ;;; Inferior packages.
181 (define-record-type <inferior-package>
182 (inferior-package inferior name version id)
184 (inferior inferior-package-inferior)
185 (name inferior-package-name)
186 (version inferior-package-version)
187 (id inferior-package-id))
189 (define (write-inferior-package package port)
191 (($ <inferior-package> _ name version)
192 (format port "#<inferior-package ~a@~a ~a>"
194 (number->string (object-address package) 16)))))
196 (set-record-type-printer! <inferior-package> write-inferior-package)
198 (define (%inferior-packages inferior)
199 "Compute the list of inferior packages from INFERIOR."
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)
212 (inferior-package inferior name version id)))
215 (define (inferior-packages inferior)
216 "Return the list of packages known to INFERIOR."
217 (force (inferior-package-promise inferior)))
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
225 (inferior-packages inferior)))
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)
234 (version-prefix? version
235 (inferior-package-version package))))
236 (vhash-fold* cons '() name
237 (force (inferior-package-table inferior))))
239 (version>? (inferior-package-version p1)
240 (inferior-package-version p2)))))
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))
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
254 '(compose (@ (guix ui) P_) package-synopsis)
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
262 '(compose (@ (guix ui) P_) package-description)
263 'package-description)))
265 (define (inferior-package-home-page package)
266 "Return the home page of PACKAGE."
267 (inferior-package-field package 'package-home-page))
269 (define (inferior-package-location package)
270 "Return the source code location of PACKAGE, either #f or a <location>
272 (source-properties->location
273 (inferior-package-field package
274 '(compose (lambda (loc)
276 (location->source-properties
280 (define (inferior-package-input-field package field)
281 "Return the input field FIELD (e.g., 'native-inputs') of PACKAGE, an
284 `(compose (lambda (inputs)
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))
300 (inferior-package-field package field*))
303 (inferior-package-inferior package))
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)
313 (define inferior-package-inputs
314 (cut inferior-package-input-field <> 'package-inputs))
316 (define inferior-package-native-inputs
317 (cut inferior-package-input-field <> 'package-native-inputs))
319 (define inferior-package-propagated-inputs
320 (cut inferior-package-input-field <> 'package-propagated-inputs))
322 (define inferior-package-transitive-propagated-inputs
323 (cut inferior-package-input-field <> 'package-transitive-propagated-inputs))
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
334 (match (select read write except)
336 (select read write except 0))))
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)
344 (match (select* (list client backend) '() '())
346 (when (memq client reads)
347 (match (get-bytevector-some client)
351 (put-bytevector backend bv)
352 (force-output backend))))
353 (when (memq backend reads)
354 (match (get-bytevector-some backend)
356 (put-bytevector client bv)
357 (force-output client))))
358 (unless (port-closed? client)
361 (define* (inferior-package-derivation store package
363 (system (%current-system))
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
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)
382 (send-inferior-request
383 `(let ((socket (socket AF_UNIX SOCK_STREAM 0)))
384 (connect socket AF_UNIX ,name)
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)
393 (package (hashv-ref %package-table
394 ,(inferior-package-id package)))
396 `(package-cross-derivation store package
399 `(package-derivation store package
401 (close-connection store)
403 (derivation-file-name drv)))
405 (match (accept socket)
407 (proxy client (nix-server-socket store))))
409 (read-derivation-from-file (read-inferior-response inferior))))))
411 (define inferior-package->derivation
412 (store-lift inferior-package-derivation))
414 (define-gexp-compiler (package-compiler (package <inferior-package>) system
416 ;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET.
417 (inferior-package->derivation package system #:target target))