Commit | Line | Data |
---|---|---|
0fdd3bea | 1 | ;;; GNU Guix --- Functional package management for GNU |
3794ce93 | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
392b5d8c | 3 | ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> |
7d193ec3 | 4 | ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> |
6ffa706b | 5 | ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> |
fbc5b815 | 6 | ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> |
1335ac31 | 7 | ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> |
c3949182 | 8 | ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> |
7e634c2f | 9 | ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> |
21f4fbdd | 10 | ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> |
0fdd3bea LC |
11 | ;;; |
12 | ;;; This file is part of GNU Guix. | |
13 | ;;; | |
14 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
15 | ;;; under the terms of the GNU General Public License as published by | |
16 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
17 | ;;; your option) any later version. | |
18 | ;;; | |
19 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
20 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
21 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
22 | ;;; GNU General Public License for more details. | |
23 | ;;; | |
24 | ;;; You should have received a copy of the GNU General Public License | |
25 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
26 | ||
27 | (define-module (guix scripts refresh) | |
28 | #:use-module (guix ui) | |
ca719424 | 29 | #:use-module (gcrypt hash) |
88981dd3 | 30 | #:use-module (guix scripts) |
21f4fbdd | 31 | #:use-module ((guix scripts build) #:select (%standard-build-options)) |
0fdd3bea LC |
32 | #:use-module (guix store) |
33 | #:use-module (guix utils) | |
34 | #:use-module (guix packages) | |
1335ac31 | 35 | #:use-module (guix profiles) |
0a7c5a09 | 36 | #:use-module (guix upstream) |
a51cbecb LC |
37 | #:use-module (guix graph) |
38 | #:use-module (guix scripts graph) | |
39 | #:use-module (guix monads) | |
f9230085 | 40 | #:use-module (guix gnupg) |
0fdd3bea | 41 | #:use-module (gnu packages) |
bdb36958 | 42 | #:use-module ((gnu packages commencement) #:select (%final-inputs)) |
0fdd3bea LC |
43 | #:use-module (ice-9 match) |
44 | #:use-module (ice-9 regex) | |
7d193ec3 | 45 | #:use-module (ice-9 vlist) |
65ea7111 | 46 | #:use-module (ice-9 format) |
0fdd3bea LC |
47 | #:use-module (srfi srfi-1) |
48 | #:use-module (srfi srfi-11) | |
49 | #:use-module (srfi srfi-26) | |
50 | #:use-module (srfi srfi-37) | |
2535635f | 51 | #:use-module (ice-9 binary-ports) |
adf0c531 | 52 | #:export (guix-refresh)) |
0fdd3bea LC |
53 | |
54 | \f | |
55 | ;;; | |
56 | ;;; Command-line options. | |
57 | ;;; | |
58 | ||
59 | (define %default-options | |
60 | ;; Alist of default option values. | |
61 | '()) | |
62 | ||
63 | (define %options | |
64 | ;; Specification of the command-line options. | |
313109e0 | 65 | (list (option '(#\u "update") #f #f |
0fdd3bea | 66 | (lambda (opt name arg result) |
313109e0 | 67 | (alist-cons 'update? #t result))) |
37a53402 LC |
68 | (option '(#\s "select") #t #f |
69 | (lambda (opt name arg result) | |
70 | (match arg | |
71 | ((or "core" "non-core") | |
72 | (alist-cons 'select (string->symbol arg) | |
73 | result)) | |
74 | (x | |
69daee23 | 75 | (leave (G_ "~a: invalid selection; expected `core' or `non-core'~%") |
37a53402 | 76 | arg))))) |
bcb571cb LC |
77 | (option '(#\t "type") #t #f |
78 | (lambda (opt name arg result) | |
7191adc5 AK |
79 | (let* ((not-comma (char-set-complement (char-set #\,))) |
80 | (names (map string->symbol | |
81 | (string-tokenize arg not-comma)))) | |
82 | (alist-cons 'updaters names result)))) | |
6ffa706b AK |
83 | (option '(#\L "list-updaters") #f #f |
84 | (lambda args | |
7191adc5 | 85 | (list-updaters-and-exit))) |
1335ac31 MO |
86 | (option '(#\m "manifest") #t #f |
87 | (lambda (opt name arg result) | |
88 | (alist-cons 'manifest arg result))) | |
2d7fc7da LC |
89 | (option '(#\e "expression") #t #f |
90 | (lambda (opt name arg result) | |
91 | (alist-cons 'expression arg result))) | |
7d193ec3 EB |
92 | (option '(#\l "list-dependent") #f #f |
93 | (lambda (opt name arg result) | |
94 | (alist-cons 'list-dependent? #t result))) | |
c3949182 EF |
95 | (option '(#\r "recursive") #f #f |
96 | (lambda (opt name arg result) | |
97 | (alist-cons 'recursive? #t result))) | |
98 | (option '("list-transitive") #f #f | |
99 | (lambda (opt name arg result) | |
100 | (alist-cons 'list-transitive? #t result))) | |
0fdd3bea | 101 | |
b9e1fddf LC |
102 | (option '("keyring") #t #f |
103 | (lambda (opt name arg result) | |
104 | (alist-cons 'keyring arg result))) | |
f9230085 LC |
105 | (option '("key-server") #t #f |
106 | (lambda (opt name arg result) | |
107 | (alist-cons 'key-server arg result))) | |
108 | (option '("gpg") #t #f | |
109 | (lambda (opt name arg result) | |
110 | (alist-cons 'gpg-command arg result))) | |
392b5d8c NK |
111 | (option '("key-download") #t #f |
112 | (lambda (opt name arg result) | |
113 | (match arg | |
114 | ((or "interactive" "always" "never") | |
115 | (alist-cons 'key-download (string->symbol arg) | |
116 | result)) | |
e465d9e1 | 117 | (x |
69daee23 | 118 | (leave (G_ "unsupported policy: ~a~%") |
392b5d8c | 119 | arg))))) |
f9230085 | 120 | |
21f4fbdd | 121 | ;; The short option -L is already used by --list-updaters, therefore |
122 | ;; it needs to be removed from %standard-build-options. | |
e478fd97 | 123 | (let ((load-path-option (find (lambda (option) |
21f4fbdd | 124 | (member "load-path" |
125 | (option-names option))) | |
126 | %standard-build-options))) | |
127 | (option | |
128 | (filter (lambda (name) (not (equal? #\L name))) | |
e478fd97 | 129 | (option-names load-path-option)) |
130 | (option-required-arg? load-path-option) | |
131 | (option-optional-arg? load-path-option) | |
132 | (option-processor load-path-option))) | |
21f4fbdd | 133 | |
0fdd3bea LC |
134 | (option '(#\h "help") #f #f |
135 | (lambda args | |
136 | (show-help) | |
137 | (exit 0))) | |
138 | (option '(#\V "version") #f #f | |
139 | (lambda args | |
140 | (show-version-and-exit "guix refresh"))))) | |
141 | ||
142 | (define (show-help) | |
69daee23 | 143 | (display (G_ "Usage: guix refresh [OPTION]... [PACKAGE]... |
37a53402 LC |
144 | Update package definitions to match the latest upstream version. |
145 | ||
146 | When PACKAGE... is given, update only the specified packages. Otherwise | |
147 | update all the packages of the distribution, or the subset thereof | |
148 | specified with `--select'.\n")) | |
69daee23 | 149 | (display (G_ " |
2d7fc7da | 150 | -e, --expression=EXPR consider the package EXPR evaluates to")) |
69daee23 | 151 | (display (G_ " |
313109e0 | 152 | -u, --update update source files in place")) |
69daee23 | 153 | (display (G_ " |
37a53402 LC |
154 | -s, --select=SUBSET select all the packages in SUBSET, one of |
155 | `core' or `non-core'")) | |
69daee23 | 156 | (display (G_ " |
1335ac31 MO |
157 | -m, --manifest=FILE select all the packages from the manifest in FILE")) |
158 | (display (G_ " | |
7191adc5 AK |
159 | -t, --type=UPDATER,... restrict to updates from the specified updaters |
160 | (e.g., 'gnu')")) | |
69daee23 | 161 | (display (G_ " |
6ffa706b | 162 | -L, --list-updaters list available updaters and exit")) |
69daee23 | 163 | (display (G_ " |
7d193ec3 EB |
164 | -l, --list-dependent list top-level dependent packages that would need to |
165 | be rebuilt as a result of upgrading PACKAGE...")) | |
c3949182 EF |
166 | (display (G_ " |
167 | -r, --recursive check the PACKAGE and its inputs for upgrades")) | |
168 | (display (G_ " | |
169 | --list-transitive list all the packages that PACKAGE depends on")) | |
0fdd3bea | 170 | (newline) |
b9e1fddf LC |
171 | (display (G_ " |
172 | --keyring=FILE use FILE as the keyring of upstream OpenPGP keys")) | |
69daee23 | 173 | (display (G_ " |
f9230085 | 174 | --key-server=HOST use HOST as the OpenPGP key server")) |
69daee23 | 175 | (display (G_ " |
f9230085 | 176 | --gpg=COMMAND use COMMAND as the GnuPG 2.x command")) |
69daee23 | 177 | (display (G_ " |
392b5d8c NK |
178 | --key-download=POLICY |
179 | handle missing OpenPGP keys according to POLICY: | |
180 | 'always', 'never', and 'interactive', which is also | |
181 | used when 'key-download' is not specified")) | |
f9230085 | 182 | (newline) |
21f4fbdd | 183 | (display (G_ " |
184 | --load-path=DIR prepend DIR to the package module search path")) | |
185 | (newline) | |
69daee23 | 186 | (display (G_ " |
0fdd3bea | 187 | -h, --help display this help and exit")) |
69daee23 | 188 | (display (G_ " |
0fdd3bea LC |
189 | -V, --version display version information and exit")) |
190 | (newline) | |
191 | (show-bug-report-information)) | |
192 | ||
fca43e14 LC |
193 | (define (options->packages opts) |
194 | "Return the list of packages requested by OPTS, honoring options like | |
195 | '--recursive'." | |
196 | (define core-package? | |
197 | (let* ((input->package (match-lambda | |
198 | ((name (? package? package) _ ...) package) | |
199 | (_ #f))) | |
200 | (final-inputs (map input->package %final-inputs)) | |
201 | (core (append final-inputs | |
202 | (append-map (compose (cut filter-map input->package <>) | |
203 | package-transitive-inputs) | |
204 | final-inputs))) | |
205 | (names (delete-duplicates (map package-name core)))) | |
206 | (lambda (package) | |
207 | "Return true if PACKAGE is likely a \"core package\"---i.e., one whose | |
208 | update would trigger a complete rebuild." | |
209 | ;; Compare by name because packages in base.scm basically inherit | |
210 | ;; other packages. So, even if those packages are not core packages | |
211 | ;; themselves, updating them would also update those who inherit from | |
212 | ;; them. | |
213 | ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input. | |
214 | (member (package-name package) names)))) | |
215 | ||
216 | (define (keep-newest package lst) | |
217 | ;; If a newer version of PACKAGE is already in LST, return LST; otherwise | |
218 | ;; return LST minus the other version of PACKAGE in it, plus PACKAGE. | |
219 | (let ((name (package-name package))) | |
220 | (match (find (lambda (p) | |
221 | (string=? (package-name p) name)) | |
222 | lst) | |
223 | ((? package? other) | |
224 | (if (version>? (package-version other) (package-version package)) | |
225 | lst | |
226 | (cons package (delq other lst)))) | |
227 | (_ | |
228 | (cons package lst))))) | |
229 | ||
230 | (define args-packages | |
231 | ;; Packages explicitly passed as command-line arguments. | |
232 | (match (filter-map (match-lambda | |
233 | (('argument . spec) | |
234 | ;; Take either the specified version or the | |
235 | ;; latest one. | |
236 | (specification->package spec)) | |
237 | (('expression . exp) | |
238 | (read/eval-package-expression exp)) | |
239 | (_ #f)) | |
240 | opts) | |
241 | (() ;default to all packages | |
242 | (let ((select? (match (assoc-ref opts 'select) | |
243 | ('core core-package?) | |
244 | ('non-core (negate core-package?)) | |
245 | (_ (const #t))))) | |
246 | (fold-packages (lambda (package result) | |
247 | (if (select? package) | |
248 | (keep-newest package result) | |
249 | result)) | |
250 | '()))) | |
251 | (some ;user-specified packages | |
252 | some))) | |
253 | ||
254 | (define packages | |
255 | (match (assoc-ref opts 'manifest) | |
256 | (#f args-packages) | |
257 | ((? string? file) (packages-from-manifest file)))) | |
258 | ||
259 | (if (assoc-ref opts 'recursive?) | |
260 | (mlet %store-monad ((edges (node-edges %bag-node-type | |
261 | (all-packages)))) | |
262 | (return (node-transitive-edges packages edges))) | |
263 | (with-monad %store-monad | |
264 | (return packages)))) | |
265 | ||
0a7c5a09 LC |
266 | \f |
267 | ;;; | |
268 | ;;; Updates. | |
269 | ;;; | |
270 | ||
e9c72306 | 271 | (define (lookup-updater-by-name name) |
bcb571cb | 272 | "Return the updater called NAME." |
fba607b1 LC |
273 | (or (find (lambda (updater) |
274 | (eq? name (upstream-updater-name updater))) | |
634088a5 | 275 | (force %updaters)) |
69daee23 | 276 | (leave (G_ "~a: no such updater~%") name))) |
bcb571cb | 277 | |
6ffa706b AK |
278 | (define (list-updaters-and-exit) |
279 | "Display available updaters and exit." | |
69daee23 | 280 | (format #t (G_ "Available updaters:~%")) |
3676f892 LC |
281 | (newline) |
282 | ||
283 | (let* ((packages (fold-packages cons '())) | |
284 | (total (length packages))) | |
cba7ddcf EB |
285 | (define uncovered |
286 | (fold (lambda (updater uncovered) | |
287 | (let ((matches (filter (upstream-updater-predicate updater) | |
288 | packages))) | |
3676f892 LC |
289 | ;; TRANSLATORS: The parenthetical expression here is rendered |
290 | ;; like "(42% coverage)" and denotes the fraction of packages | |
291 | ;; covered by the given updater. | |
69daee23 | 292 | (format #t (G_ " - ~a: ~a (~2,1f% coverage)~%") |
3676f892 | 293 | (upstream-updater-name updater) |
69daee23 | 294 | (G_ (upstream-updater-description updater)) |
cba7ddcf EB |
295 | (* 100. (/ (length matches) total))) |
296 | (lset-difference eq? uncovered matches))) | |
297 | packages | |
634088a5 | 298 | (force %updaters))) |
3676f892 LC |
299 | |
300 | (newline) | |
69daee23 | 301 | (format #t (G_ "~2,1f% of the packages are covered by these updaters.~%") |
cba7ddcf | 302 | (* 100. (/ (- total (length uncovered)) total)))) |
6ffa706b AK |
303 | (exit 0)) |
304 | ||
e9c72306 | 305 | (define (warn-no-updater package) |
4496ea74 LC |
306 | (warning (package-location package) |
307 | (G_ "no updater for ~a~%") | |
308 | (package-name package))) | |
e9c72306 | 309 | |
bcb571cb | 310 | (define* (update-package store package updaters |
e9c72306 | 311 | #:key (key-download 'interactive) warn?) |
392b5d8c NK |
312 | "Update the source file that defines PACKAGE with the new version. |
313 | KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed | |
e9c72306 LC |
314 | values: 'interactive' (default), 'always', and 'never'. When WARN? is true, |
315 | warn about packages that have no matching updater." | |
316 | (if (lookup-updater package updaters) | |
1ee3d2dc | 317 | (let-values (((version tarball source) |
e9c72306 LC |
318 | (package-update store package updaters |
319 | #:key-download key-download)) | |
320 | ((loc) | |
321 | (or (package-field-location package 'version) | |
322 | (package-location package)))) | |
323 | (when version | |
324 | (if (and=> tarball file-exists?) | |
325 | (begin | |
4496ea74 LC |
326 | (info loc |
327 | (G_ "~a: updating from version ~a to version ~a...~%") | |
328 | (package-name package) | |
329 | (package-version package) version) | |
7e634c2f RW |
330 | (for-each |
331 | (lambda (change) | |
332 | (format (current-error-port) | |
333 | (match (list (upstream-input-change-action change) | |
334 | (upstream-input-change-type change)) | |
335 | (('add 'regular) | |
336 | (G_ "~a: consider adding this input: ~a~%")) | |
337 | (('add 'native) | |
338 | (G_ "~a: consider adding this native input: ~a~%")) | |
339 | (('add 'propagated) | |
340 | (G_ "~a: consider adding this propagated input: ~a~%")) | |
341 | (('remove 'regular) | |
342 | (G_ "~a: consider removing this input: ~a~%")) | |
343 | (('remove 'native) | |
344 | (G_ "~a: consider removing this native input: ~a~%")) | |
345 | (('remove 'propagated) | |
346 | (G_ "~a: consider removing this propagated input: ~a~%"))) | |
347 | (package-name package) | |
348 | (upstream-input-change-name change))) | |
1ee3d2dc | 349 | (upstream-source-input-changes source)) |
e9c72306 LC |
350 | (let ((hash (call-with-input-file tarball |
351 | port-sha256))) | |
42314ffa | 352 | (update-package-source package source hash))) |
69daee23 | 353 | (warning (G_ "~a: version ~a could not be \ |
3d20ebd6 | 354 | downloaded and authenticated; not updating~%") |
e9c72306 LC |
355 | (package-name package) version)))) |
356 | (when warn? | |
357 | (warn-no-updater package)))) | |
358 | ||
4e6230ec | 359 | (define* (check-for-package-update package updaters #:key warn?) |
e9c72306 LC |
360 | "Check whether an update is available for PACKAGE and print a message. When |
361 | WARN? is true and no updater exists for PACKAGE, print a warning." | |
4e6230ec | 362 | (match (package-latest-release package updaters) |
e9c72306 | 363 | ((? upstream-source? source) |
4c228f9e LC |
364 | (let ((loc (or (package-field-location package 'version) |
365 | (package-location package)))) | |
366 | (case (version-compare (upstream-source-version source) | |
367 | (package-version package)) | |
368 | ((>) | |
4496ea74 LC |
369 | (info loc |
370 | (G_ "~a would be upgraded from ~a to ~a~%") | |
371 | (package-name package) (package-version package) | |
372 | (upstream-source-version source))) | |
4c228f9e LC |
373 | ((=) |
374 | (when warn? | |
4496ea74 LC |
375 | (info loc |
376 | (G_ "~a is already the latest version of ~a~%") | |
377 | (package-version package) | |
378 | (package-name package)))) | |
4c228f9e LC |
379 | (else |
380 | (when warn? | |
4496ea74 LC |
381 | (warning loc |
382 | (G_ "~a is greater than \ | |
4c228f9e | 383 | the latest known version of ~a (~a)~%") |
4496ea74 LC |
384 | (package-version package) |
385 | (package-name package) | |
386 | (upstream-source-version source))))))) | |
e9c72306 LC |
387 | (#f |
388 | (when warn? | |
7c101c4c LC |
389 | ;; Distinguish between "no updater" and "failing updater." |
390 | (match (lookup-updater package updaters) | |
391 | ((? upstream-updater? updater) | |
392 | (warning (package-location package) | |
393 | (G_ "'~a' updater failed to determine available \ | |
394 | releases for ~a~%") | |
395 | (upstream-updater-name updater) | |
396 | (package-name package))) | |
397 | (#f | |
398 | (warn-no-updater package))))))) | |
f9230085 | 399 | |
0fdd3bea | 400 | \f |
a51cbecb LC |
401 | ;;; |
402 | ;;; Dependents. | |
403 | ;;; | |
404 | ||
405 | (define (all-packages) | |
406 | "Return the list of all the distro's packages." | |
9300e2e8 LC |
407 | (fold-packages (lambda (package result) |
408 | ;; Ignore deprecated packages. | |
409 | (if (package-superseded package) | |
410 | result | |
411 | (cons package result))) | |
412 | '() | |
8e57e416 | 413 | #:select? (const #t))) ;include hidden packages |
a51cbecb LC |
414 | |
415 | (define (list-dependents packages) | |
416 | "List all the things that would need to be rebuilt if PACKAGES are changed." | |
9a6beb3b LC |
417 | ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE |
418 | ;; because it includes implicit dependencies. | |
6d1a5e5f LC |
419 | (define (full-name package) |
420 | (string-append (package-name package) "@" | |
421 | (package-version package))) | |
422 | ||
9a6beb3b | 423 | (mlet %store-monad ((edges (node-back-edges %bag-node-type |
af77219e | 424 | (package-closure (all-packages))))) |
9a6beb3b LC |
425 | (let* ((dependents (node-transitive-edges packages edges)) |
426 | (covering (filter (lambda (node) | |
427 | (null? (edges node))) | |
428 | dependents))) | |
429 | (match dependents | |
430 | (() | |
431 | (format (current-output-port) | |
432 | (N_ "No dependents other than itself: ~{~a~}~%" | |
433 | "No dependents other than themselves: ~{~a~^ ~}~%" | |
434 | (length packages)) | |
6d1a5e5f | 435 | (map full-name packages))) |
a51cbecb | 436 | |
9a6beb3b LC |
437 | ((x) |
438 | (format (current-output-port) | |
69daee23 | 439 | (G_ "A single dependent package: ~a~%") |
6d1a5e5f | 440 | (full-name x))) |
9a6beb3b LC |
441 | (lst |
442 | (format (current-output-port) | |
9b5e1cc1 | 443 | (N_ "Building the following ~d package would ensure ~d \ |
4d6ce0f1 | 444 | dependent packages are rebuilt: ~{~a~^ ~}~%" |
9a6beb3b | 445 | "Building the following ~d packages would ensure ~d \ |
a51cbecb | 446 | dependent packages are rebuilt: ~{~a~^ ~}~%" |
9a6beb3b LC |
447 | (length covering)) |
448 | (length covering) (length dependents) | |
6d1a5e5f | 449 | (map full-name covering)))) |
9a6beb3b | 450 | (return #t)))) |
a51cbecb | 451 | |
c3949182 EF |
452 | (define (list-transitive packages) |
453 | "List all the packages that would cause PACKAGES to be rebuilt if they are changed." | |
454 | ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE | |
455 | ;; because it includes implicit dependencies. | |
456 | (define (full-name package) | |
457 | (string-append (package-name package) "@" | |
458 | (package-version package))) | |
459 | ||
460 | (mlet %store-monad ((edges (node-edges %bag-node-type | |
461 | ;; Here we don't want the -boot0 packages. | |
462 | (fold-packages cons '())))) | |
463 | (let ((dependent (node-transitive-edges packages edges))) | |
464 | (match packages | |
465 | ((x) | |
466 | (format (current-output-port) | |
467 | (G_ "~a depends on the following ~d packages: ~{~a~^ ~}~%.") | |
468 | (full-name x) (length dependent) (map full-name dependent))) | |
469 | (lst | |
470 | (format (current-output-port) | |
471 | (G_ "The following ~d packages \ | |
472 | all are dependent packages: ~{~a~^ ~}~%") | |
473 | (length dependent) (map full-name dependent)))) | |
474 | (return #t)))) | |
475 | ||
a51cbecb | 476 | \f |
1335ac31 MO |
477 | ;;; |
478 | ;;; Manifest. | |
479 | ;;; | |
480 | ||
481 | (define (manifest->packages manifest) | |
482 | "Return the list of packages in MANIFEST." | |
483 | (filter-map (lambda (entry) | |
484 | (let ((item (manifest-entry-item entry))) | |
485 | (if (package? item) item #f))) | |
486 | (manifest-entries manifest))) | |
487 | ||
488 | (define (packages-from-manifest manifest) | |
489 | "Return the list of packages in loaded MANIFEST." | |
490 | (let* ((user-module (make-user-module '((guix profiles) (gnu)))) | |
491 | (manifest (load* manifest user-module))) | |
492 | (manifest->packages manifest))) | |
493 | ||
494 | \f | |
0fdd3bea LC |
495 | ;;; |
496 | ;;; Entry point. | |
497 | ;;; | |
498 | ||
3794ce93 LC |
499 | (define-command (guix-refresh . args) |
500 | (category packaging) | |
501 | (synopsis "update existing package definitions") | |
502 | ||
0fdd3bea LC |
503 | (define (parse-options) |
504 | ;; Return the alist of option values. | |
a1ff7e1d LC |
505 | (parse-command-line args %options (list %default-options) |
506 | #:build-options? #f)) | |
0fdd3bea | 507 | |
bcb571cb LC |
508 | (define (options->updaters opts) |
509 | ;; Return the list of updaters to use. | |
510 | (match (filter-map (match-lambda | |
7191adc5 | 511 | (('updaters . names) |
e9c72306 | 512 | (map lookup-updater-by-name names)) |
bcb571cb LC |
513 | (_ #f)) |
514 | opts) | |
515 | (() | |
516 | ;; Use the default updaters. | |
634088a5 | 517 | (force %updaters)) |
7191adc5 AK |
518 | (lists |
519 | (concatenate lists)))) | |
bcb571cb | 520 | |
7d193ec3 EB |
521 | (let* ((opts (parse-options)) |
522 | (update? (assoc-ref opts 'update?)) | |
bcb571cb | 523 | (updaters (options->updaters opts)) |
c3949182 | 524 | (recursive? (assoc-ref opts 'recursive?)) |
7d193ec3 | 525 | (list-dependent? (assoc-ref opts 'list-dependent?)) |
c3949182 | 526 | (list-transitive? (assoc-ref opts 'list-transitive?)) |
7d193ec3 | 527 | (key-download (assoc-ref opts 'key-download)) |
e9c72306 LC |
528 | |
529 | ;; Warn about missing updaters when a package is explicitly given on | |
530 | ;; the command line. | |
fca43e14 | 531 | (warn? (and (or (assoc-ref opts 'argument) |
7489207f LC |
532 | (assoc-ref opts 'expression) |
533 | (assoc-ref opts 'manifest)) | |
fca43e14 | 534 | (not recursive?)))) |
37a53402 | 535 | (with-error-handling |
9a6beb3b LC |
536 | (with-store store |
537 | (run-with-store store | |
fca43e14 LC |
538 | (mlet %store-monad ((packages (options->packages opts))) |
539 | (cond | |
540 | (list-dependent? | |
541 | (list-dependents packages)) | |
542 | (list-transitive? | |
543 | (list-transitive packages)) | |
544 | (update? | |
545 | (parameterize ((%openpgp-key-server | |
546 | (or (assoc-ref opts 'key-server) | |
547 | (%openpgp-key-server))) | |
548 | (%gpg-command | |
549 | (or (assoc-ref opts 'gpg-command) | |
550 | (%gpg-command))) | |
551 | (current-keyring | |
552 | (or (assoc-ref opts 'keyring) | |
553 | (string-append (config-directory) | |
554 | "/upstream/trustedkeys.kbx")))) | |
555 | (for-each | |
556 | (cut update-package store <> updaters | |
557 | #:key-download key-download | |
558 | #:warn? warn?) | |
559 | packages) | |
560 | (return #t))) | |
561 | (else | |
562 | (for-each (cut check-for-package-update <> updaters | |
563 | #:warn? warn?) | |
564 | packages) | |
9a6beb3b | 565 | (return #t))))))))) |