me
/
guix
Archived
1
0
Fork 0
Code

refresh: Refactor option handling and '--recursive'. 

This allows us to combine '--recursive' with other options (-u, -m,
etc.), turns off warnings when '--recursive' is used, and avoids the
hazards of I/O in the presence of multithreading.

* guix/scripts/refresh.scm (options->packages): New procedure, with code
formerly in 'guix-refresh'.
(refresh-recursive): Remove.
(guix-refresh)[keep-newest, core-package?, args-packages, packages]:
Remove.
[warn?]: Set to #f when RECURSIVE? is true.
Call 'options->packages' in monadic context.
master
Ludovic Courtès 2019-01-11 11:44:26 +01:00
parent 88d7101798
commit fca43e14f7
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 104 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

211
guix/scripts/refresh.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
@ -41,7 +41,6 @@
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (ice-9 threads) ; par-for-each
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -172,6 +171,79 @@ specified with `--select'.\n"))
(newline) (newline)
(show-bug-report-information)) (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. ;;; Updates.
@ -335,19 +407,6 @@ dependent packages are rebuilt: ~{~a~^ ~}~%"
(map full-name covering)))) (map full-name covering))))
(return #t)))) (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) (define (list-transitive packages)
"List all the packages that would cause PACKAGES to be rebuilt if they are changed." "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 ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE
@ -414,40 +473,6 @@ all are dependent packages: ~{~a~^ ~}~%")
(lists (lists
(concatenate 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)) (let* ((opts (parse-options))
(update? (assoc-ref opts 'update?)) (update? (assoc-ref opts 'update?))
(updaters (options->updaters opts)) (updaters (options->updaters opts))
@ -458,65 +483,37 @@ update would trigger a complete rebuild."
;; Warn about missing updaters when a package is explicitly given on ;; Warn about missing updaters when a package is explicitly given on
;; the command line. ;; the command line.
(warn? (or (assoc-ref opts 'argument) (warn? (and (or (assoc-ref opts 'argument)
(assoc-ref opts 'expression))) (assoc-ref opts 'expression))
(args-packages (not recursive?))))
(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)))))
(with-error-handling (with-error-handling
(with-store store (with-store store
(run-with-store store (run-with-store store
(cond (mlet %store-monad ((packages (options->packages opts)))
(list-dependent? (cond
(list-dependents packages)) (list-dependent?
(list-transitive? (list-dependents packages))
(list-transitive packages)) (list-transitive?
(recursive? (list-transitive packages))
(refresh-recursive packages)) (update?
(update? (parameterize ((%openpgp-key-server
(parameterize ((%openpgp-key-server (or (assoc-ref opts 'key-server)
(or (assoc-ref opts 'key-server) (%openpgp-key-server)))
(%openpgp-key-server))) (%gpg-command
(%gpg-command (or (assoc-ref opts 'gpg-command)
(or (assoc-ref opts 'gpg-command) (%gpg-command)))
(%gpg-command))) (current-keyring
(current-keyring (or (assoc-ref opts 'keyring)
(or (assoc-ref opts 'keyring) (string-append (config-directory)
(string-append (config-directory) "/upstream/trustedkeys.kbx"))))
"/upstream/trustedkeys.kbx")))) (for-each
(for-each (cut update-package store <> updaters
(cut update-package store <> updaters #:key-download key-download
#:key-download key-download #:warn? warn?)
#:warn? warn?) packages)
packages) (return #t)))
(with-monad %store-monad (else
(return #t)))) (for-each (cut check-for-package-update <> updaters
(else #:warn? warn?)
(for-each (cut check-for-package-update <> updaters packages)
#:warn? warn?)
packages)
(with-monad %store-monad
(return #t))))))))) (return #t)))))))))