diff options
Diffstat (limited to 'guix/scripts/refresh.scm')
| -rw-r--r-- | guix/scripts/refresh.scm | 235 |
1 files changed, 127 insertions, 108 deletions
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 003c915da3..a0de9f6c10 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,11 +1,12 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,7 +42,6 @@ #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (ice-9 format) - #:use-module (ice-9 threads) ; par-for-each #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -172,6 +172,79 @@ specified with `--select'.\n")) (newline) (show-bug-report-information)) +(define (options->packages opts) + "Return the list of packages requested by OPTS, honoring options like +'--recursive'." + (define core-package? + (let* ((input->package (match-lambda + ((name (? package? package) _ ...) package) + (_ #f))) + (final-inputs (map input->package %final-inputs)) + (core (append final-inputs + (append-map (compose (cut filter-map input->package <>) + package-transitive-inputs) + final-inputs))) + (names (delete-duplicates (map package-name core)))) + (lambda (package) + "Return true if PACKAGE is likely a \"core package\"---i.e., one whose +update would trigger a complete rebuild." + ;; Compare by name because packages in base.scm basically inherit + ;; other packages. So, even if those packages are not core packages + ;; themselves, updating them would also update those who inherit from + ;; them. + ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input. + (member (package-name package) names)))) + + (define (keep-newest package lst) + ;; If a newer version of PACKAGE is already in LST, return LST; otherwise + ;; return LST minus the other version of PACKAGE in it, plus PACKAGE. + (let ((name (package-name package))) + (match (find (lambda (p) + (string=? (package-name p) name)) + lst) + ((? package? other) + (if (version>? (package-version other) (package-version package)) + lst + (cons package (delq other lst)))) + (_ + (cons package lst))))) + + (define args-packages + ;; Packages explicitly passed as command-line arguments. + (match (filter-map (match-lambda + (('argument . spec) + ;; Take either the specified version or the + ;; latest one. + (specification->package spec)) + (('expression . exp) + (read/eval-package-expression exp)) + (_ #f)) + opts) + (() ;default to all packages + (let ((select? (match (assoc-ref opts 'select) + ('core core-package?) + ('non-core (negate core-package?)) + (_ (const #t))))) + (fold-packages (lambda (package result) + (if (select? package) + (keep-newest package result) + result)) + '()))) + (some ;user-specified packages + some))) + + (define packages + (match (assoc-ref opts 'manifest) + (#f args-packages) + ((? string? file) (packages-from-manifest file)))) + + (if (assoc-ref opts 'recursive?) + (mlet %store-monad ((edges (node-edges %bag-node-type + (all-packages)))) + (return (node-transitive-edges packages edges))) + (with-monad %store-monad + (return packages)))) + ;;; ;;; Updates. @@ -224,7 +297,7 @@ KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'interactive' (default), 'always', and 'never'. When WARN? is true, warn about packages that have no matching updater." (if (lookup-updater package updaters) - (let-values (((version tarball) + (let-values (((version tarball changes) (package-update store package updaters #:key-download key-download)) ((loc) @@ -238,6 +311,26 @@ warn about packages that have no matching updater." (location->string loc) (package-name package) (package-version package) version) + (for-each + (lambda (change) + (format (current-error-port) + (match (list (upstream-input-change-action change) + (upstream-input-change-type change)) + (('add 'regular) + (G_ "~a: consider adding this input: ~a~%")) + (('add 'native) + (G_ "~a: consider adding this native input: ~a~%")) + (('add 'propagated) + (G_ "~a: consider adding this propagated input: ~a~%")) + (('remove 'regular) + (G_ "~a: consider removing this input: ~a~%")) + (('remove 'native) + (G_ "~a: consider removing this native input: ~a~%")) + (('remove 'propagated) + (G_ "~a: consider removing this propagated input: ~a~%"))) + (package-name package) + (upstream-input-change-name change))) + (changes)) (let ((hash (call-with-input-file tarball port-sha256))) (update-package-source package version hash))) @@ -335,19 +428,6 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" (map full-name covering)))) (return #t)))) -(define (refresh-recursive packages) - "Check all of the package inputs of PACKAGES for newer upstream versions." - (mlet %store-monad ((edges (node-edges %bag-node-type - ;; Here we don't want the -boot0 packages. - (fold-packages cons '())))) - (let ((dependent (node-transitive-edges packages edges))) - ;; par-for-each has an undefined return value, so packages which cause - ;; errors can be ignored. - (par-for-each (lambda (package) - (guix-refresh package)) - (map package-name dependent))) - (return #t))) - (define (list-transitive packages) "List all the packages that would cause PACKAGES to be rebuilt if they are changed." ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE @@ -414,40 +494,6 @@ all are dependent packages: ~{~a~^ ~}~%") (lists (concatenate lists)))) - (define (keep-newest package lst) - ;; If a newer version of PACKAGE is already in LST, return LST; otherwise - ;; return LST minus the other version of PACKAGE in it, plus PACKAGE. - (let ((name (package-name package))) - (match (find (lambda (p) - (string=? (package-name p) name)) - lst) - ((? package? other) - (if (version>? (package-version other) (package-version package)) - lst - (cons package (delq other lst)))) - (_ - (cons package lst))))) - - (define core-package? - (let* ((input->package (match-lambda - ((name (? package? package) _ ...) package) - (_ #f))) - (final-inputs (map input->package %final-inputs)) - (core (append final-inputs - (append-map (compose (cut filter-map input->package <>) - package-transitive-inputs) - final-inputs))) - (names (delete-duplicates (map package-name core)))) - (lambda (package) - "Return true if PACKAGE is likely a \"core package\"---i.e., one whose -update would trigger a complete rebuild." - ;; Compare by name because packages in base.scm basically inherit - ;; other packages. So, even if those packages are not core packages - ;; themselves, updating them would also update those who inherit from - ;; them. - ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input. - (member (package-name package) names)))) - (let* ((opts (parse-options)) (update? (assoc-ref opts 'update?)) (updaters (options->updaters opts)) @@ -458,65 +504,38 @@ update would trigger a complete rebuild." ;; Warn about missing updaters when a package is explicitly given on ;; the command line. - (warn? (or (assoc-ref opts 'argument) - (assoc-ref opts 'expression))) - (args-packages - (match (filter-map (match-lambda - (('argument . spec) - ;; Take either the specified version or the - ;; latest one. - (specification->package spec)) - (('expression . exp) - (read/eval-package-expression exp)) - (_ #f)) - opts) - (() ; default to all packages - (let ((select? (match (assoc-ref opts 'select) - ('core core-package?) - ('non-core (negate core-package?)) - (_ (const #t))))) - (fold-packages (lambda (package result) - (if (select? package) - (keep-newest package result) - result)) - '()))) - (some ; user-specified packages - some))) - (packages - (match (assoc-ref opts 'manifest) - (#f args-packages) - ((? string? file) (packages-from-manifest file))))) + (warn? (and (or (assoc-ref opts 'argument) + (assoc-ref opts 'expression) + (assoc-ref opts 'manifest)) + (not recursive?)))) (with-error-handling (with-store store (run-with-store store - (cond - (list-dependent? - (list-dependents packages)) - (list-transitive? - (list-transitive packages)) - (recursive? - (refresh-recursive packages)) - (update? - (parameterize ((%openpgp-key-server - (or (assoc-ref opts 'key-server) - (%openpgp-key-server))) - (%gpg-command - (or (assoc-ref opts 'gpg-command) - (%gpg-command))) - (current-keyring - (or (assoc-ref opts 'keyring) - (string-append (config-directory) - "/upstream/trustedkeys.kbx")))) - (for-each - (cut update-package store <> updaters - #:key-download key-download - #:warn? warn?) - packages) - (with-monad %store-monad - (return #t)))) - (else - (for-each (cut check-for-package-update <> updaters - #:warn? warn?) - packages) - (with-monad %store-monad + (mlet %store-monad ((packages (options->packages opts))) + (cond + (list-dependent? + (list-dependents packages)) + (list-transitive? + (list-transitive packages)) + (update? + (parameterize ((%openpgp-key-server + (or (assoc-ref opts 'key-server) + (%openpgp-key-server))) + (%gpg-command + (or (assoc-ref opts 'gpg-command) + (%gpg-command))) + (current-keyring + (or (assoc-ref opts 'keyring) + (string-append (config-directory) + "/upstream/trustedkeys.kbx")))) + (for-each + (cut update-package store <> updaters + #:key-download key-download + #:warn? warn?) + packages) + (return #t))) + (else + (for-each (cut check-for-package-update <> updaters + #:warn? warn?) + packages) (return #t))))))))) |