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