Commit | Line | Data |
---|---|---|
2ca299ca | 1 | ;;; GNU Guix --- Functional package management for GNU |
b1fc98d6 | 2 | ;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org> |
2ca299ca LC |
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) | |
71507435 LC |
22 | #:use-module (srfi srfi-34) |
23 | #:use-module (srfi srfi-35) | |
a5e2fc73 LC |
24 | #:use-module ((guix diagnostics) |
25 | #:select (source-properties->location)) | |
9daf046c LC |
26 | #:use-module ((guix utils) |
27 | #:select (%current-system | |
bd86bbd3 | 28 | call-with-temporary-directory |
2dad0313 LC |
29 | version>? version-prefix? |
30 | cache-directory)) | |
9daf046c | 31 | #:use-module ((guix store) |
de9fbe9c LC |
32 | #:select (store-connection-socket |
33 | store-connection-major-version | |
34 | store-connection-minor-version | |
71507435 LC |
35 | store-lift |
36 | &store-protocol-error)) | |
9daf046c LC |
37 | #:use-module ((guix derivations) |
38 | #:select (read-derivation-from-file)) | |
39 | #:use-module (guix gexp) | |
eee8b303 | 40 | #:use-module (guix search-paths) |
2e6d64e1 | 41 | #:use-module (guix profiles) |
2dad0313 | 42 | #:use-module (guix channels) |
7cfd7891 | 43 | #:use-module ((guix git) #:select (update-cached-checkout)) |
2dad0313 LC |
44 | #:use-module (guix monads) |
45 | #:use-module (guix store) | |
46 | #:use-module (guix derivations) | |
47 | #:use-module (guix base32) | |
48 | #:use-module (gcrypt hash) | |
ea6d962b LC |
49 | #:autoload (guix cache) (maybe-remove-expired-cache-entries |
50 | file-expiration-time) | |
7bd5f729 | 51 | #:autoload (guix ui) (build-notifier) |
2dad0313 | 52 | #:autoload (guix build utils) (mkdir-p) |
e1a4ffda | 53 | #:use-module (srfi srfi-1) |
6030396a | 54 | #:use-module (srfi srfi-26) |
7cfd7891 | 55 | #:use-module (srfi srfi-71) |
2dad0313 | 56 | #:autoload (ice-9 ftw) (scandir) |
2ca299ca | 57 | #:use-module (ice-9 match) |
e1a4ffda | 58 | #:use-module (ice-9 vlist) |
9daf046c | 59 | #:use-module (ice-9 binary-ports) |
2dad0313 | 60 | #:use-module ((rnrs bytevectors) #:select (string->utf8)) |
2ca299ca LC |
61 | #:export (inferior? |
62 | open-inferior | |
af15fe13 | 63 | port->inferior |
2ca299ca LC |
64 | close-inferior |
65 | inferior-eval | |
94c0e61f | 66 | inferior-eval-with-store |
2ca299ca | 67 | inferior-object? |
f7537e30 LC |
68 | inferior-exception? |
69 | inferior-exception-arguments | |
70 | inferior-exception-inferior | |
1dca6aaa | 71 | inferior-exception-stack |
d0ffa321 | 72 | read-repl-response |
2ca299ca | 73 | |
2e6d64e1 | 74 | inferior-packages |
73938054 | 75 | inferior-available-packages |
2e6d64e1 LC |
76 | lookup-inferior-packages |
77 | ||
2ca299ca LC |
78 | inferior-package? |
79 | inferior-package-name | |
80 | inferior-package-version | |
2ca299ca | 81 | inferior-package-synopsis |
7e1d2290 LC |
82 | inferior-package-description |
83 | inferior-package-home-page | |
9daf046c | 84 | inferior-package-location |
6030396a LC |
85 | inferior-package-inputs |
86 | inferior-package-native-inputs | |
87 | inferior-package-propagated-inputs | |
88 | inferior-package-transitive-propagated-inputs | |
eee8b303 LC |
89 | inferior-package-native-search-paths |
90 | inferior-package-transitive-native-search-paths | |
91 | inferior-package-search-paths | |
97d615b1 | 92 | inferior-package-replacement |
7a241c63 | 93 | inferior-package-provenance |
2e6d64e1 LC |
94 | inferior-package-derivation |
95 | ||
2dad0313 LC |
96 | inferior-package->manifest-entry |
97 | ||
ae927822 LC |
98 | gexp->derivation-in-inferior |
99 | ||
2dad0313 | 100 | %inferior-cache-directory |
8898eaec | 101 | cached-channel-instance |
2dad0313 | 102 | inferior-for-channels)) |
2ca299ca LC |
103 | |
104 | ;;; Commentary: | |
105 | ;;; | |
106 | ;;; This module provides a way to spawn Guix "inferior" processes and to talk | |
107 | ;;; to them. It allows us, from one instance of Guix, to interact with | |
108 | ;;; another instance of Guix coming from a different commit. | |
109 | ;;; | |
110 | ;;; Code: | |
111 | ||
112 | ;; Inferior Guix process. | |
113 | (define-record-type <inferior> | |
10aad721 | 114 | (inferior pid socket close version packages table |
bd86bbd3 | 115 | bridge-socket) |
2ca299ca LC |
116 | inferior? |
117 | (pid inferior-pid) | |
118 | (socket inferior-socket) | |
af15fe13 | 119 | (close inferior-close-socket) ;procedure |
e1a4ffda LC |
120 | (version inferior-version) ;REPL protocol version |
121 | (packages inferior-package-promise) ;promise of inferior packages | |
10aad721 LC |
122 | (table inferior-package-table) ;promise of vhash |
123 | ||
124 | ;; Bridging with a store. | |
10aad721 LC |
125 | (bridge-socket inferior-bridge-socket ;#f | port |
126 | set-inferior-bridge-socket!)) | |
2ca299ca | 127 | |
2569bd99 LC |
128 | (define (write-inferior inferior port) |
129 | (match inferior | |
130 | (($ <inferior> pid _ _ version) | |
131 | (format port "#<inferior ~a ~a ~a>" | |
132 | pid version | |
133 | (number->string (object-address inferior) 16))))) | |
134 | ||
135 | (set-record-type-printer! <inferior> write-inferior) | |
136 | ||
bd86bbd3 LC |
137 | (define (open-bidirectional-pipe command . args) |
138 | "Open a bidirectional pipe to COMMAND invoked with ARGS and return it, as a | |
139 | regular file port (socket). | |
140 | ||
141 | This is equivalent to (open-pipe* OPEN_BOTH ...) except that the result is a | |
142 | regular file port that can be passed to 'select' ('open-pipe*' returns a | |
143 | custom binary port)." | |
a4994d73 LC |
144 | ;; Make sure the sockets are close-on-exec; failing to do that, a second |
145 | ;; inferior (for instance) would inherit the underlying file descriptor, and | |
146 | ;; thus (close-port PARENT) in the original process would have no effect: | |
147 | ;; the REPL process wouldn't get EOF on standard input. | |
148 | (match (socketpair AF_UNIX (logior SOCK_STREAM SOCK_CLOEXEC) 0) | |
bd86bbd3 LC |
149 | ((parent . child) |
150 | (match (primitive-fork) | |
151 | (0 | |
152 | (dynamic-wind | |
153 | (lambda () | |
154 | #t) | |
155 | (lambda () | |
156 | (close-port parent) | |
157 | (close-fdes 0) | |
158 | (close-fdes 1) | |
b4c4a6ac | 159 | (close-fdes 2) |
bd86bbd3 LC |
160 | (dup2 (fileno child) 0) |
161 | (dup2 (fileno child) 1) | |
162 | ;; Mimic 'open-pipe*'. | |
b4c4a6ac CB |
163 | (if (file-port? (current-error-port)) |
164 | (let ((error-port-fileno | |
165 | (fileno (current-error-port)))) | |
166 | (unless (eq? error-port-fileno 2) | |
167 | (dup2 error-port-fileno | |
168 | 2))) | |
169 | (dup2 (open-fdes "/dev/null" O_WRONLY) | |
170 | 2)) | |
bd86bbd3 LC |
171 | (apply execlp command command args)) |
172 | (lambda () | |
173 | (primitive-_exit 127)))) | |
174 | (pid | |
175 | (close-port child) | |
176 | (values parent pid)))))) | |
177 | ||
f0428c18 | 178 | (define* (inferior-pipe directory command error-port) |
bd86bbd3 LC |
179 | "Return two values: an input/output pipe on the Guix instance in DIRECTORY |
180 | and its PID. This runs 'DIRECTORY/COMMAND repl' if it exists, or falls back | |
181 | to some other method if it's an old Guix." | |
182 | (let ((pipe pid (with-error-to-port error-port | |
183 | (lambda () | |
184 | (open-bidirectional-pipe | |
185 | (string-append directory "/" command) | |
186 | "repl" "-t" "machine"))))) | |
2ca299ca LC |
187 | (if (eof-object? (peek-char pipe)) |
188 | (begin | |
bd86bbd3 | 189 | (close-port pipe) |
2ca299ca LC |
190 | |
191 | ;; Older versions of Guix didn't have a 'guix repl' command, so | |
192 | ;; emulate it. | |
ef0c2654 CB |
193 | (with-error-to-port error-port |
194 | (lambda () | |
bd86bbd3 LC |
195 | (open-bidirectional-pipe |
196 | "guile" | |
197 | "-L" (string-append directory "/share/guile/site/" | |
198 | (effective-version)) | |
199 | "-C" (string-append directory "/share/guile/site/" | |
200 | (effective-version)) | |
201 | "-C" (string-append directory "/lib/guile/" | |
202 | (effective-version) "/site-ccache") | |
203 | "-c" | |
204 | (object->string | |
205 | `(begin | |
206 | (primitive-load ,(search-path %load-path | |
207 | "guix/repl.scm")) | |
208 | ((@ (guix repl) machine-repl)))))))) | |
209 | (values pipe pid)))) | |
2ca299ca | 210 | |
af15fe13 LC |
211 | (define* (port->inferior pipe #:optional (close close-port)) |
212 | "Given PIPE, an input/output port, return an inferior that talks over PIPE. | |
213 | PIPE is closed with CLOSE when 'close-inferior' is called on the returned | |
214 | inferior." | |
a65177a6 | 215 | (setvbuf pipe 'line) |
a81b59b1 | 216 | |
2ca299ca LC |
217 | (match (read pipe) |
218 | (('repl-version 0 rest ...) | |
af15fe13 | 219 | (letrec ((result (inferior 'pipe pipe close (cons 0 rest) |
e1a4ffda | 220 | (delay (%inferior-packages result)) |
10aad721 | 221 | (delay (%inferior-package-table result)) |
bd86bbd3 | 222 | #f))) |
ec0a8661 LC |
223 | |
224 | ;; For protocol (0 1) and later, send the protocol version we support. | |
225 | (match rest | |
226 | ((n _ ...) | |
227 | (when (>= n 1) | |
1dca6aaa | 228 | (send-inferior-request '(() repl-version 0 1 1) result))) |
ec0a8661 LC |
229 | (_ |
230 | #t)) | |
231 | ||
2ca299ca LC |
232 | (inferior-eval '(use-modules (guix)) result) |
233 | (inferior-eval '(use-modules (gnu)) result) | |
6030396a | 234 | (inferior-eval '(use-modules (ice-9 match)) result) |
71507435 | 235 | (inferior-eval '(use-modules (srfi srfi-34)) result) |
2ca299ca LC |
236 | (inferior-eval '(define %package-table (make-hash-table)) |
237 | result) | |
e778910b LC |
238 | (inferior-eval '(begin |
239 | (define %store-table (make-hash-table)) | |
240 | (define (cached-store-connection store-id version) | |
241 | ;; Cache connections to store ID. This ensures that | |
242 | ;; the caches within <store-connection> (in | |
243 | ;; particular the object cache) are reused across | |
244 | ;; calls to 'inferior-eval-with-store', which makes a | |
245 | ;; significant difference when it is called | |
246 | ;; repeatedly. | |
247 | (or (hashv-ref %store-table store-id) | |
248 | ||
249 | ;; 'port->connection' appeared in June 2018 and | |
250 | ;; we can hardly emulate it on older versions. | |
251 | ;; Thus fall back to 'open-connection', at the | |
252 | ;; risk of talking to the wrong daemon or having | |
253 | ;; our build result reclaimed (XXX). | |
254 | (let ((store (if (defined? 'port->connection) | |
255 | (port->connection %bridge-socket | |
256 | #:version | |
257 | version) | |
258 | (open-connection)))) | |
259 | (hashv-set! %store-table store-id store) | |
260 | store)))) | |
261 | result) | |
262 | (inferior-eval '(begin | |
263 | (define store-protocol-error? | |
264 | (if (defined? 'store-protocol-error?) | |
265 | store-protocol-error? | |
266 | nix-protocol-error?)) | |
267 | (define store-protocol-error-message | |
268 | (if (defined? 'store-protocol-error-message) | |
269 | store-protocol-error-message | |
270 | nix-protocol-error-message))) | |
c71910a0 | 271 | result) |
2ca299ca LC |
272 | result)) |
273 | (_ | |
274 | #f))) | |
275 | ||
f0428c18 CB |
276 | (define* (open-inferior directory |
277 | #:key (command "bin/guix") | |
278 | (error-port (%make-void-port "w"))) | |
af15fe13 LC |
279 | "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or |
280 | equivalent. Return #f if the inferior could not be launched." | |
bd86bbd3 LC |
281 | (let ((pipe pid (inferior-pipe directory command error-port))) |
282 | (port->inferior pipe | |
283 | (lambda (port) | |
284 | (close-port port) | |
285 | (waitpid pid))))) | |
af15fe13 | 286 | |
2ca299ca LC |
287 | (define (close-inferior inferior) |
288 | "Close INFERIOR." | |
af15fe13 | 289 | (let ((close (inferior-close-socket inferior))) |
10aad721 LC |
290 | (close (inferior-socket inferior)) |
291 | ||
292 | ;; Close and delete the store bridge, if any. | |
293 | (when (inferior-bridge-socket inferior) | |
bd86bbd3 | 294 | (close-port (inferior-bridge-socket inferior))))) |
2ca299ca LC |
295 | |
296 | ;; Non-self-quoting object of the inferior. | |
297 | (define-record-type <inferior-object> | |
298 | (inferior-object address appearance) | |
299 | inferior-object? | |
300 | (address inferior-object-address) | |
301 | (appearance inferior-object-appearance)) | |
302 | ||
303 | (define (write-inferior-object object port) | |
304 | (match object | |
305 | (($ <inferior-object> _ appearance) | |
306 | (format port "#<inferior-object ~a>" appearance)))) | |
307 | ||
308 | (set-record-type-printer! <inferior-object> write-inferior-object) | |
309 | ||
f7537e30 LC |
310 | ;; Reified exception thrown by an inferior. |
311 | (define-condition-type &inferior-exception &error | |
312 | inferior-exception? | |
313 | (arguments inferior-exception-arguments) ;key + arguments | |
1dca6aaa LC |
314 | (inferior inferior-exception-inferior) ;<inferior> | #f |
315 | (stack inferior-exception-stack)) ;list of (FILE COLUMN LINE) | |
f7537e30 LC |
316 | |
317 | (define* (read-repl-response port #:optional inferior) | |
318 | "Read a (guix repl) response from PORT and return it as a Scheme object. | |
319 | Raise '&inferior-exception' when an exception is read from PORT." | |
2ca299ca LC |
320 | (define sexp->object |
321 | (match-lambda | |
322 | (('value value) | |
323 | value) | |
324 | (('non-self-quoting address string) | |
325 | (inferior-object address string)))) | |
326 | ||
d0ffa321 | 327 | (match (read port) |
2ca299ca LC |
328 | (('values objects ...) |
329 | (apply values (map sexp->object objects))) | |
1dca6aaa LC |
330 | (('exception ('arguments key objects ...) |
331 | ('stack frames ...)) | |
332 | ;; Protocol (0 1 1) and later. | |
333 | (raise (condition (&inferior-exception | |
334 | (arguments (cons key (map sexp->object objects))) | |
335 | (inferior inferior) | |
336 | (stack frames))))) | |
2ca299ca | 337 | (('exception key objects ...) |
1dca6aaa | 338 | ;; Protocol (0 0). |
f7537e30 LC |
339 | (raise (condition (&inferior-exception |
340 | (arguments (cons key (map sexp->object objects))) | |
1dca6aaa LC |
341 | (inferior inferior) |
342 | (stack '()))))))) | |
2ca299ca | 343 | |
d0ffa321 | 344 | (define (read-inferior-response inferior) |
f7537e30 LC |
345 | (read-repl-response (inferior-socket inferior) |
346 | inferior)) | |
d0ffa321 | 347 | |
9daf046c LC |
348 | (define (send-inferior-request exp inferior) |
349 | (write exp (inferior-socket inferior)) | |
350 | (newline (inferior-socket inferior))) | |
351 | ||
352 | (define (inferior-eval exp inferior) | |
353 | "Evaluate EXP in INFERIOR." | |
354 | (send-inferior-request exp inferior) | |
355 | (read-inferior-response inferior)) | |
356 | ||
2ca299ca LC |
357 | \f |
358 | ;;; | |
359 | ;;; Inferior packages. | |
360 | ;;; | |
361 | ||
362 | (define-record-type <inferior-package> | |
363 | (inferior-package inferior name version id) | |
364 | inferior-package? | |
365 | (inferior inferior-package-inferior) | |
366 | (name inferior-package-name) | |
367 | (version inferior-package-version) | |
368 | (id inferior-package-id)) | |
369 | ||
370 | (define (write-inferior-package package port) | |
371 | (match package | |
372 | (($ <inferior-package> _ name version) | |
373 | (format port "#<inferior-package ~a@~a ~a>" | |
374 | name version | |
375 | (number->string (object-address package) 16))))) | |
376 | ||
377 | (set-record-type-printer! <inferior-package> write-inferior-package) | |
378 | ||
e1a4ffda LC |
379 | (define (%inferior-packages inferior) |
380 | "Compute the list of inferior packages from INFERIOR." | |
2ca299ca LC |
381 | (let ((result (inferior-eval |
382 | '(fold-packages (lambda (package result) | |
383 | (let ((id (object-address package))) | |
384 | (hashv-set! %package-table id package) | |
385 | (cons (list (package-name package) | |
386 | (package-version package) | |
387 | id) | |
388 | result))) | |
389 | '()) | |
390 | inferior))) | |
391 | (map (match-lambda | |
392 | ((name version id) | |
393 | (inferior-package inferior name version id))) | |
394 | result))) | |
395 | ||
e1a4ffda LC |
396 | (define (inferior-packages inferior) |
397 | "Return the list of packages known to INFERIOR." | |
398 | (force (inferior-package-promise inferior))) | |
399 | ||
400 | (define (%inferior-package-table inferior) | |
401 | "Compute a package lookup table for INFERIOR." | |
402 | (fold (lambda (package table) | |
403 | (vhash-cons (inferior-package-name package) package | |
404 | table)) | |
405 | vlist-null | |
406 | (inferior-packages inferior))) | |
407 | ||
73938054 LC |
408 | (define (inferior-available-packages inferior) |
409 | "Return the list of name/version pairs corresponding to the set of packages | |
410 | available in INFERIOR. | |
411 | ||
09ab0d42 | 412 | This is faster and less resource-intensive than calling 'inferior-packages'." |
73938054 LC |
413 | (if (inferior-eval '(defined? 'fold-available-packages) |
414 | inferior) | |
415 | (inferior-eval '(fold-available-packages | |
416 | (lambda* (name version result | |
417 | #:key supported? deprecated? | |
418 | #:allow-other-keys) | |
419 | (if (and supported? (not deprecated?)) | |
420 | (acons name version result) | |
421 | result)) | |
422 | '()) | |
423 | inferior) | |
424 | ||
425 | ;; As a last resort, if INFERIOR is old and lacks | |
426 | ;; 'fold-available-packages', fall back to 'inferior-packages'. | |
427 | (map (lambda (package) | |
428 | (cons (inferior-package-name package) | |
429 | (inferior-package-version package))) | |
430 | (inferior-packages inferior)))) | |
431 | ||
e1a4ffda LC |
432 | (define* (lookup-inferior-packages inferior name #:optional version) |
433 | "Return the sorted list of inferior packages matching NAME in INFERIOR, with | |
434 | highest version numbers first. If VERSION is true, return only packages with | |
435 | a version number prefixed by VERSION." | |
436 | ;; This is the counterpart of 'find-packages-by-name'. | |
437 | (sort (filter (lambda (package) | |
438 | (or (not version) | |
439 | (version-prefix? version | |
440 | (inferior-package-version package)))) | |
441 | (vhash-fold* cons '() name | |
442 | (force (inferior-package-table inferior)))) | |
443 | (lambda (p1 p2) | |
444 | (version>? (inferior-package-version p1) | |
445 | (inferior-package-version p2))))) | |
446 | ||
2ca299ca LC |
447 | (define (inferior-package-field package getter) |
448 | "Return the field of PACKAGE, an inferior package, accessed with GETTER." | |
449 | (let ((inferior (inferior-package-inferior package)) | |
450 | (id (inferior-package-id package))) | |
451 | (inferior-eval `(,getter (hashv-ref %package-table ,id)) | |
452 | inferior))) | |
453 | ||
454 | (define* (inferior-package-synopsis package #:key (translate? #t)) | |
455 | "Return the Texinfo synopsis of PACKAGE, an inferior package. When | |
456 | TRANSLATE? is true, translate it to the current locale's language." | |
457 | (inferior-package-field package | |
458 | (if translate? | |
459 | '(compose (@ (guix ui) P_) package-synopsis) | |
460 | 'package-synopsis))) | |
461 | ||
462 | (define* (inferior-package-description package #:key (translate? #t)) | |
463 | "Return the Texinfo description of PACKAGE, an inferior package. When | |
464 | TRANSLATE? is true, translate it to the current locale's language." | |
465 | (inferior-package-field package | |
466 | (if translate? | |
467 | '(compose (@ (guix ui) P_) package-description) | |
468 | 'package-description))) | |
7e1d2290 LC |
469 | |
470 | (define (inferior-package-home-page package) | |
471 | "Return the home page of PACKAGE." | |
472 | (inferior-package-field package 'package-home-page)) | |
473 | ||
474 | (define (inferior-package-location package) | |
475 | "Return the source code location of PACKAGE, either #f or a <location> | |
476 | record." | |
477 | (source-properties->location | |
478 | (inferior-package-field package | |
479 | '(compose (lambda (loc) | |
480 | (and loc | |
481 | (location->source-properties | |
482 | loc))) | |
483 | package-location)))) | |
9daf046c | 484 | |
6030396a LC |
485 | (define (inferior-package-input-field package field) |
486 | "Return the input field FIELD (e.g., 'native-inputs') of PACKAGE, an | |
487 | inferior package." | |
488 | (define field* | |
489 | `(compose (lambda (inputs) | |
490 | (map (match-lambda | |
491 | ;; XXX: Origins are not handled. | |
492 | ((label (? package? package) rest ...) | |
493 | (let ((id (object-address package))) | |
494 | (hashv-set! %package-table id package) | |
495 | `(,label (package ,id | |
496 | ,(package-name package) | |
497 | ,(package-version package)) | |
498 | ,@rest))) | |
499 | (x | |
500 | x)) | |
501 | inputs)) | |
502 | ,field)) | |
503 | ||
504 | (define inputs | |
505 | (inferior-package-field package field*)) | |
506 | ||
507 | (define inferior | |
508 | (inferior-package-inferior package)) | |
509 | ||
510 | (map (match-lambda | |
511 | ((label ('package id name version) . rest) | |
512 | ;; XXX: eq?-ness of inferior packages is not preserved here. | |
513 | `(,label ,(inferior-package inferior name version id) | |
514 | ,@rest)) | |
515 | (x x)) | |
516 | inputs)) | |
517 | ||
518 | (define inferior-package-inputs | |
519 | (cut inferior-package-input-field <> 'package-inputs)) | |
520 | ||
521 | (define inferior-package-native-inputs | |
522 | (cut inferior-package-input-field <> 'package-native-inputs)) | |
523 | ||
524 | (define inferior-package-propagated-inputs | |
525 | (cut inferior-package-input-field <> 'package-propagated-inputs)) | |
526 | ||
527 | (define inferior-package-transitive-propagated-inputs | |
528 | (cut inferior-package-input-field <> 'package-transitive-propagated-inputs)) | |
529 | ||
eee8b303 | 530 | (define (%inferior-package-search-paths package field) |
a130544d | 531 | "Return the list of search path specifications of PACKAGE, an inferior |
eee8b303 LC |
532 | package." |
533 | (define paths | |
534 | (inferior-package-field package | |
535 | `(compose (lambda (paths) | |
536 | (map (@ (guix search-paths) | |
537 | search-path-specification->sexp) | |
538 | paths)) | |
539 | ,field))) | |
540 | ||
541 | (map sexp->search-path-specification paths)) | |
542 | ||
543 | (define inferior-package-native-search-paths | |
544 | (cut %inferior-package-search-paths <> 'package-native-search-paths)) | |
545 | ||
546 | (define inferior-package-search-paths | |
547 | (cut %inferior-package-search-paths <> 'package-search-paths)) | |
548 | ||
549 | (define inferior-package-transitive-native-search-paths | |
550 | (cut %inferior-package-search-paths <> 'package-transitive-native-search-paths)) | |
551 | ||
97d615b1 CB |
552 | (define (inferior-package-replacement package) |
553 | "Return the replacement for PACKAGE. This will either be an inferior | |
554 | package, or #f." | |
555 | (match (inferior-package-field | |
556 | package | |
557 | '(compose (match-lambda | |
558 | ((? package? package) | |
559 | (let ((id (object-address package))) | |
560 | (hashv-set! %package-table id package) | |
561 | (list id | |
562 | (package-name package) | |
563 | (package-version package)))) | |
564 | (#f #f)) | |
565 | package-replacement)) | |
566 | (#f #f) | |
567 | ((id name version) | |
568 | (inferior-package (inferior-package-inferior package) | |
569 | name | |
570 | version | |
571 | id)))) | |
572 | ||
7a241c63 LC |
573 | (define (inferior-package-provenance package) |
574 | "Return a \"provenance sexp\" for PACKAGE, an inferior package. The result | |
575 | is similar to the sexp returned by 'package-provenance' for regular packages." | |
576 | (inferior-package-field package | |
577 | '(let* ((describe | |
578 | (false-if-exception | |
579 | (resolve-interface '(guix describe)))) | |
580 | (provenance | |
581 | (false-if-exception | |
582 | (module-ref describe | |
583 | 'package-provenance)))) | |
584 | (or provenance (const #f))))) | |
585 | ||
bd86bbd3 LC |
586 | (define (proxy inferior store) ;adapted from (guix ssh) |
587 | "Proxy communication between INFERIOR and STORE, until the connection to | |
588 | STORE is closed or INFERIOR has data available for input (a REPL response)." | |
589 | (define client | |
590 | (inferior-bridge-socket inferior)) | |
591 | (define backend | |
592 | (store-connection-socket store)) | |
593 | (define response-port | |
594 | (inferior-socket inferior)) | |
595 | ||
9daf046c LC |
596 | ;; Use buffered ports so that 'get-bytevector-some' returns up to the |
597 | ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>. | |
76832d34 LC |
598 | (setvbuf client 'block 65536) |
599 | (setvbuf backend 'block 65536) | |
9daf046c | 600 | |
bd86bbd3 LC |
601 | ;; RESPONSE-PORT may typically contain a leftover newline that 'read' didn't |
602 | ;; consume. Drain it so that 'select' doesn't immediately stop. | |
603 | (drain-input response-port) | |
604 | ||
9daf046c | 605 | (let loop () |
bd86bbd3 | 606 | (match (select (list client backend response-port) '() '()) |
9daf046c LC |
607 | ((reads () ()) |
608 | (when (memq client reads) | |
609 | (match (get-bytevector-some client) | |
610 | ((? eof-object?) | |
bd86bbd3 | 611 | #t) |
9daf046c LC |
612 | (bv |
613 | (put-bytevector backend bv) | |
614 | (force-output backend)))) | |
615 | (when (memq backend reads) | |
616 | (match (get-bytevector-some backend) | |
617 | (bv | |
618 | (put-bytevector client bv) | |
619 | (force-output client)))) | |
bd86bbd3 LC |
620 | (unless (or (port-closed? client) |
621 | (memq response-port reads)) | |
9daf046c LC |
622 | (loop)))))) |
623 | ||
10aad721 LC |
624 | (define (open-store-bridge! inferior) |
625 | "Open a \"store bridge\" for INFERIOR--a named socket in /tmp that will be | |
626 | used to proxy store RPCs from the inferior to the store of the calling | |
627 | process." | |
628 | ;; Create a named socket in /tmp to let INFERIOR connect to it and use it as | |
629 | ;; its store. This ensures the inferior uses the same store, with the same | |
630 | ;; options, the same per-session GC roots, etc. | |
631 | ;; FIXME: This strategy doesn't work for remote inferiors (SSH). | |
bd86bbd3 LC |
632 | (call-with-temporary-directory |
633 | (lambda (directory) | |
634 | (chmod directory #o700) | |
635 | (let ((name (string-append directory "/inferior")) | |
636 | (socket (socket AF_UNIX SOCK_STREAM 0))) | |
637 | (bind socket AF_UNIX name) | |
638 | (listen socket 2) | |
639 | ||
640 | (send-inferior-request | |
641 | `(define %bridge-socket | |
642 | (let ((socket (socket AF_UNIX SOCK_STREAM 0))) | |
643 | (connect socket AF_UNIX ,name) | |
644 | socket)) | |
645 | inferior) | |
646 | (match (accept socket) | |
647 | ((client . address) | |
648 | (close-port socket) | |
649 | (set-inferior-bridge-socket! inferior client))) | |
650 | (read-inferior-response inferior))))) | |
10aad721 LC |
651 | |
652 | (define (ensure-store-bridge! inferior) | |
653 | "Ensure INFERIOR has a connected bridge." | |
654 | (or (inferior-bridge-socket inferior) | |
655 | (begin | |
656 | (open-store-bridge! inferior) | |
657 | (inferior-bridge-socket inferior)))) | |
658 | ||
94c0e61f LC |
659 | (define (inferior-eval-with-store inferior store code) |
660 | "Evaluate CODE in INFERIOR, passing it STORE as its argument. CODE must | |
661 | thus be the code of a one-argument procedure that accepts a store." | |
10aad721 LC |
662 | (let* ((major (store-connection-major-version store)) |
663 | (minor (store-connection-minor-version store)) | |
c71910a0 LC |
664 | (proto (logior major minor)) |
665 | ||
666 | ;; The address of STORE itself is not a good identifier because it | |
667 | ;; keeps changing through the use of "functional caches". The | |
668 | ;; address of its socket port makes more sense. | |
669 | (store-id (object-address (store-connection-socket store)))) | |
10aad721 LC |
670 | (ensure-store-bridge! inferior) |
671 | (send-inferior-request | |
e778910b LC |
672 | `(let ((proc ,code) |
673 | (store (cached-store-connection ,store-id ,proto))) | |
674 | ;; Serialize '&store-protocol-error' conditions. The exception | |
675 | ;; serialization mechanism that 'read-repl-response' expects is | |
676 | ;; unsuitable for SRFI-35 error conditions, hence this special case. | |
677 | (guard (c ((store-protocol-error? c) | |
678 | `(store-protocol-error | |
679 | ,(store-protocol-error-message c)))) | |
680 | `(result ,(proc store)))) | |
10aad721 | 681 | inferior) |
bd86bbd3 | 682 | (proxy inferior store) |
10aad721 LC |
683 | |
684 | (match (read-inferior-response inferior) | |
685 | (('store-protocol-error message) | |
686 | (raise (condition | |
687 | (&store-protocol-error (message message) | |
688 | (status 1))))) | |
689 | (('result result) | |
690 | result)))) | |
94c0e61f LC |
691 | |
692 | (define* (inferior-package-derivation store package | |
693 | #:optional | |
694 | (system (%current-system)) | |
695 | #:key target) | |
696 | "Return the derivation for PACKAGE, an inferior package, built for SYSTEM | |
697 | and cross-built for TARGET if TARGET is true. The inferior corresponding to | |
698 | PACKAGE must be live." | |
699 | (define proc | |
700 | `(lambda (store) | |
701 | (let* ((package (hashv-ref %package-table | |
702 | ,(inferior-package-id package))) | |
703 | (drv ,(if target | |
704 | `(package-cross-derivation store package | |
705 | ,target | |
706 | ,system) | |
707 | `(package-derivation store package | |
708 | ,system)))) | |
709 | (derivation-file-name drv)))) | |
710 | ||
711 | (and=> (inferior-eval-with-store (inferior-package-inferior package) store | |
712 | proc) | |
713 | read-derivation-from-file)) | |
9daf046c LC |
714 | |
715 | (define inferior-package->derivation | |
716 | (store-lift inferior-package-derivation)) | |
717 | ||
718 | (define-gexp-compiler (package-compiler (package <inferior-package>) system | |
719 | target) | |
720 | ;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET. | |
721 | (inferior-package->derivation package system #:target target)) | |
2e6d64e1 | 722 | |
ae927822 | 723 | (define* (gexp->derivation-in-inferior name exp guix |
4035fcba LC |
724 | #:key silent-failure? |
725 | #:allow-other-keys | |
ae927822 LC |
726 | #:rest rest) |
727 | "Return a derivation that evaluates EXP with GUIX, an instance of Guix as | |
728 | returned for example by 'channel-instances->derivation'. Other arguments are | |
4035fcba LC |
729 | passed as-is to 'gexp->derivation'. |
730 | ||
731 | When SILENT-FAILURE? is true, create an empty output directory instead of | |
732 | failing when GUIX is too old and lacks the 'guix repl' command." | |
1fafc383 LC |
733 | (define script |
734 | ;; EXP wrapped with a proper (set! %load-path …) prologue. | |
735 | (scheme-file "inferior-script.scm" exp)) | |
736 | ||
ae927822 LC |
737 | (define trampoline |
738 | ;; This is a crude way to run EXP on GUIX. TODO: use 'raw-derivation' and | |
739 | ;; make 'guix repl' the "builder"; this will require "opening up" the | |
740 | ;; mechanisms behind 'gexp->derivation', and adding '-l' to 'guix repl'. | |
741 | #~(begin | |
742 | (use-modules (ice-9 popen)) | |
743 | ||
744 | (let ((pipe (open-pipe* OPEN_WRITE | |
745 | #+(file-append guix "/bin/guix") | |
746 | "repl" "-t" "machine"))) | |
1fafc383 LC |
747 | |
748 | ;; XXX: EXP presumably refers to #$output but that reference is lost | |
749 | ;; so explicitly reference it here. | |
750 | #$output | |
751 | ||
752 | (write `(primitive-load #$script) pipe) | |
ae927822 LC |
753 | |
754 | (unless (zero? (close-pipe pipe)) | |
4035fcba LC |
755 | (if #$silent-failure? |
756 | (mkdir #$output) | |
757 | (error "inferior failed" #+guix)))))) | |
758 | ||
759 | (define (drop-extra-keyword lst) | |
760 | (let loop ((lst lst) | |
761 | (result '())) | |
762 | (match lst | |
763 | (() | |
764 | (reverse result)) | |
765 | ((#:silent-failure? _ . rest) | |
766 | (loop rest result)) | |
767 | ((kw value . tail) | |
768 | (loop tail (cons* value kw result)))))) | |
769 | ||
770 | (apply gexp->derivation name trampoline | |
771 | (drop-extra-keyword rest))) | |
ae927822 | 772 | |
2e6d64e1 LC |
773 | \f |
774 | ;;; | |
775 | ;;; Manifest entries. | |
776 | ;;; | |
777 | ||
778 | (define* (inferior-package->manifest-entry package | |
779 | #:optional (output "out") | |
0f20b3fa | 780 | #:key (properties '())) |
2e6d64e1 | 781 | "Return a manifest entry for the OUTPUT of package PACKAGE." |
0f20b3fa LC |
782 | (define cache |
783 | (make-hash-table)) | |
784 | ||
785 | (define-syntax-rule (memoized package output exp) | |
786 | ;; Memoize the entry returned by EXP for PACKAGE/OUTPUT. This is | |
787 | ;; important as the same package may be traversed many times through | |
788 | ;; propagated inputs, and querying the inferior is costly. Use | |
789 | ;; 'hash'/'equal?', which is okay since <inferior-package> is simple. | |
790 | (let ((compute (lambda () exp)) | |
791 | (key (cons package output))) | |
792 | (or (hash-ref cache key) | |
793 | (let ((result (compute))) | |
794 | (hash-set! cache key result) | |
795 | result)))) | |
796 | ||
797 | (let loop ((package package) | |
798 | (output output) | |
799 | (parent (delay #f))) | |
800 | (memoized package output | |
801 | ;; For each dependency, keep a promise pointing to its "parent" entry. | |
802 | (letrec* ((deps (map (match-lambda | |
803 | ((label package) | |
804 | (loop package "out" (delay entry))) | |
805 | ((label package output) | |
806 | (loop package output (delay entry)))) | |
807 | (inferior-package-propagated-inputs package))) | |
808 | (entry (manifest-entry | |
809 | (name (inferior-package-name package)) | |
810 | (version (inferior-package-version package)) | |
811 | (output output) | |
812 | (item package) | |
813 | (dependencies (delete-duplicates deps)) | |
814 | (search-paths | |
815 | (inferior-package-transitive-native-search-paths package)) | |
816 | (parent parent) | |
817 | (properties properties)))) | |
818 | entry)))) | |
2dad0313 LC |
819 | |
820 | \f | |
821 | ;;; | |
822 | ;;; Cached inferiors. | |
823 | ;;; | |
824 | ||
825 | (define %inferior-cache-directory | |
826 | ;; Directory for cached inferiors (GC roots). | |
827 | (make-parameter (string-append (cache-directory #:ensure? #f) | |
828 | "/inferiors"))) | |
829 | ||
7cfd7891 LC |
830 | (define (channel-full-commit channel) |
831 | "Return the commit designated by CHANNEL as quickly as possible. If | |
832 | CHANNEL's 'commit' field is a full SHA1, return it as-is; if it's a SHA1 | |
833 | prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip." | |
834 | (let ((commit (channel-commit channel)) | |
835 | (branch (channel-branch channel))) | |
836 | (if (and commit (= (string-length commit) 40)) | |
837 | commit | |
838 | (let* ((ref (if commit `(commit . ,commit) `(branch . ,branch))) | |
839 | (cache commit relation | |
840 | (update-cached-checkout (channel-url channel) | |
841 | #:ref ref | |
842 | #:check-out? #f))) | |
843 | commit)))) | |
844 | ||
8898eaec MO |
845 | (define* (cached-channel-instance store |
846 | channels | |
847 | #:key | |
848 | (authenticate? #t) | |
849 | (cache-directory (%inferior-cache-directory)) | |
850 | (ttl (* 3600 24 30))) | |
851 | "Return a directory containing a guix filetree defined by CHANNELS, a list of channels. | |
852 | The directory is a subdirectory of CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds. | |
853 | This procedure opens a new connection to the build daemon. AUTHENTICATE? | |
854 | determines whether CHANNELS are authenticated." | |
855 | (define commits | |
856 | ;; Since computing the instances of CHANNELS is I/O-intensive, use a | |
857 | ;; cheaper way to get the commit list of CHANNELS. This limits overhead | |
858 | ;; to the minimum in case of a cache hit. | |
859 | (map channel-full-commit channels)) | |
860 | ||
1d548569 KH |
861 | (define key |
862 | (bytevector->base32-string | |
863 | (sha256 | |
7cfd7891 | 864 | (string->utf8 (string-concatenate commits))))) |
1d548569 KH |
865 | |
866 | (define cached | |
867 | (string-append cache-directory "/" key)) | |
868 | ||
869 | (define (base32-encoded-sha256? str) | |
870 | (= (string-length str) 52)) | |
871 | ||
872 | (define (cache-entries directory) | |
873 | (map (lambda (file) | |
874 | (string-append directory "/" file)) | |
875 | (scandir directory base32-encoded-sha256?))) | |
876 | ||
a831ff6b MO |
877 | (define (symlink/safe old new) |
878 | (catch 'system-error | |
879 | (lambda () | |
880 | (symlink old new)) | |
881 | (lambda args | |
882 | (unless (= EEXIST (system-error-errno args)) | |
883 | (apply throw args))))) | |
884 | ||
1d548569 | 885 | (define symlink* |
a831ff6b | 886 | (lift2 symlink/safe %store-monad)) |
1d548569 KH |
887 | |
888 | (define add-indirect-root* | |
889 | (store-lift add-indirect-root)) | |
890 | ||
9f371f23 LC |
891 | (define add-temp-root* |
892 | (store-lift add-temp-root)) | |
893 | ||
1d548569 KH |
894 | (mkdir-p cache-directory) |
895 | (maybe-remove-expired-cache-entries cache-directory | |
896 | cache-entries | |
897 | #:entry-expiration | |
898 | (file-expiration-time ttl)) | |
899 | ||
900 | (if (file-exists? cached) | |
901 | cached | |
902 | (run-with-store store | |
8898eaec MO |
903 | (mlet* %store-monad ((instances |
904 | -> (latest-channel-instances store channels | |
905 | #:authenticate? | |
906 | authenticate?)) | |
907 | (profile | |
908 | (channel-instances->derivation instances))) | |
1d548569 | 909 | (mbegin %store-monad |
7bd5f729 LC |
910 | ;; It's up to the caller to install a build handler to report |
911 | ;; what's going to be built. | |
1d548569 | 912 | (built-derivations (list profile)) |
7bd5f729 | 913 | |
9f371f23 LC |
914 | ;; Cache if and only if AUTHENTICATE? is true. |
915 | (if authenticate? | |
916 | (mbegin %store-monad | |
917 | (symlink* (derivation->output-path profile) cached) | |
918 | (add-indirect-root* cached) | |
919 | (return cached)) | |
920 | (mbegin %store-monad | |
b1fc98d6 | 921 | (add-temp-root* (derivation->output-path profile)) |
a9cc79d9 | 922 | (return (derivation->output-path profile))))))))) |
f675f8de KH |
923 | |
924 | (define* (inferior-for-channels channels | |
925 | #:key | |
926 | (cache-directory (%inferior-cache-directory)) | |
927 | (ttl (* 3600 24 30))) | |
928 | "Return an inferior for CHANNELS, a list of channels. Use the cache at | |
929 | CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds. This | |
930 | procedure opens a new connection to the build daemon. | |
931 | ||
932 | This is a convenience procedure that people may use in manifests passed to | |
933 | 'guix package -m', for instance." | |
934 | (define cached | |
1d548569 | 935 | (with-store store |
7bd5f729 LC |
936 | ;; XXX: Install a build notifier out of convenience, so users know |
937 | ;; what's going on. However, we cannot be sure that its options, such | |
938 | ;; as #:use-substitutes?, correspond to the daemon's default settings. | |
939 | (with-build-handler (build-notifier) | |
940 | (cached-channel-instance store | |
941 | channels | |
942 | #:cache-directory cache-directory | |
943 | #:ttl ttl)))) | |
f675f8de | 944 | (open-inferior cached)) |
0f20b3fa LC |
945 | |
946 | ;;; Local Variables: | |
947 | ;;; eval: (put 'memoized 'scheme-indent-function 1) | |
948 | ;;; End: |