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