mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -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:
Ricardo Wurmus
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 © 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.
|
||||
;;;
|
||||
|
|
@ -296,7 +297,7 @@ (define* (update-package store package updaters
|
|||
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)
|
||||
|
|
@ -310,6 +311,26 @@ (define* (update-package store package updaters
|
|||
(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)))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
|
||||
;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
|
@ -45,6 +46,7 @@ (define-module (guix upstream)
|
|||
upstream-source-urls
|
||||
upstream-source-signature-urls
|
||||
upstream-source-archive-types
|
||||
upstream-source-input-changes
|
||||
|
||||
url-prefix-predicate
|
||||
coalesce-sources
|
||||
|
|
@ -56,6 +58,12 @@ (define-module (guix upstream)
|
|||
upstream-updater-predicate
|
||||
upstream-updater-latest
|
||||
|
||||
upstream-input-change?
|
||||
upstream-input-change-name
|
||||
upstream-input-change-type
|
||||
upstream-input-change-action
|
||||
changed-inputs
|
||||
|
||||
%updaters
|
||||
lookup-updater
|
||||
|
||||
|
|
@ -82,7 +90,73 @@ (define-record-type* <upstream-source>
|
|||
(version upstream-source-version) ;string
|
||||
(urls upstream-source-urls) ;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)
|
||||
"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
|
||||
#:key (key-download 'interactive))
|
||||
"Return the new version and the file name of the new version tarball for
|
||||
PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a
|
||||
download policy for missing OpenPGP keys; allowed values: 'always', 'never',
|
||||
and 'interactive' (default)."
|
||||
"Return the new version, the file name of the new version tarball, and input
|
||||
changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date.
|
||||
KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
|
||||
values: 'always', 'never', and 'interactive' (default)."
|
||||
(match (package-latest-release* package updaters)
|
||||
(($ <upstream-source> _ version urls signature-urls)
|
||||
(($ <upstream-source> _ version urls signature-urls changes)
|
||||
(let*-values (((name)
|
||||
(package-name package))
|
||||
((archive-type)
|
||||
|
|
@ -299,9 +373,9 @@ (define* (package-update store package updaters
|
|||
(or signature-urls (circular-list #f)))))
|
||||
(let ((tarball (download-tarball store url signature-url
|
||||
#:key-download key-download)))
|
||||
(values version tarball))))
|
||||
(values version tarball changes))))
|
||||
(#f
|
||||
(values #f #f))))
|
||||
(values #f #f #f))))
|
||||
|
||||
(define (update-package-source package version hash)
|
||||
"Modify the source file that defines PACKAGE to refer to VERSION,
|
||||
|
|
|
|||
Loading…
Reference in a new issue