Commit | Line | Data |
---|---|---|
457f60fa | 1 | ;;; GNU Guix --- Functional package management for GNU |
056b5cef | 2 | ;;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com> |
457f60fa AK |
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 | ;;; Commentary: | |
20 | ||
21 | ;; Information about packages and generations is passed to the elisp | |
22 | ;; side in the form of alists of parameters (such as ‘name’ or | |
81b339fe | 23 | ;; ‘version’) and their values. |
457f60fa | 24 | |
81b339fe | 25 | ;; ‘entries’ procedure is the “entry point” for the elisp side to get |
457f60fa AK |
26 | ;; information about packages and generations. |
27 | ||
28 | ;; Since name/version pair is not necessarily unique, we use | |
29 | ;; `object-address' to identify a package (for ‘id’ parameter), if | |
30 | ;; possible. However for the obsolete packages (that can be found in | |
31 | ;; installed manifest but not in a package directory), ‘id’ parameter is | |
32 | ;; still "name-version" string. So ‘id’ package parameter in the code | |
33 | ;; below is either an object-address number or a full-name string. | |
457f60fa AK |
34 | |
35 | ;; To speed-up the process of getting information, the following | |
36 | ;; auxiliary variables are used: | |
37 | ;; | |
38 | ;; - `%packages' - VHash of "package address"/"package" pairs. | |
39 | ;; | |
40 | ;; - `%package-table' - Hash table of | |
41 | ;; "name+version key"/"list of packages" pairs. | |
457f60fa AK |
42 | |
43 | ;;; Code: | |
44 | ||
45 | (use-modules | |
46 | (ice-9 vlist) | |
47 | (ice-9 match) | |
8b9ceb8d | 48 | (ice-9 popen) |
457f60fa | 49 | (srfi srfi-1) |
0b0fbf0c | 50 | (srfi srfi-2) |
457f60fa AK |
51 | (srfi srfi-11) |
52 | (srfi srfi-19) | |
53 | (srfi srfi-26) | |
54 | (guix) | |
0b0fbf0c | 55 | (guix git-download) |
457f60fa AK |
56 | (guix packages) |
57 | (guix profiles) | |
58 | (guix licenses) | |
59 | (guix utils) | |
60 | (guix ui) | |
43b40c4b | 61 | (guix scripts graph) |
056b5cef | 62 | (guix scripts lint) |
457f60fa | 63 | (guix scripts package) |
2d7bf949 | 64 | (guix scripts pull) |
457f60fa AK |
65 | (gnu packages)) |
66 | ||
67 | (define-syntax-rule (first-or-false lst) | |
68 | (and (not (null? lst)) | |
69 | (first lst))) | |
70 | ||
81b339fe AK |
71 | (define (list-maybe obj) |
72 | (if (list? obj) obj (list obj))) | |
73 | ||
457f60fa AK |
74 | (define full-name->name+version package-name->name+version) |
75 | (define (name+version->full-name name version) | |
76 | (string-append name "-" version)) | |
77 | ||
78 | (define* (make-package-specification name #:optional version output) | |
79 | (let ((full-name (if version | |
80 | (name+version->full-name name version) | |
81 | name))) | |
82 | (if output | |
83 | (string-append full-name ":" output) | |
84 | full-name))) | |
85 | ||
86 | (define name+version->key cons) | |
87 | (define key->name+version car+cdr) | |
88 | ||
457f60fa AK |
89 | (define %packages |
90 | (fold-packages (lambda (pkg res) | |
91 | (vhash-consq (object-address pkg) pkg res)) | |
92 | vlist-null)) | |
93 | ||
94 | (define %package-table | |
95 | (let ((table (make-hash-table (vlist-length %packages)))) | |
96 | (vlist-for-each | |
97 | (lambda (elem) | |
98 | (match elem | |
99 | ((address . pkg) | |
100 | (let* ((key (name+version->key (package-name pkg) | |
101 | (package-version pkg))) | |
102 | (ref (hash-ref table key))) | |
103 | (hash-set! table key | |
104 | (if ref (cons pkg ref) (list pkg))))))) | |
105 | %packages) | |
106 | table)) | |
107 | ||
81b339fe AK |
108 | (define (manifest-entry->name+version+output entry) |
109 | (values | |
110 | (manifest-entry-name entry) | |
111 | (manifest-entry-version entry) | |
112 | (manifest-entry-output entry))) | |
113 | ||
d38bd08c AK |
114 | (define (manifest-entry->package-specification entry) |
115 | (call-with-values | |
116 | (lambda () (manifest-entry->name+version+output entry)) | |
117 | make-package-specification)) | |
118 | ||
119 | (define (manifest-entries->package-specifications entries) | |
120 | (map manifest-entry->package-specification entries)) | |
121 | ||
122 | (define (generation-package-specifications profile number) | |
123 | "Return a list of package specifications for generation NUMBER." | |
124 | (let ((manifest (profile-manifest | |
125 | (generation-file-name profile number)))) | |
126 | (manifest-entries->package-specifications | |
127 | (manifest-entries manifest)))) | |
128 | ||
129 | (define (generation-package-specifications+paths profile number) | |
130 | "Return a list of package specifications and paths for generation NUMBER. | |
131 | Each element of the list is a list of the package specification and its path." | |
132 | (let ((manifest (profile-manifest | |
133 | (generation-file-name profile number)))) | |
134 | (map (lambda (entry) | |
135 | (list (manifest-entry->package-specification entry) | |
136 | (manifest-entry-item entry))) | |
137 | (manifest-entries manifest)))) | |
138 | ||
139 | (define (generation-difference profile number1 number2) | |
140 | "Return a list of package specifications for outputs installed in generation | |
141 | NUMBER1 and not installed in generation NUMBER2." | |
142 | (let ((specs1 (generation-package-specifications profile number1)) | |
143 | (specs2 (generation-package-specifications profile number2))) | |
144 | (lset-difference string=? specs1 specs2))) | |
145 | ||
81b339fe AK |
146 | (define (manifest-entries->hash-table entries) |
147 | "Return a hash table of name keys and lists of matching manifest ENTRIES." | |
148 | (let ((table (make-hash-table (length entries)))) | |
149 | (for-each (lambda (entry) | |
150 | (let* ((key (manifest-entry-name entry)) | |
151 | (ref (hash-ref table key))) | |
152 | (hash-set! table key | |
153 | (if ref (cons entry ref) (list entry))))) | |
154 | entries) | |
155 | table)) | |
457f60fa | 156 | |
81b339fe AK |
157 | (define (manifest=? m1 m2) |
158 | (or (eq? m1 m2) | |
159 | (equal? m1 m2))) | |
160 | ||
161 | (define manifest->hash-table | |
162 | (let ((current-manifest #f) | |
163 | (current-table #f)) | |
164 | (lambda (manifest) | |
165 | "Return a hash table of name keys and matching MANIFEST entries." | |
166 | (unless (manifest=? manifest current-manifest) | |
167 | (set! current-manifest manifest) | |
168 | (set! current-table (manifest-entries->hash-table | |
169 | (manifest-entries manifest)))) | |
170 | current-table))) | |
171 | ||
172 | (define* (manifest-entries-by-name manifest name #:optional version output) | |
173 | "Return a list of MANIFEST entries matching NAME, VERSION and OUTPUT." | |
174 | (let ((entries (or (hash-ref (manifest->hash-table manifest) name) | |
175 | '()))) | |
176 | (if (or version output) | |
177 | (filter (lambda (entry) | |
178 | (and (or (not version) | |
179 | (equal? version (manifest-entry-version entry))) | |
180 | (or (not output) | |
181 | (equal? output (manifest-entry-output entry))))) | |
182 | entries) | |
183 | entries))) | |
184 | ||
185 | (define (manifest-entry-by-output entries output) | |
186 | "Return a manifest entry from ENTRIES matching OUTPUT." | |
187 | (find (lambda (entry) | |
188 | (string= output (manifest-entry-output entry))) | |
189 | entries)) | |
190 | ||
191 | (define (fold-manifest-by-name manifest proc init) | |
192 | "Fold over MANIFEST entries. | |
193 | Call (PROC NAME VERSION ENTRIES RESULT), using INIT as the initial value | |
194 | of RESULT. ENTRIES is a list of manifest entries with NAME/VERSION." | |
195 | (hash-fold (lambda (name entries res) | |
196 | (proc name (manifest-entry-version (car entries)) | |
197 | entries res)) | |
457f60fa | 198 | init |
81b339fe | 199 | (manifest->hash-table manifest))) |
457f60fa AK |
200 | |
201 | (define* (object-transformer param-alist #:optional (params '())) | |
81b339fe | 202 | "Return procedure transforming objects into alist of parameter/value pairs. |
457f60fa | 203 | |
81b339fe AK |
204 | PARAM-ALIST is alist of available parameters (symbols) and procedures |
205 | returning values of these parameters. Each procedure is applied to | |
206 | objects. | |
457f60fa | 207 | |
81b339fe AK |
208 | PARAMS is list of parameters from PARAM-ALIST that should be returned by |
209 | a resulting procedure. If PARAMS is not specified or is an empty list, | |
210 | use all available parameters. | |
457f60fa AK |
211 | |
212 | Example: | |
213 | ||
81b339fe AK |
214 | (let* ((alist `((plus1 . ,1+) (minus1 . ,1-) (mul2 . ,(cut * 2 <>)))) |
215 | (number->alist (object-transformer alist '(plus1 mul2)))) | |
457f60fa AK |
216 | (number->alist 8)) |
217 | => | |
218 | ((plus1 . 9) (mul2 . 16)) | |
219 | " | |
81b339fe AK |
220 | (let* ((use-all-params (null? params)) |
221 | (alist (filter-map (match-lambda | |
222 | ((param . proc) | |
223 | (and (or use-all-params | |
224 | (memq param params)) | |
225 | (cons param proc))) | |
226 | (_ #f)) | |
227 | param-alist))) | |
228 | (lambda objects | |
457f60fa | 229 | (map (match-lambda |
81b339fe AK |
230 | ((param . proc) |
231 | (cons param (apply proc objects)))) | |
457f60fa AK |
232 | alist)))) |
233 | ||
81b339fe AK |
234 | (define %manifest-entry-param-alist |
235 | `((output . ,manifest-entry-output) | |
236 | (path . ,manifest-entry-item) | |
237 | (dependencies . ,manifest-entry-dependencies))) | |
457f60fa | 238 | |
81b339fe AK |
239 | (define manifest-entry->sexp |
240 | (object-transformer %manifest-entry-param-alist)) | |
457f60fa | 241 | |
81b339fe AK |
242 | (define (manifest-entries->sexps entries) |
243 | (map manifest-entry->sexp entries)) | |
457f60fa AK |
244 | |
245 | (define (package-inputs-names inputs) | |
81b339fe | 246 | "Return a list of full names of the packages from package INPUTS." |
457f60fa AK |
247 | (filter-map (match-lambda |
248 | ((_ (? package? package)) | |
249 | (package-full-name package)) | |
250 | (_ #f)) | |
251 | inputs)) | |
252 | ||
253 | (define (package-license-names package) | |
81b339fe AK |
254 | "Return a list of license names of the PACKAGE." |
255 | (filter-map (lambda (license) | |
256 | (and (license? license) | |
257 | (license-name license))) | |
258 | (list-maybe (package-license package)))) | |
457f60fa | 259 | |
0b0fbf0c AK |
260 | (define (package-source-names package) |
261 | "Return a list of source names (URLs) of the PACKAGE." | |
262 | (let ((source (package-source package))) | |
263 | (and (origin? source) | |
264 | (filter-map (lambda (uri) | |
265 | (cond ((string? uri) | |
266 | uri) | |
267 | ((git-reference? uri) | |
268 | (git-reference-url uri)) | |
269 | (else "Unknown source type"))) | |
270 | (list-maybe (origin-uri source)))))) | |
271 | ||
457f60fa AK |
272 | (define (package-unique? package) |
273 | "Return #t if PACKAGE is a single package with such name/version." | |
81b339fe AK |
274 | (null? (cdr (packages-by-name (package-name package) |
275 | (package-version package))))) | |
276 | ||
277 | (define %package-param-alist | |
278 | `((id . ,object-address) | |
279 | (package-id . ,object-address) | |
280 | (name . ,package-name) | |
281 | (version . ,package-version) | |
282 | (license . ,package-license-names) | |
0b0fbf0c | 283 | (source . ,package-source-names) |
81b339fe AK |
284 | (synopsis . ,package-synopsis) |
285 | (description . ,package-description) | |
286 | (home-url . ,package-home-page) | |
287 | (outputs . ,package-outputs) | |
288 | (non-unique . ,(negate package-unique?)) | |
289 | (inputs . ,(lambda (pkg) | |
290 | (package-inputs-names | |
291 | (package-inputs pkg)))) | |
292 | (native-inputs . ,(lambda (pkg) | |
293 | (package-inputs-names | |
294 | (package-native-inputs pkg)))) | |
295 | (propagated-inputs . ,(lambda (pkg) | |
296 | (package-inputs-names | |
297 | (package-propagated-inputs pkg)))) | |
298 | (location . ,(lambda (pkg) | |
299 | (location->string (package-location pkg)))))) | |
457f60fa AK |
300 | |
301 | (define (package-param package param) | |
81b339fe AK |
302 | "Return a value of a PACKAGE PARAM." |
303 | (and=> (assq-ref %package-param-alist param) | |
457f60fa AK |
304 | (cut <> package))) |
305 | ||
81b339fe AK |
306 | \f |
307 | ;;; Finding packages. | |
308 | ||
309 | (define (package-by-address address) | |
310 | (and=> (vhash-assq address %packages) | |
311 | cdr)) | |
312 | ||
313 | (define (packages-by-name+version name version) | |
314 | (or (hash-ref %package-table | |
315 | (name+version->key name version)) | |
316 | '())) | |
317 | ||
318 | (define (packages-by-full-name full-name) | |
319 | (call-with-values | |
320 | (lambda () (full-name->name+version full-name)) | |
321 | packages-by-name+version)) | |
322 | ||
323 | (define (packages-by-id id) | |
324 | (if (integer? id) | |
325 | (let ((pkg (package-by-address id))) | |
326 | (if pkg (list pkg) '())) | |
327 | (packages-by-full-name id))) | |
328 | ||
329 | (define (id->name+version id) | |
330 | (if (integer? id) | |
331 | (and=> (package-by-address id) | |
332 | (lambda (pkg) | |
333 | (values (package-name pkg) | |
334 | (package-version pkg)))) | |
335 | (full-name->name+version id))) | |
336 | ||
337 | (define (package-by-id id) | |
338 | (first-or-false (packages-by-id id))) | |
339 | ||
340 | (define (newest-package-by-id id) | |
341 | (and=> (id->name+version id) | |
342 | (lambda (name) | |
343 | (first-or-false (find-best-packages-by-name name #f))))) | |
344 | ||
345 | (define (matching-packages predicate) | |
457f60fa AK |
346 | (fold-packages (lambda (pkg res) |
347 | (if (predicate pkg) | |
81b339fe | 348 | (cons pkg res) |
457f60fa AK |
349 | res)) |
350 | '())) | |
351 | ||
81b339fe AK |
352 | (define (filter-packages-by-output packages output) |
353 | (filter (lambda (package) | |
354 | (member output (package-outputs package))) | |
355 | packages)) | |
356 | ||
357 | (define* (packages-by-name name #:optional version output) | |
358 | "Return a list of packages matching NAME, VERSION and OUTPUT." | |
359 | (let ((packages (if version | |
360 | (packages-by-name+version name version) | |
361 | (matching-packages | |
362 | (lambda (pkg) (string=? name (package-name pkg))))))) | |
363 | (if output | |
364 | (filter-packages-by-output packages output) | |
365 | packages))) | |
457f60fa | 366 | |
81b339fe AK |
367 | (define (manifest-entry->packages entry) |
368 | (call-with-values | |
369 | (lambda () (manifest-entry->name+version+output entry)) | |
370 | packages-by-name)) | |
457f60fa | 371 | |
81b339fe AK |
372 | (define (packages-by-regexp regexp match-params) |
373 | "Return a list of packages matching REGEXP string. | |
457f60fa AK |
374 | MATCH-PARAMS is a list of parameters that REGEXP can match." |
375 | (define (package-match? package regexp) | |
376 | (any (lambda (param) | |
377 | (let ((val (package-param package param))) | |
378 | (and (string? val) (regexp-exec regexp val)))) | |
379 | match-params)) | |
380 | ||
457f60fa | 381 | (let ((re (make-regexp regexp regexp/icase))) |
81b339fe AK |
382 | (matching-packages (cut package-match? <> re)))) |
383 | ||
384 | (define (all-available-packages) | |
385 | "Return a list of all available packages." | |
386 | (matching-packages (const #t))) | |
387 | ||
388 | (define (newest-available-packages) | |
389 | "Return a list of the newest available packages." | |
457f60fa AK |
390 | (vhash-fold (lambda (name elem res) |
391 | (match elem | |
81b339fe AK |
392 | ((_ newest pkgs ...) |
393 | (cons newest res)))) | |
457f60fa AK |
394 | '() |
395 | (find-newest-available-packages))) | |
396 | ||
81b339fe AK |
397 | \f |
398 | ;;; Making package/output patterns. | |
399 | ||
400 | (define (specification->package-pattern specification) | |
401 | (call-with-values | |
402 | (lambda () | |
403 | (full-name->name+version specification)) | |
404 | list)) | |
457f60fa | 405 | |
81b339fe AK |
406 | (define (specification->output-pattern specification) |
407 | (call-with-values | |
408 | (lambda () | |
409 | (package-specification->name+version+output specification #f)) | |
410 | list)) | |
457f60fa | 411 | |
81b339fe AK |
412 | (define (id->package-pattern id) |
413 | (if (integer? id) | |
414 | (package-by-address id) | |
415 | (specification->package-pattern id))) | |
416 | ||
417 | (define (id->output-pattern id) | |
418 | "Return an output pattern by output ID. | |
419 | ID should be '<package-address>:<output>' or '<name>-<version>:<output>'." | |
420 | (let-values (((name version output) | |
421 | (package-specification->name+version+output id))) | |
422 | (if version | |
423 | (list name version output) | |
424 | (list (package-by-address (string->number name)) | |
425 | output)))) | |
426 | ||
427 | (define (specifications->package-patterns . specifications) | |
428 | (map specification->package-pattern specifications)) | |
429 | ||
430 | (define (specifications->output-patterns . specifications) | |
431 | (map specification->output-pattern specifications)) | |
432 | ||
433 | (define (ids->package-patterns . ids) | |
434 | (map id->package-pattern ids)) | |
435 | ||
436 | (define (ids->output-patterns . ids) | |
437 | (map id->output-pattern ids)) | |
438 | ||
439 | (define* (manifest-patterns-result packages res obsolete-pattern | |
440 | #:optional installed-pattern) | |
441 | "Auxiliary procedure for 'manifest-package-patterns' and | |
442 | 'manifest-output-patterns'." | |
443 | (if (null? packages) | |
444 | (cons (obsolete-pattern) res) | |
445 | (if installed-pattern | |
446 | ;; We don't need duplicates for a list of installed packages, | |
447 | ;; so just take any (car) package. | |
448 | (cons (installed-pattern (car packages)) res) | |
449 | res))) | |
450 | ||
451 | (define* (manifest-package-patterns manifest #:optional obsolete-only?) | |
452 | "Return a list of package patterns for MANIFEST entries. | |
453 | If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only | |
454 | for obsolete packages." | |
455 | (fold-manifest-by-name | |
456 | manifest | |
457f60fa | 457 | (lambda (name version entries res) |
81b339fe AK |
458 | (manifest-patterns-result (packages-by-name name version) |
459 | res | |
460 | (lambda () (list name version entries)) | |
461 | (and (not obsolete-only?) | |
462 | (cut list <> entries)))) | |
457f60fa AK |
463 | '())) |
464 | ||
81b339fe AK |
465 | (define* (manifest-output-patterns manifest #:optional obsolete-only?) |
466 | "Return a list of output patterns for MANIFEST entries. | |
467 | If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only | |
468 | for obsolete packages." | |
469 | (fold (lambda (entry res) | |
470 | (manifest-patterns-result (manifest-entry->packages entry) | |
471 | res | |
472 | (lambda () entry) | |
473 | (and (not obsolete-only?) | |
474 | (cut list <> entry)))) | |
475 | '() | |
476 | (manifest-entries manifest))) | |
477 | ||
478 | (define (obsolete-package-patterns manifest) | |
479 | (manifest-package-patterns manifest #t)) | |
480 | ||
481 | (define (obsolete-output-patterns manifest) | |
482 | (manifest-output-patterns manifest #t)) | |
483 | ||
457f60fa | 484 | \f |
81b339fe | 485 | ;;; Transforming package/output patterns into alists. |
457f60fa | 486 | |
81b339fe AK |
487 | (define (obsolete-package-sexp name version entries) |
488 | "Return an alist with information about obsolete package. | |
489 | ENTRIES is a list of installed manifest entries." | |
490 | `((id . ,(name+version->full-name name version)) | |
491 | (name . ,name) | |
492 | (version . ,version) | |
493 | (outputs . ,(map manifest-entry-output entries)) | |
494 | (obsolete . #t) | |
495 | (installed . ,(manifest-entries->sexps entries)))) | |
496 | ||
497 | (define (package-pattern-transformer manifest params) | |
498 | "Return 'package-pattern->package-sexps' procedure." | |
499 | (define package->sexp | |
500 | (object-transformer %package-param-alist params)) | |
501 | ||
502 | (define* (sexp-by-package package #:optional | |
503 | (entries (manifest-entries-by-name | |
504 | manifest | |
505 | (package-name package) | |
506 | (package-version package)))) | |
507 | (cons (cons 'installed (manifest-entries->sexps entries)) | |
508 | (package->sexp package))) | |
509 | ||
510 | (define (->sexps pattern) | |
511 | (match pattern | |
512 | ((? package? package) | |
513 | (list (sexp-by-package package))) | |
514 | (((? package? package) entries) | |
515 | (list (sexp-by-package package entries))) | |
516 | ((name version entries) | |
517 | (list (obsolete-package-sexp | |
518 | name version entries))) | |
519 | ((name version) | |
520 | (let ((packages (packages-by-name name version))) | |
521 | (if (null? packages) | |
522 | (let ((entries (manifest-entries-by-name | |
523 | manifest name version))) | |
524 | (if (null? entries) | |
525 | '() | |
526 | (list (obsolete-package-sexp | |
527 | name version entries)))) | |
ce8b2953 AK |
528 | (map sexp-by-package packages)))) |
529 | (_ '()))) | |
81b339fe AK |
530 | |
531 | ->sexps) | |
532 | ||
533 | (define (output-pattern-transformer manifest params) | |
534 | "Return 'output-pattern->output-sexps' procedure." | |
535 | (define package->sexp | |
536 | (object-transformer (alist-delete 'id %package-param-alist) | |
537 | params)) | |
538 | ||
539 | (define manifest-entry->sexp | |
540 | (object-transformer (alist-delete 'output %manifest-entry-param-alist) | |
541 | params)) | |
542 | ||
543 | (define* (output-sexp pkg-alist pkg-address output | |
544 | #:optional entry) | |
545 | (let ((entry-alist (if entry | |
546 | (manifest-entry->sexp entry) | |
547 | '())) | |
548 | (base `((id . ,(string-append | |
549 | (number->string pkg-address) | |
550 | ":" output)) | |
551 | (output . ,output) | |
552 | (installed . ,(->bool entry))))) | |
553 | (append entry-alist base pkg-alist))) | |
554 | ||
555 | (define (obsolete-output-sexp entry) | |
556 | (let-values (((name version output) | |
557 | (manifest-entry->name+version+output entry))) | |
558 | (let ((base `((id . ,(make-package-specification | |
559 | name version output)) | |
560 | (package-id . ,(name+version->full-name name version)) | |
561 | (name . ,name) | |
562 | (version . ,version) | |
563 | (output . ,output) | |
564 | (obsolete . #t) | |
565 | (installed . #t)))) | |
566 | (append (manifest-entry->sexp entry) base)))) | |
567 | ||
568 | (define* (sexps-by-package package #:optional output | |
569 | (entries (manifest-entries-by-name | |
570 | manifest | |
571 | (package-name package) | |
572 | (package-version package)))) | |
573 | ;; Assuming that PACKAGE has this OUTPUT. | |
574 | (let ((pkg-alist (package->sexp package)) | |
575 | (address (object-address package)) | |
576 | (outputs (if output | |
577 | (list output) | |
578 | (package-outputs package)))) | |
579 | (map (lambda (output) | |
580 | (output-sexp pkg-alist address output | |
581 | (manifest-entry-by-output entries output))) | |
582 | outputs))) | |
583 | ||
584 | (define* (sexps-by-manifest-entry entry #:optional | |
585 | (packages (manifest-entry->packages | |
586 | entry))) | |
587 | (if (null? packages) | |
588 | (list (obsolete-output-sexp entry)) | |
589 | (map (lambda (package) | |
590 | (output-sexp (package->sexp package) | |
591 | (object-address package) | |
592 | (manifest-entry-output entry) | |
593 | entry)) | |
594 | packages))) | |
595 | ||
596 | (define (->sexps pattern) | |
597 | (match pattern | |
598 | ((? package? package) | |
599 | (sexps-by-package package)) | |
600 | ((package (? string? output)) | |
601 | (sexps-by-package package output)) | |
602 | ((? manifest-entry? entry) | |
603 | (list (obsolete-output-sexp entry))) | |
604 | ((package entry) | |
605 | (sexps-by-manifest-entry entry (list package))) | |
606 | ((name version output) | |
607 | (let ((packages (packages-by-name name version output))) | |
608 | (if (null? packages) | |
609 | (let ((entries (manifest-entries-by-name | |
610 | manifest name version output))) | |
611 | (append-map (cut sexps-by-manifest-entry <>) | |
612 | entries)) | |
613 | (append-map (cut sexps-by-package <> output) | |
ce8b2953 AK |
614 | packages)))) |
615 | (_ '()))) | |
81b339fe AK |
616 | |
617 | ->sexps) | |
618 | ||
619 | (define (entry-type-error entry-type) | |
620 | (error (format #f "Wrong entry-type '~a'" entry-type))) | |
621 | ||
622 | (define (search-type-error entry-type search-type) | |
623 | (error (format #f "Wrong search type '~a' for entry-type '~a'" | |
624 | search-type entry-type))) | |
625 | ||
626 | (define %pattern-transformers | |
627 | `((package . ,package-pattern-transformer) | |
628 | (output . ,output-pattern-transformer))) | |
629 | ||
630 | (define (pattern-transformer entry-type) | |
631 | (assq-ref %pattern-transformers entry-type)) | |
632 | ||
633 | ;; All procedures from inner alists are called with (MANIFEST . SEARCH-VALS) | |
634 | ;; as arguments; see `package/output-sexps'. | |
635 | (define %patterns-makers | |
636 | (let* ((apply-to-rest (lambda (proc) | |
637 | (lambda (_ . rest) (apply proc rest)))) | |
638 | (apply-to-first (lambda (proc) | |
639 | (lambda (first . _) (proc first)))) | |
640 | (manifest-package-proc (apply-to-first manifest-package-patterns)) | |
641 | (manifest-output-proc (apply-to-first manifest-output-patterns)) | |
642 | (regexp-proc (lambda (_ regexp params . __) | |
643 | (packages-by-regexp regexp params))) | |
644 | (all-proc (lambda _ (all-available-packages))) | |
645 | (newest-proc (lambda _ (newest-available-packages)))) | |
646 | `((package | |
647 | (id . ,(apply-to-rest ids->package-patterns)) | |
648 | (name . ,(apply-to-rest specifications->package-patterns)) | |
649 | (installed . ,manifest-package-proc) | |
650 | (generation . ,manifest-package-proc) | |
651 | (obsolete . ,(apply-to-first obsolete-package-patterns)) | |
652 | (regexp . ,regexp-proc) | |
653 | (all-available . ,all-proc) | |
654 | (newest-available . ,newest-proc)) | |
655 | (output | |
656 | (id . ,(apply-to-rest ids->output-patterns)) | |
657 | (name . ,(apply-to-rest specifications->output-patterns)) | |
658 | (installed . ,manifest-output-proc) | |
659 | (generation . ,manifest-output-proc) | |
660 | (obsolete . ,(apply-to-first obsolete-output-patterns)) | |
661 | (regexp . ,regexp-proc) | |
662 | (all-available . ,all-proc) | |
663 | (newest-available . ,newest-proc))))) | |
664 | ||
665 | (define (patterns-maker entry-type search-type) | |
666 | (or (and=> (assq-ref %patterns-makers entry-type) | |
667 | (cut assq-ref <> search-type)) | |
668 | (search-type-error entry-type search-type))) | |
669 | ||
670 | (define (package/output-sexps profile params entry-type | |
671 | search-type search-vals) | |
672 | "Return information about packages or package outputs. | |
673 | See 'entry-sexps' for details." | |
674 | (let* ((profile (if (eq? search-type 'generation) | |
675 | (generation-file-name profile (car search-vals)) | |
676 | profile)) | |
677 | (manifest (profile-manifest profile)) | |
d38bd08c AK |
678 | (patterns (if (and (eq? entry-type 'output) |
679 | (eq? search-type 'generation-diff)) | |
680 | (match search-vals | |
681 | ((g1 g2) | |
682 | (map specification->output-pattern | |
683 | (generation-difference profile g1 g2))) | |
684 | (_ '())) | |
685 | (apply (patterns-maker entry-type search-type) | |
686 | manifest search-vals))) | |
81b339fe AK |
687 | (->sexps ((pattern-transformer entry-type) manifest params))) |
688 | (append-map ->sexps patterns))) | |
689 | ||
690 | \f | |
691 | ;;; Getting information about generations. | |
457f60fa AK |
692 | |
693 | (define (generation-param-alist profile) | |
81b339fe | 694 | "Return an alist of generation parameters and procedures for PROFILE." |
c2379b3c AK |
695 | (let ((current (generation-number profile))) |
696 | `((id . ,identity) | |
697 | (number . ,identity) | |
698 | (prev-number . ,(cut previous-generation-number profile <>)) | |
699 | (current . ,(cut = current <>)) | |
700 | (path . ,(cut generation-file-name profile <>)) | |
701 | (time . ,(lambda (gen) | |
702 | (time-second (generation-time profile gen))))))) | |
457f60fa | 703 | |
81b339fe AK |
704 | (define (matching-generations profile predicate) |
705 | "Return a list of PROFILE generations matching PREDICATE." | |
706 | (filter predicate (profile-generations profile))) | |
457f60fa | 707 | |
81b339fe AK |
708 | (define (last-generations profile number) |
709 | "Return a list of last NUMBER generations. | |
710 | If NUMBER is 0 or less, return all generations." | |
457f60fa AK |
711 | (let ((generations (profile-generations profile)) |
712 | (number (if (<= number 0) +inf.0 number))) | |
81b339fe AK |
713 | (if (> (length generations) number) |
714 | (list-head (reverse generations) number) | |
715 | generations))) | |
457f60fa | 716 | |
81b339fe AK |
717 | (define (find-generations profile search-type search-vals) |
718 | "Find PROFILE's generations matching SEARCH-TYPE and SEARCH-VALS." | |
719 | (case search-type | |
720 | ((id) | |
ce8b2953 | 721 | (matching-generations profile (cut memq <> search-vals))) |
81b339fe AK |
722 | ((last) |
723 | (last-generations profile (car search-vals))) | |
724 | ((all) | |
725 | (last-generations profile +inf.0)) | |
189cea27 AK |
726 | ((time) |
727 | (match search-vals | |
728 | ((from to) | |
729 | (matching-generations | |
730 | profile | |
731 | (lambda (gen) | |
732 | (let ((time (time-second (generation-time profile gen)))) | |
733 | (< from time to))))) | |
734 | (_ '()))) | |
81b339fe AK |
735 | (else (search-type-error "generation" search-type)))) |
736 | ||
737 | (define (generation-sexps profile params search-type search-vals) | |
738 | "Return information about generations. | |
739 | See 'entry-sexps' for details." | |
740 | (let ((generations (find-generations profile search-type search-vals)) | |
741 | (->sexp (object-transformer (generation-param-alist profile) | |
742 | params))) | |
743 | (map ->sexp generations))) | |
457f60fa AK |
744 | |
745 | \f | |
81b339fe AK |
746 | ;;; Getting package/output/generation entries (alists). |
747 | ||
748 | (define (entries profile params entry-type search-type search-vals) | |
749 | "Return information about entries. | |
750 | ||
751 | ENTRY-TYPE is a symbol defining a type of returning information. Should | |
752 | be: 'package', 'output' or 'generation'. | |
753 | ||
754 | SEARCH-TYPE and SEARCH-VALS define how to get the information. | |
755 | SEARCH-TYPE should be one of the following symbols: | |
756 | ||
757 | - If ENTRY-TYPE is 'package' or 'output': | |
758 | 'id', 'name', 'regexp', 'all-available', 'newest-available', | |
759 | 'installed', 'obsolete', 'generation'. | |
760 | ||
761 | - If ENTRY-TYPE is 'generation': | |
189cea27 | 762 | 'id', 'last', 'all', 'time'. |
81b339fe AK |
763 | |
764 | PARAMS is a list of parameters for receiving. If it is an empty list, | |
765 | get information with all available parameters, which are: | |
766 | ||
767 | - If ENTRY-TYPE is 'package': | |
768 | 'id', 'name', 'version', 'outputs', 'license', 'synopsis', | |
769 | 'description', 'home-url', 'inputs', 'native-inputs', | |
770 | 'propagated-inputs', 'location', 'installed'. | |
771 | ||
772 | - If ENTRY-TYPE is 'output': | |
773 | 'id', 'package-id', 'name', 'version', 'output', 'license', | |
774 | 'synopsis', 'description', 'home-url', 'inputs', 'native-inputs', | |
775 | 'propagated-inputs', 'location', 'installed', 'path', 'dependencies'. | |
776 | ||
777 | - If ENTRY-TYPE is 'generation': | |
778 | 'id', 'number', 'prev-number', 'path', 'time'. | |
779 | ||
780 | Returning value is a list of alists. Each alist consists of | |
781 | parameter/value pairs." | |
782 | (case entry-type | |
783 | ((package output) | |
784 | (package/output-sexps profile params entry-type | |
785 | search-type search-vals)) | |
786 | ((generation) | |
787 | (generation-sexps profile params | |
788 | search-type search-vals)) | |
789 | (else (entry-type-error entry-type)))) | |
457f60fa AK |
790 | |
791 | \f | |
81b339fe | 792 | ;;; Package actions. |
457f60fa AK |
793 | |
794 | (define* (package->manifest-entry* package #:optional output) | |
795 | (and package | |
796 | (begin | |
797 | (check-package-freshness package) | |
798 | (package->manifest-entry package output)))) | |
799 | ||
800 | (define* (make-install-manifest-entries id #:optional output) | |
801 | (package->manifest-entry* (package-by-id id) output)) | |
802 | ||
803 | (define* (make-upgrade-manifest-entries id #:optional output) | |
804 | (package->manifest-entry* (newest-package-by-id id) output)) | |
805 | ||
806 | (define* (make-manifest-pattern id #:optional output) | |
807 | "Make manifest pattern from a package ID and OUTPUT." | |
808 | (let-values (((name version) | |
809 | (id->name+version id))) | |
810 | (and name version | |
811 | (manifest-pattern | |
812 | (name name) | |
813 | (version version) | |
814 | (output output))))) | |
815 | ||
816 | (define (convert-action-pattern pattern proc) | |
817 | "Convert action PATTERN into a list of objects returned by PROC. | |
818 | PROC is called: (PROC ID) or (PROC ID OUTPUT)." | |
819 | (match pattern | |
820 | ((id . outputs) | |
821 | (if (null? outputs) | |
822 | (let ((obj (proc id))) | |
823 | (if obj (list obj) '())) | |
824 | (filter-map (cut proc id <>) | |
825 | outputs))) | |
826 | (_ '()))) | |
827 | ||
828 | (define (convert-action-patterns patterns proc) | |
829 | (append-map (cut convert-action-pattern <> proc) | |
830 | patterns)) | |
831 | ||
832 | (define* (process-package-actions | |
833 | profile #:key (install '()) (upgrade '()) (remove '()) | |
834 | (use-substitutes? #t) dry-run?) | |
835 | "Perform package actions. | |
836 | ||
837 | INSTALL, UPGRADE, REMOVE are lists of 'package action patterns'. | |
838 | Each pattern should have the following form: | |
839 | ||
840 | (ID . OUTPUTS) | |
841 | ||
842 | ID is an object address or a full-name of a package. | |
843 | OUTPUTS is a list of package outputs (may be an empty list)." | |
844 | (format #t "The process begins ...~%") | |
845 | (let* ((install (append | |
846 | (convert-action-patterns | |
847 | install make-install-manifest-entries) | |
848 | (convert-action-patterns | |
849 | upgrade make-upgrade-manifest-entries))) | |
850 | (remove (convert-action-patterns remove make-manifest-pattern)) | |
851 | (transaction (manifest-transaction (install install) | |
852 | (remove remove))) | |
853 | (manifest (profile-manifest profile)) | |
854 | (new-manifest (manifest-perform-transaction | |
855 | manifest transaction))) | |
856 | (unless (and (null? install) (null? remove)) | |
1f06b288 AK |
857 | (with-store store |
858 | (let* ((derivation (run-with-store store | |
4ad2e76a LC |
859 | (mbegin %store-monad |
860 | (set-guile-for-build (default-guile)) | |
861 | (profile-derivation new-manifest)))) | |
1f06b288 AK |
862 | (derivations (list derivation)) |
863 | (new-profile (derivation->output-path derivation))) | |
864 | (set-build-options store | |
90fad288 | 865 | #:print-build-trace #f |
1f06b288 | 866 | #:use-substitutes? use-substitutes?) |
5d7a8584 | 867 | (show-manifest-transaction store manifest transaction |
1f06b288 AK |
868 | #:dry-run? dry-run?) |
869 | (show-what-to-build store derivations | |
870 | #:use-substitutes? use-substitutes? | |
871 | #:dry-run? dry-run?) | |
872 | (unless dry-run? | |
873 | (let ((name (generation-file-name | |
874 | profile | |
875 | (+ 1 (generation-number profile))))) | |
876 | (and (build-derivations store derivations) | |
877 | (let* ((entries (manifest-entries new-manifest)) | |
878 | (count (length entries))) | |
879 | (switch-symlinks name new-profile) | |
880 | (switch-symlinks profile name) | |
881 | (format #t (N_ "~a package in profile~%" | |
882 | "~a packages in profile~%" | |
883 | count) | |
307153c1 AK |
884 | count) |
885 | (display-search-paths entries profile)))))))))) | |
cb6a5c71 AK |
886 | |
887 | (define (delete-generations* profile generations) | |
888 | "Delete GENERATIONS from PROFILE. | |
889 | GENERATIONS is a list of generation numbers." | |
890 | (with-store store | |
891 | (delete-generations store profile generations))) | |
0b0fbf0c | 892 | |
eb097f36 AK |
893 | (define (package-location-string id-or-name) |
894 | "Return a location string of a package with ID-OR-NAME." | |
895 | (and-let* ((package (or (package-by-id id-or-name) | |
896 | (first (packages-by-name id-or-name)))) | |
6248e326 AK |
897 | (location (package-location package))) |
898 | (location->string location))) | |
899 | ||
0b0fbf0c AK |
900 | (define (package-source-derivation->store-path derivation) |
901 | "Return a store path of the package source DERIVATION." | |
902 | (match (derivation-outputs derivation) | |
903 | ;; Source derivation is always (("out" . derivation)). | |
904 | (((_ . output-drv)) | |
905 | (derivation-output-path output-drv)) | |
906 | (_ #f))) | |
907 | ||
908 | (define (package-source-path package-id) | |
909 | "Return a store file path to a source of a package PACKAGE-ID." | |
910 | (and-let* ((package (package-by-id package-id)) | |
911 | (source (package-source package))) | |
912 | (with-store store | |
913 | (package-source-derivation->store-path | |
914 | (package-source-derivation store source))))) | |
915 | ||
916 | (define* (package-source-build-derivation package-id #:key dry-run? | |
917 | (use-substitutes? #t)) | |
918 | "Build source derivation of a package PACKAGE-ID." | |
919 | (and-let* ((package (package-by-id package-id)) | |
920 | (source (package-source package))) | |
921 | (with-store store | |
922 | (let* ((derivation (package-source-derivation store source)) | |
923 | (derivations (list derivation))) | |
924 | (set-build-options store | |
90fad288 | 925 | #:print-build-trace #f |
0b0fbf0c AK |
926 | #:use-substitutes? use-substitutes?) |
927 | (show-what-to-build store derivations | |
928 | #:use-substitutes? use-substitutes? | |
929 | #:dry-run? dry-run?) | |
930 | (unless dry-run? | |
931 | (build-derivations store derivations)) | |
932 | (format #t "The source store path: ~a~%" | |
933 | (package-source-derivation->store-path derivation)))))) | |
056b5cef AK |
934 | |
935 | \f | |
5e53b0c5 AK |
936 | ;;; Executing guix commands |
937 | ||
938 | (define (guix-command . args) | |
939 | "Run 'guix ARGS ...' command." | |
940 | (catch 'quit | |
941 | (lambda () (apply run-guix args)) | |
942 | (const #t))) | |
943 | ||
944 | (define (guix-command-output . args) | |
945 | "Return string with 'guix ARGS ...' output." | |
946 | (with-output-to-string | |
947 | (lambda () (apply guix-command args)))) | |
948 | ||
949 | (define (help-string . commands) | |
950 | "Return string with 'guix COMMANDS ... --help' output." | |
951 | (apply guix-command-output `(,@commands "--help"))) | |
952 | ||
8b9ceb8d AK |
953 | (define (pipe-guix-output guix-args command-args) |
954 | "Run 'guix GUIX-ARGS ...' command and pipe its output to a shell command | |
955 | defined by COMMAND-ARGS. | |
956 | Return #t if the shell command was executed successfully." | |
957 | (let ((pipe (apply open-pipe* OPEN_WRITE command-args))) | |
958 | (with-output-to-port pipe | |
959 | (lambda () (apply guix-command guix-args))) | |
960 | (zero? (status:exit-val (close-pipe pipe))))) | |
961 | ||
5e53b0c5 | 962 | \f |
056b5cef AK |
963 | ;;; Lists of packages, lint checkers, etc. |
964 | ||
43b40c4b AK |
965 | (define (graph-type-names) |
966 | "Return a list of names of available graph node types." | |
967 | (map node-type-name %node-types)) | |
968 | ||
056b5cef AK |
969 | (define (lint-checker-names) |
970 | "Return a list of names of available lint checkers." | |
971 | (map (lambda (checker) | |
972 | (symbol->string (lint-checker-name checker))) | |
973 | %checkers)) | |
25a2839c AK |
974 | |
975 | (define (package-names) | |
976 | "Return a list of names of available packages." | |
977 | (delete-duplicates | |
978 | (fold-packages (lambda (pkg res) | |
979 | (cons (package-name pkg) res)) | |
980 | '()))) | |
981 | ||
982 | ;; See the comment to 'guix-package-names' function in "guix-popup.el". | |
983 | (define (package-names-lists) | |
984 | (map list (package-names))) |