gnu-maintenance: Generalize, leading to (guix upstream).
* guix/gnu-maintenance.scm (<gnu-release>): Remove. (coalesce-releases): Move to upstream.scm. Rename to 'coalesce-sources'; adjust callers. (releases, latest-release): Return <upstream-source> objects instead of <gnu-release> objects. (latest-release*, non-emacs-gnu-package?): New procedures. (gnu-release-archive-types): Remove. (%gnu-updater): New variable. (package-update-path, download-tarball, package-update, update-package-source): Move to... * guix/upstream.scm: ... here. New file. * Makefile.am (MODULES): Add it. * po/guix/POTFILES.in: Replace gnu-maintenance.scm with upstream.scm. * guix/scripts/refresh.scm (%updaters): New variable. (update-package): Adjust to new 'package-update' interface. (guix-refresh): Adjust to new 'package-update-path'. Remove 'false-if-exception' around it.
This commit is contained in:
parent
cbaf0f11dd
commit
0a7c5a09fe
|
@ -48,6 +48,7 @@ MODULES = \
|
||||||
guix/nar.scm \
|
guix/nar.scm \
|
||||||
guix/derivations.scm \
|
guix/derivations.scm \
|
||||||
guix/gnu-maintenance.scm \
|
guix/gnu-maintenance.scm \
|
||||||
|
guix/upstream.scm \
|
||||||
guix/licenses.scm \
|
guix/licenses.scm \
|
||||||
guix/build-system.scm \
|
guix/build-system.scm \
|
||||||
guix/build-system/cmake.scm \
|
guix/build-system/cmake.scm \
|
||||||
|
|
|
@ -29,16 +29,10 @@
|
||||||
#:use-module (system foreign)
|
#:use-module (system foreign)
|
||||||
#:use-module (guix http-client)
|
#:use-module (guix http-client)
|
||||||
#:use-module (guix ftp-client)
|
#:use-module (guix ftp-client)
|
||||||
#:use-module (guix ui)
|
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module (guix records)
|
#:use-module (guix records)
|
||||||
|
#:use-module (guix upstream)
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
#:use-module ((guix download) #:select (download-to-store))
|
|
||||||
#:use-module (guix gnupg)
|
|
||||||
#:use-module (rnrs io ports)
|
|
||||||
#:use-module (guix base32)
|
|
||||||
#:use-module ((guix build utils)
|
|
||||||
#:select (substitute))
|
|
||||||
#:export (gnu-package-name
|
#:export (gnu-package-name
|
||||||
gnu-package-mundane-name
|
gnu-package-mundane-name
|
||||||
gnu-package-copyright-holder
|
gnu-package-copyright-holder
|
||||||
|
@ -56,21 +50,12 @@
|
||||||
find-packages
|
find-packages
|
||||||
gnu-package?
|
gnu-package?
|
||||||
|
|
||||||
gnu-release?
|
|
||||||
gnu-release-package
|
|
||||||
gnu-release-version
|
|
||||||
gnu-release-directory
|
|
||||||
gnu-release-files
|
|
||||||
|
|
||||||
releases
|
releases
|
||||||
latest-release
|
latest-release
|
||||||
gnu-release-archive-types
|
gnu-release-archive-types
|
||||||
gnu-package-name->name+version
|
gnu-package-name->name+version
|
||||||
|
|
||||||
download-tarball
|
%gnu-updater))
|
||||||
package-update-path
|
|
||||||
package-update
|
|
||||||
update-package-source))
|
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
;;;
|
;;;
|
||||||
|
@ -218,13 +203,6 @@ network to check in GNU's database."
|
||||||
;;; Latest release.
|
;;; Latest release.
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define-record-type* <gnu-release> gnu-release make-gnu-release
|
|
||||||
gnu-release?
|
|
||||||
(package gnu-release-package)
|
|
||||||
(version gnu-release-version)
|
|
||||||
(directory gnu-release-directory)
|
|
||||||
(files gnu-release-files))
|
|
||||||
|
|
||||||
(define (ftp-server/directory project)
|
(define (ftp-server/directory project)
|
||||||
"Return the FTP server and directory where PROJECT's tarball are
|
"Return the FTP server and directory where PROJECT's tarball are
|
||||||
stored."
|
stored."
|
||||||
|
@ -284,29 +262,6 @@ true."
|
||||||
(gnu-package-name->name+version (sans-extension tarball))))
|
(gnu-package-name->name+version (sans-extension tarball))))
|
||||||
version))
|
version))
|
||||||
|
|
||||||
(define (coalesce-releases releases)
|
|
||||||
"Coalesce the elements of RELEASES that correspond to the same version."
|
|
||||||
(define (same-version? r1 r2)
|
|
||||||
(string=? (gnu-release-version r1) (gnu-release-version r2)))
|
|
||||||
|
|
||||||
(define (release>? r1 r2)
|
|
||||||
(version>? (gnu-release-version r1) (gnu-release-version r2)))
|
|
||||||
|
|
||||||
(fold (lambda (release result)
|
|
||||||
(match result
|
|
||||||
((head . tail)
|
|
||||||
(if (same-version? release head)
|
|
||||||
(cons (gnu-release
|
|
||||||
(inherit release)
|
|
||||||
(files (append (gnu-release-files release)
|
|
||||||
(gnu-release-files head))))
|
|
||||||
tail)
|
|
||||||
(cons release result)))
|
|
||||||
(()
|
|
||||||
(list release))))
|
|
||||||
'()
|
|
||||||
(sort releases release>?)))
|
|
||||||
|
|
||||||
(define (releases project)
|
(define (releases project)
|
||||||
"Return the list of releases of PROJECT as a list of release name/directory
|
"Return the list of releases of PROJECT as a list of release name/directory
|
||||||
pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). "
|
pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). "
|
||||||
|
@ -319,13 +274,24 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
|
||||||
(match directories
|
(match directories
|
||||||
(()
|
(()
|
||||||
(ftp-close conn)
|
(ftp-close conn)
|
||||||
(coalesce-releases result))
|
(coalesce-sources result))
|
||||||
((directory rest ...)
|
((directory rest ...)
|
||||||
(let* ((files (ftp-list conn directory))
|
(let* ((files (ftp-list conn directory))
|
||||||
(subdirs (filter-map (match-lambda
|
(subdirs (filter-map (match-lambda
|
||||||
((name 'directory . _) name)
|
((name 'directory . _) name)
|
||||||
(_ #f))
|
(_ #f))
|
||||||
files)))
|
files)))
|
||||||
|
(define (file->url file)
|
||||||
|
(string-append "ftp://" server directory "/" file))
|
||||||
|
|
||||||
|
(define (file->source file)
|
||||||
|
(let ((url (file->url file)))
|
||||||
|
(upstream-source
|
||||||
|
(package project)
|
||||||
|
(version (tarball->version file))
|
||||||
|
(urls (list url))
|
||||||
|
(signature-urls (list (string-append url ".sig"))))))
|
||||||
|
|
||||||
(loop (append (map (cut string-append directory "/" <>)
|
(loop (append (map (cut string-append directory "/" <>)
|
||||||
subdirs)
|
subdirs)
|
||||||
rest)
|
rest)
|
||||||
|
@ -336,13 +302,8 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
|
||||||
;; guile-www; in mit-scheme, filter out binaries.
|
;; guile-www; in mit-scheme, filter out binaries.
|
||||||
(filter-map (match-lambda
|
(filter-map (match-lambda
|
||||||
((file 'file . _)
|
((file 'file . _)
|
||||||
(if (release-file? project file)
|
(and (release-file? project file)
|
||||||
(gnu-release
|
(file->source file)))
|
||||||
(package project)
|
|
||||||
(version (tarball->version file))
|
|
||||||
(directory directory)
|
|
||||||
(files (list file)))
|
|
||||||
#f))
|
|
||||||
(_ #f))
|
(_ #f))
|
||||||
files)
|
files)
|
||||||
result))))))))
|
result))))))))
|
||||||
|
@ -355,7 +316,7 @@ open (resp. close) FTP connections; this can be useful to reuse connections."
|
||||||
(if (version>? a b) a b))
|
(if (version>? a b) a b))
|
||||||
|
|
||||||
(define (latest-release a b)
|
(define (latest-release a b)
|
||||||
(if (version>? (gnu-release-version a) (gnu-release-version b))
|
(if (version>? (upstream-source-version a) (upstream-source-version b))
|
||||||
a b))
|
a b))
|
||||||
|
|
||||||
(define contains-digit?
|
(define contains-digit?
|
||||||
|
@ -368,6 +329,17 @@ open (resp. close) FTP connections; this can be useful to reuse connections."
|
||||||
(let-values (((server directory) (ftp-server/directory project)))
|
(let-values (((server directory) (ftp-server/directory project)))
|
||||||
(define conn (ftp-open server))
|
(define conn (ftp-open server))
|
||||||
|
|
||||||
|
(define (file->url file)
|
||||||
|
(string-append "ftp://" server directory "/" file))
|
||||||
|
|
||||||
|
(define (file->source file)
|
||||||
|
(let ((url (file->url file)))
|
||||||
|
(upstream-source
|
||||||
|
(package project)
|
||||||
|
(version (tarball->version file))
|
||||||
|
(urls (list url))
|
||||||
|
(signature-urls (list (string-append url ".sig"))))))
|
||||||
|
|
||||||
(let loop ((directory directory)
|
(let loop ((directory directory)
|
||||||
(result #f))
|
(result #f))
|
||||||
(let* ((entries (ftp-list conn directory))
|
(let* ((entries (ftp-list conn directory))
|
||||||
|
@ -390,19 +362,14 @@ open (resp. close) FTP connections; this can be useful to reuse connections."
|
||||||
(releases (filter-map (match-lambda
|
(releases (filter-map (match-lambda
|
||||||
((file 'file . _)
|
((file 'file . _)
|
||||||
(and (release-file? project file)
|
(and (release-file? project file)
|
||||||
(gnu-release
|
(file->source file)))
|
||||||
(package project)
|
|
||||||
(version
|
|
||||||
(tarball->version file))
|
|
||||||
(directory directory)
|
|
||||||
(files (list file)))))
|
|
||||||
(_ #f))
|
(_ #f))
|
||||||
entries)))
|
entries)))
|
||||||
|
|
||||||
;; Assume that SUBDIRS correspond to versions, and jump into the
|
;; Assume that SUBDIRS correspond to versions, and jump into the
|
||||||
;; one with the highest version number.
|
;; one with the highest version number.
|
||||||
(let* ((release (reduce latest-release #f
|
(let* ((release (reduce latest-release #f
|
||||||
(coalesce-releases releases)))
|
(coalesce-sources releases)))
|
||||||
(result (if (and result release)
|
(result (if (and result release)
|
||||||
(latest-release release result)
|
(latest-release release result)
|
||||||
(or release result)))
|
(or release result)))
|
||||||
|
@ -414,10 +381,18 @@ open (resp. close) FTP connections; this can be useful to reuse connections."
|
||||||
(ftp-close conn)
|
(ftp-close conn)
|
||||||
result)))))))
|
result)))))))
|
||||||
|
|
||||||
(define (gnu-release-archive-types release)
|
(define (latest-release* package)
|
||||||
"Return the available types of archives for RELEASE---a list of strings such
|
"Like 'latest-release', but ignore FTP errors that might occur when PACKAGE
|
||||||
as \"gz\" or \"xz\"."
|
is not actually a GNU package, or not hosted on ftp.gnu.org, or not under that
|
||||||
(map file-extension (gnu-release-files release)))
|
name (this is the case for \"emacs-auctex\", for instance.)"
|
||||||
|
(catch 'ftp-error
|
||||||
|
(lambda ()
|
||||||
|
(latest-release package))
|
||||||
|
(lambda (key port . rest)
|
||||||
|
(if (ftp-connection? port)
|
||||||
|
(ftp-close port)
|
||||||
|
(close-port port))
|
||||||
|
#f)))
|
||||||
|
|
||||||
(define %package-name-rx
|
(define %package-name-rx
|
||||||
;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
|
;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
|
||||||
|
@ -431,121 +406,15 @@ as \"gz\" or \"xz\"."
|
||||||
(values name+version #f)
|
(values name+version #f)
|
||||||
(values (match:substring match 1) (match:substring match 2)))))
|
(values (match:substring match 1) (match:substring match 2)))))
|
||||||
|
|
||||||
|
(define (non-emacs-gnu-package? package)
|
||||||
;;;
|
"Return true if PACKAGE is a non-Emacs GNU package. This excludes AucTeX,
|
||||||
;;; Auto-update.
|
for instance, whose releases are now uploaded to elpa.gnu.org."
|
||||||
;;;
|
(and (not (string-prefix? "emacs-" (package-name package)))
|
||||||
|
(gnu-package? package)))
|
||||||
|
|
||||||
(define (package-update-path package)
|
(define %gnu-updater
|
||||||
"Return an update path for PACKAGE, or #f if no update is needed."
|
(upstream-updater 'gnu
|
||||||
(and (gnu-package? package)
|
non-emacs-gnu-package?
|
||||||
(match (latest-release (package-name package))
|
latest-release*))
|
||||||
(($ <gnu-release> name version directory)
|
|
||||||
(and (version>? version (package-version package))
|
|
||||||
`(,version . ,directory)))
|
|
||||||
(_ #f))))
|
|
||||||
|
|
||||||
(define* (download-tarball store project directory version
|
|
||||||
#:key (archive-type "gz")
|
|
||||||
(key-download 'interactive))
|
|
||||||
"Download PROJECT's tarball over FTP and check its OpenPGP signature. On
|
|
||||||
success, return the tarball file name. KEY-DOWNLOAD specifies a download
|
|
||||||
policy for missing OpenPGP keys; allowed values: 'interactive' (default),
|
|
||||||
'always', and 'never'."
|
|
||||||
(let* ((server (ftp-server/directory project))
|
|
||||||
(base (string-append project "-" version ".tar." archive-type))
|
|
||||||
(url (string-append "ftp://" server "/" directory "/" base))
|
|
||||||
(sig-url (string-append url ".sig"))
|
|
||||||
(tarball (download-to-store store url))
|
|
||||||
(sig (download-to-store store sig-url)))
|
|
||||||
(let ((ret (gnupg-verify* sig tarball #:key-download key-download)))
|
|
||||||
(if ret
|
|
||||||
tarball
|
|
||||||
(begin
|
|
||||||
(warning (_ "signature verification failed for `~a'~%")
|
|
||||||
base)
|
|
||||||
(warning (_ "(could be because the public key is not in your keyring)~%"))
|
|
||||||
#f)))))
|
|
||||||
|
|
||||||
(define* (package-update store package #: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)."
|
|
||||||
(match (package-update-path package)
|
|
||||||
((version . directory)
|
|
||||||
(let-values (((name)
|
|
||||||
(package-name package))
|
|
||||||
((archive-type)
|
|
||||||
(let ((source (package-source package)))
|
|
||||||
(or (and (origin? source)
|
|
||||||
(file-extension (origin-uri source)))
|
|
||||||
"gz"))))
|
|
||||||
(let ((tarball (download-tarball store name directory version
|
|
||||||
#:archive-type archive-type
|
|
||||||
#:key-download key-download)))
|
|
||||||
(values version tarball))))
|
|
||||||
(_
|
|
||||||
(values #f #f))))
|
|
||||||
|
|
||||||
(define (update-package-source package version hash)
|
|
||||||
"Modify the source file that defines PACKAGE to refer to VERSION,
|
|
||||||
whose tarball has SHA256 HASH (a bytevector). Return the new version string
|
|
||||||
if an update was made, and #f otherwise."
|
|
||||||
(define (new-line line matches replacement)
|
|
||||||
;; Iterate over MATCHES and return the modified line based on LINE.
|
|
||||||
;; Replace each match with REPLACEMENT.
|
|
||||||
(let loop ((m* matches) ; matches
|
|
||||||
(o 0) ; offset in L
|
|
||||||
(r '())) ; result
|
|
||||||
(match m*
|
|
||||||
(()
|
|
||||||
(let ((r (cons (substring line o) r)))
|
|
||||||
(string-concatenate-reverse r)))
|
|
||||||
((m . rest)
|
|
||||||
(loop rest
|
|
||||||
(match:end m)
|
|
||||||
(cons* replacement
|
|
||||||
(substring line o (match:start m))
|
|
||||||
r))))))
|
|
||||||
|
|
||||||
(define (update-source file old-version version
|
|
||||||
old-hash hash)
|
|
||||||
;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION
|
|
||||||
;; and occurrences of OLD-HASH by HASH (base32 representation thereof).
|
|
||||||
|
|
||||||
;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in
|
|
||||||
;; different unrelated places, we may modify it more than needed, for
|
|
||||||
;; instance. We should try to make changes only within the sexp that
|
|
||||||
;; corresponds to the definition of PACKAGE.
|
|
||||||
(let ((old-hash (bytevector->nix-base32-string old-hash))
|
|
||||||
(hash (bytevector->nix-base32-string hash)))
|
|
||||||
(substitute file
|
|
||||||
`((,(regexp-quote old-version)
|
|
||||||
. ,(cut new-line <> <> version))
|
|
||||||
(,(regexp-quote old-hash)
|
|
||||||
. ,(cut new-line <> <> hash))))
|
|
||||||
version))
|
|
||||||
|
|
||||||
(let ((name (package-name package))
|
|
||||||
(loc (package-field-location package 'version)))
|
|
||||||
(if loc
|
|
||||||
(let ((old-version (package-version package))
|
|
||||||
(old-hash (origin-sha256 (package-source package)))
|
|
||||||
(file (and=> (location-file loc)
|
|
||||||
(cut search-path %load-path <>))))
|
|
||||||
(if file
|
|
||||||
(update-source file
|
|
||||||
old-version version
|
|
||||||
old-hash hash)
|
|
||||||
(begin
|
|
||||||
(warning (_ "~a: could not locate source file")
|
|
||||||
(location-file loc))
|
|
||||||
#f)))
|
|
||||||
(begin
|
|
||||||
(format (current-error-port)
|
|
||||||
(_ "~a: ~a: no `version' field in source; skipping~%")
|
|
||||||
(location->string (package-location package))
|
|
||||||
name)))))
|
|
||||||
|
|
||||||
;;; gnu-maintenance.scm ends here
|
;;; gnu-maintenance.scm ends here
|
||||||
|
|
|
@ -25,7 +25,8 @@
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
#:use-module (guix gnu-maintenance)
|
#:use-module (guix upstream)
|
||||||
|
#:use-module ((guix gnu-maintenance) #:select (%gnu-updater))
|
||||||
#:use-module (guix gnupg)
|
#:use-module (guix gnupg)
|
||||||
#:use-module (gnu packages)
|
#:use-module (gnu packages)
|
||||||
#:use-module ((gnu packages commencement) #:select (%final-inputs))
|
#:use-module ((gnu packages commencement) #:select (%final-inputs))
|
||||||
|
@ -124,6 +125,15 @@ specified with `--select'.\n"))
|
||||||
(newline)
|
(newline)
|
||||||
(show-bug-report-information))
|
(show-bug-report-information))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Updates.
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define %updaters
|
||||||
|
;; List of "updaters" used by default.
|
||||||
|
(list %gnu-updater))
|
||||||
|
|
||||||
(define* (update-package store package #:key (key-download 'interactive))
|
(define* (update-package store package #:key (key-download 'interactive))
|
||||||
"Update the source file that defines PACKAGE with the new version.
|
"Update the source file that defines PACKAGE with the new version.
|
||||||
KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
|
KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
|
||||||
|
@ -131,12 +141,12 @@ values: 'interactive' (default), 'always', and 'never'."
|
||||||
(let-values (((version tarball)
|
(let-values (((version tarball)
|
||||||
(catch #t
|
(catch #t
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(package-update store package #:key-download key-download))
|
(package-update store package %updaters
|
||||||
|
#:key-download key-download))
|
||||||
(lambda _
|
(lambda _
|
||||||
(values #f #f))))
|
(values #f #f))))
|
||||||
((loc)
|
((loc)
|
||||||
(or (package-field-location package
|
(or (package-field-location package 'version)
|
||||||
'version)
|
|
||||||
(package-location package))))
|
(package-location package))))
|
||||||
(when version
|
(when version
|
||||||
(if (and=> tarball file-exists?)
|
(if (and=> tarball file-exists?)
|
||||||
|
@ -153,7 +163,6 @@ values: 'interactive' (default), 'always', and 'never'."
|
||||||
downloaded and authenticated; not updating~%")
|
downloaded and authenticated; not updating~%")
|
||||||
(package-name package) version)))))
|
(package-name package) version)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Entry point.
|
;;; Entry point.
|
||||||
|
@ -262,14 +271,14 @@ dependent packages are rebuilt: ~{~a~^ ~}~%"
|
||||||
packages))))
|
packages))))
|
||||||
(else
|
(else
|
||||||
(for-each (lambda (package)
|
(for-each (lambda (package)
|
||||||
(match (false-if-exception (package-update-path package))
|
(match (package-update-path package %updaters)
|
||||||
((new-version . directory)
|
((? upstream-source? source)
|
||||||
(let ((loc (or (package-field-location package 'version)
|
(let ((loc (or (package-field-location package 'version)
|
||||||
(package-location package))))
|
(package-location package))))
|
||||||
(format (current-error-port)
|
(format (current-error-port)
|
||||||
(_ "~a: ~a would be upgraded from ~a to ~a~%")
|
(_ "~a: ~a would be upgraded from ~a to ~a~%")
|
||||||
(location->string loc)
|
(location->string loc)
|
||||||
(package-name package) (package-version package)
|
(package-name package) (package-version package)
|
||||||
new-version)))
|
(upstream-source-version source))))
|
||||||
(_ #f)))
|
(#f #f)))
|
||||||
packages))))))
|
packages))))))
|
||||||
|
|
|
@ -0,0 +1,259 @@
|
||||||
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
|
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
;;;
|
||||||
|
;;; This file is part of GNU Guix.
|
||||||
|
;;;
|
||||||
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||||
|
;;; under the terms of the GNU General Public License as published by
|
||||||
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||||
|
;;; your option) any later version.
|
||||||
|
;;;
|
||||||
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||||
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;;; GNU General Public License for more details.
|
||||||
|
;;;
|
||||||
|
;;; You should have received a copy of the GNU General Public License
|
||||||
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
(define-module (guix upstream)
|
||||||
|
#:use-module (guix records)
|
||||||
|
#:use-module (guix utils)
|
||||||
|
#:use-module ((guix download)
|
||||||
|
#:select (download-to-store))
|
||||||
|
#:use-module ((guix build utils)
|
||||||
|
#:select (substitute))
|
||||||
|
#:use-module (guix gnupg)
|
||||||
|
#:use-module (guix packages)
|
||||||
|
#:use-module (guix ui)
|
||||||
|
#:use-module (guix base32)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-9)
|
||||||
|
#:use-module (srfi srfi-11)
|
||||||
|
#:use-module (srfi srfi-26)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (ice-9 regex)
|
||||||
|
#:export (upstream-source
|
||||||
|
upstream-source?
|
||||||
|
upstream-source-package
|
||||||
|
upstream-source-version
|
||||||
|
upstream-source-urls
|
||||||
|
upstream-source-signature-urls
|
||||||
|
|
||||||
|
coalesce-sources
|
||||||
|
|
||||||
|
upstream-updater
|
||||||
|
upstream-updater?
|
||||||
|
upstream-updater-name
|
||||||
|
upstream-updater-predicate
|
||||||
|
upstream-updater-latest
|
||||||
|
|
||||||
|
download-tarball
|
||||||
|
package-update-path
|
||||||
|
package-update
|
||||||
|
update-package-source))
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
;;;
|
||||||
|
;;; This module provides tools to represent and manipulate a upstream source
|
||||||
|
;;; code, and to auto-update package recipes.
|
||||||
|
;;;
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
;; Representation of upstream's source. There can be several URLs--e.g.,
|
||||||
|
;; tar.gz, tar.gz, etc. There can be correspond signature URLs, one per
|
||||||
|
;; source URL.
|
||||||
|
(define-record-type* <upstream-source>
|
||||||
|
upstream-source make-upstream-source
|
||||||
|
upstream-source?
|
||||||
|
(package upstream-source-package) ;string
|
||||||
|
(version upstream-source-version) ;string
|
||||||
|
(urls upstream-source-urls) ;list of strings
|
||||||
|
(signature-urls upstream-source-signature-urls ;#f | list of strings
|
||||||
|
(default #f)))
|
||||||
|
|
||||||
|
(define (upstream-source-archive-types release)
|
||||||
|
"Return the available types of archives for RELEASE---a list of strings such
|
||||||
|
as \"gz\" or \"xz\"."
|
||||||
|
(map file-extension (upstream-source-urls release)))
|
||||||
|
|
||||||
|
(define (coalesce-sources sources)
|
||||||
|
"Coalesce the elements of SOURCES, a list of <upstream-source>, that
|
||||||
|
correspond to the same version."
|
||||||
|
(define (same-version? r1 r2)
|
||||||
|
(string=? (upstream-source-version r1) (upstream-source-version r2)))
|
||||||
|
|
||||||
|
(define (release>? r1 r2)
|
||||||
|
(version>? (upstream-source-version r1) (upstream-source-version r2)))
|
||||||
|
|
||||||
|
(fold (lambda (release result)
|
||||||
|
(match result
|
||||||
|
((head . tail)
|
||||||
|
(if (same-version? release head)
|
||||||
|
(cons (upstream-source
|
||||||
|
(inherit release)
|
||||||
|
(urls (append (upstream-source-urls release)
|
||||||
|
(upstream-source-urls head)))
|
||||||
|
(signature-urls
|
||||||
|
(append (upstream-source-signature-urls release)
|
||||||
|
(upstream-source-signature-urls head))))
|
||||||
|
tail)
|
||||||
|
(cons release result)))
|
||||||
|
(()
|
||||||
|
(list release))))
|
||||||
|
'()
|
||||||
|
(sort sources release>?)))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Auto-update.
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define-record-type <upstream-updater>
|
||||||
|
(upstream-updater name pred latest)
|
||||||
|
upstream-updater?
|
||||||
|
(name upstream-updater-name)
|
||||||
|
(pred upstream-updater-predicate)
|
||||||
|
(latest upstream-updater-latest))
|
||||||
|
|
||||||
|
(define (lookup-updater package updaters)
|
||||||
|
"Return an updater among UPDATERS that matches PACKAGE, or #f if none of
|
||||||
|
them matches."
|
||||||
|
(any (match-lambda
|
||||||
|
(($ <upstream-updater> _ pred latest)
|
||||||
|
(and (pred package) latest)))
|
||||||
|
updaters))
|
||||||
|
|
||||||
|
(define (package-update-path package updaters)
|
||||||
|
"Return an upstream source to update PACKAGE to, or #f if no update is
|
||||||
|
needed or known."
|
||||||
|
(match (lookup-updater package updaters)
|
||||||
|
((? procedure? latest-release)
|
||||||
|
(match (latest-release (package-name package))
|
||||||
|
((and source ($ <upstream-source> name version))
|
||||||
|
(and (version>? version (package-version package))
|
||||||
|
source))
|
||||||
|
(_ #f)))
|
||||||
|
(#f #f)))
|
||||||
|
|
||||||
|
(define* (download-tarball store url signature-url
|
||||||
|
#:key (key-download 'interactive))
|
||||||
|
"Download the tarball at URL to the store; check its OpenPGP signature at
|
||||||
|
SIGNATURE-URL, unless SIGNATURE-URL is false. On success, return the tarball
|
||||||
|
file name. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys;
|
||||||
|
allowed values: 'interactive' (default), 'always', and 'never'."
|
||||||
|
(let ((tarball (download-to-store store url)))
|
||||||
|
(if (not signature-url)
|
||||||
|
tarball
|
||||||
|
(let* ((sig (download-to-store store signature-url))
|
||||||
|
(ret (gnupg-verify* sig tarball #:key-download key-download)))
|
||||||
|
(if ret
|
||||||
|
tarball
|
||||||
|
(begin
|
||||||
|
(warning (_ "signature verification failed for `~a'~%")
|
||||||
|
url)
|
||||||
|
(warning (_ "(could be because the public key is not in your keyring)~%"))
|
||||||
|
#f))))))
|
||||||
|
|
||||||
|
(define (find2 pred lst1 lst2)
|
||||||
|
"Like 'find', but operate on items from both LST1 and LST2. Return two
|
||||||
|
values: the item from LST1 and the item from LST2 that match PRED."
|
||||||
|
(let loop ((lst1 lst1) (lst2 lst2))
|
||||||
|
(match lst1
|
||||||
|
((head1 . tail1)
|
||||||
|
(match lst2
|
||||||
|
((head2 . tail2)
|
||||||
|
(if (pred head1 head2)
|
||||||
|
(values head1 head2)
|
||||||
|
(loop tail1 tail2)))))
|
||||||
|
(()
|
||||||
|
(values #f #f)))))
|
||||||
|
|
||||||
|
(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)."
|
||||||
|
(match (package-update-path package updaters)
|
||||||
|
(($ <upstream-source> _ version urls signature-urls)
|
||||||
|
(let*-values (((name)
|
||||||
|
(package-name package))
|
||||||
|
((archive-type)
|
||||||
|
(match (and=> (package-source package) origin-uri)
|
||||||
|
((? string? uri)
|
||||||
|
(or (file-extension uri) "gz"))
|
||||||
|
(_
|
||||||
|
"gz")))
|
||||||
|
((url signature-url)
|
||||||
|
(find2 (lambda (url sig-url)
|
||||||
|
(string-suffix? archive-type url))
|
||||||
|
urls
|
||||||
|
(or signature-urls (circular-list #f)))))
|
||||||
|
(let ((tarball (download-tarball store url signature-url
|
||||||
|
#:key-download key-download)))
|
||||||
|
(values version tarball))))
|
||||||
|
(#f
|
||||||
|
(values #f #f))))
|
||||||
|
|
||||||
|
(define (update-package-source package version hash)
|
||||||
|
"Modify the source file that defines PACKAGE to refer to VERSION,
|
||||||
|
whose tarball has SHA256 HASH (a bytevector). Return the new version string
|
||||||
|
if an update was made, and #f otherwise."
|
||||||
|
(define (new-line line matches replacement)
|
||||||
|
;; Iterate over MATCHES and return the modified line based on LINE.
|
||||||
|
;; Replace each match with REPLACEMENT.
|
||||||
|
(let loop ((m* matches) ; matches
|
||||||
|
(o 0) ; offset in L
|
||||||
|
(r '())) ; result
|
||||||
|
(match m*
|
||||||
|
(()
|
||||||
|
(let ((r (cons (substring line o) r)))
|
||||||
|
(string-concatenate-reverse r)))
|
||||||
|
((m . rest)
|
||||||
|
(loop rest
|
||||||
|
(match:end m)
|
||||||
|
(cons* replacement
|
||||||
|
(substring line o (match:start m))
|
||||||
|
r))))))
|
||||||
|
|
||||||
|
(define (update-source file old-version version
|
||||||
|
old-hash hash)
|
||||||
|
;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION
|
||||||
|
;; and occurrences of OLD-HASH by HASH (base32 representation thereof).
|
||||||
|
|
||||||
|
;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in
|
||||||
|
;; different unrelated places, we may modify it more than needed, for
|
||||||
|
;; instance. We should try to make changes only within the sexp that
|
||||||
|
;; corresponds to the definition of PACKAGE.
|
||||||
|
(let ((old-hash (bytevector->nix-base32-string old-hash))
|
||||||
|
(hash (bytevector->nix-base32-string hash)))
|
||||||
|
(substitute file
|
||||||
|
`((,(regexp-quote old-version)
|
||||||
|
. ,(cut new-line <> <> version))
|
||||||
|
(,(regexp-quote old-hash)
|
||||||
|
. ,(cut new-line <> <> hash))))
|
||||||
|
version))
|
||||||
|
|
||||||
|
(let ((name (package-name package))
|
||||||
|
(loc (package-field-location package 'version)))
|
||||||
|
(if loc
|
||||||
|
(let ((old-version (package-version package))
|
||||||
|
(old-hash (origin-sha256 (package-source package)))
|
||||||
|
(file (and=> (location-file loc)
|
||||||
|
(cut search-path %load-path <>))))
|
||||||
|
(if file
|
||||||
|
(update-source file
|
||||||
|
old-version version
|
||||||
|
old-hash hash)
|
||||||
|
(begin
|
||||||
|
(warning (_ "~a: could not locate source file")
|
||||||
|
(location-file loc))
|
||||||
|
#f)))
|
||||||
|
(begin
|
||||||
|
(format (current-error-port)
|
||||||
|
(_ "~a: ~a: no `version' field in source; skipping~%")
|
||||||
|
(location->string (package-location package))
|
||||||
|
name)))))
|
||||||
|
|
||||||
|
;;; upstream.scm ends here
|
|
@ -23,7 +23,7 @@ guix/scripts/edit.scm
|
||||||
guix/scripts/size.scm
|
guix/scripts/size.scm
|
||||||
guix/scripts/graph.scm
|
guix/scripts/graph.scm
|
||||||
guix/scripts/challenge.scm
|
guix/scripts/challenge.scm
|
||||||
guix/gnu-maintenance.scm
|
guix/upstream.scm
|
||||||
guix/ui.scm
|
guix/ui.scm
|
||||||
guix/http-client.scm
|
guix/http-client.scm
|
||||||
guix/nar.scm
|
guix/nar.scm
|
||||||
|
|
Loading…
Reference in New Issue