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