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