mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 15:36:20 -05:00
refresh: Suggest input changes when updating.
* guix/upstream.scm (<upstream-source>)[input-changes]: New field. (<upstream-input-change>): New record. (upstream-input-change?, upstream-input-change-name, upstream-input-change-type, upstream-input-change-action, changed-inputs): New procedures. (package-update): Pass along input changes. * guix/script/refresh.scm (update-package): Process input changes.
This commit is contained in:
parent
ea600ff709
commit
7e634c2f53
2 changed files with 104 additions and 9 deletions
|
@ -6,6 +6,7 @@
|
||||||
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
|
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
|
||||||
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||||
;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
|
;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
|
||||||
|
;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -296,7 +297,7 @@ (define* (update-package store package updaters
|
||||||
values: 'interactive' (default), 'always', and 'never'. When WARN? is true,
|
values: 'interactive' (default), 'always', and 'never'. When WARN? is true,
|
||||||
warn about packages that have no matching updater."
|
warn about packages that have no matching updater."
|
||||||
(if (lookup-updater package updaters)
|
(if (lookup-updater package updaters)
|
||||||
(let-values (((version tarball)
|
(let-values (((version tarball changes)
|
||||||
(package-update store package updaters
|
(package-update store package updaters
|
||||||
#:key-download key-download))
|
#:key-download key-download))
|
||||||
((loc)
|
((loc)
|
||||||
|
@ -310,6 +311,26 @@ (define* (update-package store package updaters
|
||||||
(location->string loc)
|
(location->string loc)
|
||||||
(package-name package)
|
(package-name package)
|
||||||
(package-version package) version)
|
(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
|
(let ((hash (call-with-input-file tarball
|
||||||
port-sha256)))
|
port-sha256)))
|
||||||
(update-package-source package version hash)))
|
(update-package-source package version hash)))
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
|
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
|
;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
|
||||||
|
;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -45,6 +46,7 @@ (define-module (guix upstream)
|
||||||
upstream-source-urls
|
upstream-source-urls
|
||||||
upstream-source-signature-urls
|
upstream-source-signature-urls
|
||||||
upstream-source-archive-types
|
upstream-source-archive-types
|
||||||
|
upstream-source-input-changes
|
||||||
|
|
||||||
url-prefix-predicate
|
url-prefix-predicate
|
||||||
coalesce-sources
|
coalesce-sources
|
||||||
|
@ -56,6 +58,12 @@ (define-module (guix upstream)
|
||||||
upstream-updater-predicate
|
upstream-updater-predicate
|
||||||
upstream-updater-latest
|
upstream-updater-latest
|
||||||
|
|
||||||
|
upstream-input-change?
|
||||||
|
upstream-input-change-name
|
||||||
|
upstream-input-change-type
|
||||||
|
upstream-input-change-action
|
||||||
|
changed-inputs
|
||||||
|
|
||||||
%updaters
|
%updaters
|
||||||
lookup-updater
|
lookup-updater
|
||||||
|
|
||||||
|
@ -82,7 +90,73 @@ (define-record-type* <upstream-source>
|
||||||
(version upstream-source-version) ;string
|
(version upstream-source-version) ;string
|
||||||
(urls upstream-source-urls) ;list of strings
|
(urls upstream-source-urls) ;list of strings
|
||||||
(signature-urls upstream-source-signature-urls ;#f | list of strings
|
(signature-urls upstream-source-signature-urls ;#f | list of strings
|
||||||
(default #f)))
|
(default #f))
|
||||||
|
(input-changes upstream-source-input-changes
|
||||||
|
(default '()) (thunked)))
|
||||||
|
|
||||||
|
;; Representation of an upstream input change.
|
||||||
|
(define-record-type* <upstream-input-change>
|
||||||
|
upstream-input-change make-upstream-input-change
|
||||||
|
upstream-input-change?
|
||||||
|
(name upstream-input-change-name) ;string
|
||||||
|
(type upstream-input-change-type) ;symbol: regular | native | propagated
|
||||||
|
(action upstream-input-change-action)) ;symbol: add | remove
|
||||||
|
|
||||||
|
(define (changed-inputs package package-sexp)
|
||||||
|
"Return a list of input changes for PACKAGE based on the newly imported
|
||||||
|
S-expression PACKAGE-SEXP."
|
||||||
|
(match package-sexp
|
||||||
|
((and expr ('package fields ...))
|
||||||
|
(let* ((input->name (match-lambda ((name pkg . out) name)))
|
||||||
|
(new-regular
|
||||||
|
(match expr
|
||||||
|
((path *** ('inputs
|
||||||
|
('quasiquote ((label ('unquote sym)) ...)))) label)
|
||||||
|
(_ '())))
|
||||||
|
(new-native
|
||||||
|
(match expr
|
||||||
|
((path *** ('native-inputs
|
||||||
|
('quasiquote ((label ('unquote sym)) ...)))) label)
|
||||||
|
(_ '())))
|
||||||
|
(new-propagated
|
||||||
|
(match expr
|
||||||
|
((path *** ('propagated-inputs
|
||||||
|
('quasiquote ((label ('unquote sym)) ...)))) label)
|
||||||
|
(_ '())))
|
||||||
|
(current-regular
|
||||||
|
(map input->name (package-inputs package)))
|
||||||
|
(current-native
|
||||||
|
(map input->name (package-native-inputs package)))
|
||||||
|
(current-propagated
|
||||||
|
(map input->name (package-propagated-inputs package))))
|
||||||
|
(append-map
|
||||||
|
(match-lambda
|
||||||
|
((action type names)
|
||||||
|
(map (lambda (name)
|
||||||
|
(upstream-input-change
|
||||||
|
(name name)
|
||||||
|
(type type)
|
||||||
|
(action action)))
|
||||||
|
names)))
|
||||||
|
`((add regular
|
||||||
|
,(lset-difference equal?
|
||||||
|
new-regular current-regular))
|
||||||
|
(remove regular
|
||||||
|
,(lset-difference equal?
|
||||||
|
current-regular new-regular))
|
||||||
|
(add native
|
||||||
|
,(lset-difference equal?
|
||||||
|
new-native current-native))
|
||||||
|
(remove native
|
||||||
|
,(lset-difference equal?
|
||||||
|
current-native new-native))
|
||||||
|
(add propagated
|
||||||
|
,(lset-difference equal?
|
||||||
|
new-propagated current-propagated))
|
||||||
|
(remove propagated
|
||||||
|
,(lset-difference equal?
|
||||||
|
current-propagated new-propagated))))))
|
||||||
|
(_ '())))
|
||||||
|
|
||||||
(define (url-prefix-predicate prefix)
|
(define (url-prefix-predicate prefix)
|
||||||
"Return a predicate that returns true when passed a package where one of its
|
"Return a predicate that returns true when passed a package where one of its
|
||||||
|
@ -268,12 +342,12 @@ (define (find2 pred lst1 lst2)
|
||||||
|
|
||||||
(define* (package-update store package updaters
|
(define* (package-update store package updaters
|
||||||
#:key (key-download 'interactive))
|
#:key (key-download 'interactive))
|
||||||
"Return the new version and the file name of the new version tarball for
|
"Return the new version, the file name of the new version tarball, and input
|
||||||
PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a
|
changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date.
|
||||||
download policy for missing OpenPGP keys; allowed values: 'always', 'never',
|
KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
|
||||||
and 'interactive' (default)."
|
values: 'always', 'never', and 'interactive' (default)."
|
||||||
(match (package-latest-release* package updaters)
|
(match (package-latest-release* package updaters)
|
||||||
(($ <upstream-source> _ version urls signature-urls)
|
(($ <upstream-source> _ version urls signature-urls changes)
|
||||||
(let*-values (((name)
|
(let*-values (((name)
|
||||||
(package-name package))
|
(package-name package))
|
||||||
((archive-type)
|
((archive-type)
|
||||||
|
@ -299,9 +373,9 @@ (define* (package-update store package updaters
|
||||||
(or signature-urls (circular-list #f)))))
|
(or signature-urls (circular-list #f)))))
|
||||||
(let ((tarball (download-tarball store url signature-url
|
(let ((tarball (download-tarball store url signature-url
|
||||||
#:key-download key-download)))
|
#:key-download key-download)))
|
||||||
(values version tarball))))
|
(values version tarball changes))))
|
||||||
(#f
|
(#f
|
||||||
(values #f #f))))
|
(values #f #f #f))))
|
||||||
|
|
||||||
(define (update-package-source package version hash)
|
(define (update-package-source package version hash)
|
||||||
"Modify the source file that defines PACKAGE to refer to VERSION,
|
"Modify the source file that defines PACKAGE to refer to VERSION,
|
||||||
|
|
Loading…
Reference in a new issue