ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

gnu-maintenance: Generalize, leading to (guix upstream).

Browse source 
* 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:
Ludovic Courtès 2015-10-21 11:11:25 +02:00
parent cbaf0f11dd
commit 0a7c5a09fe
5 changed files with 340 additions and 202 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -48,6 +48,7 @@ MODULES = \
guix/nar.scm \
guix/derivations.scm \
guix/gnu-maintenance.scm \
guix/upstream.scm \
guix/licenses.scm \
guix/build-system.scm \
guix/build-system/cmake.scm \

253
guix/gnu-maintenance.scm
View file

@ -29,16 +29,10 @@ (define-module (guix gnu-maintenance)
#:use-module (system foreign)
#:use-module (guix http-client)
#:use-module (guix ftp-client)
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (guix upstream)
#: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
gnu-package-mundane-name
gnu-package-copyright-holder
@ -56,21 +50,12 @@ (define-module (guix gnu-maintenance)
find-packages
gnu-package?
gnu-release?
gnu-release-package
gnu-release-version
gnu-release-directory
gnu-release-files
releases
latest-release
gnu-release-archive-types
gnu-package-name->name+version
download-tarball
package-update-path
package-update
update-package-source))
%gnu-updater))
;;; Commentary:
;;;
@ -218,13 +203,6 @@ (define (gnu-home-page? package)
;;; 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)
"Return the FTP server and directory where PROJECT's tarball are
stored."
@ -284,29 +262,6 @@ (define (tarball->version tarball)
(gnu-package-name->name+version (sans-extension tarball))))
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)
"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\"). "
@ -319,13 +274,24 @@ (define conn (ftp-open server))
(match directories
(()
(ftp-close conn)
(coalesce-releases result))
(coalesce-sources result))
((directory rest ...)
(let* ((files (ftp-list conn directory))
(subdirs (filter-map (match-lambda
((name 'directory . _) name)
(_ #f))
((name 'directory . _) name)
(_ #f))
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 "/" <>)
subdirs)
rest)
@ -335,15 +301,10 @@ (define conn (ftp-open server))
;; in /gnu/guile, filter out guile-oops and
;; guile-www; in mit-scheme, filter out binaries.
(filter-map (match-lambda
((file 'file . _)
(if (release-file? project file)
(gnu-release
(package project)
(version (tarball->version file))
(directory directory)
(files (list file)))
#f))
(_ #f))
((file 'file . _)
(and (release-file? project file)
(file->source file)))
(_ #f))
files)
result))))))))
@ -355,7 +316,7 @@ (define (latest a b)
(if (version>? a b) 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))
(define contains-digit?
@ -368,6 +329,17 @@ (define patch-directory-name?
(let-values (((server directory) (ftp-server/directory project)))
(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)
(result #f))
(let* ((entries (ftp-list conn directory))
@ -375,12 +347,12 @@ (define conn (ftp-open server))
;; Filter out sub-directories that do not contain digits---e.g.,
;; /gnuzilla/lang and /gnupg/patches.
(subdirs (filter-map (match-lambda
(((? patch-directory-name? dir)
'directory . _)
#f)
(((? contains-digit? dir) 'directory . _)
dir)
(_ #f))
(((? patch-directory-name? dir)
'directory . _)
#f)
(((? contains-digit? dir) 'directory . _)
dir)
(_ #f))
entries))
;; Whether or not SUBDIRS is empty, compute the latest releases
@ -390,19 +362,14 @@ (define conn (ftp-open server))
(releases (filter-map (match-lambda
((file 'file . _)
(and (release-file? project file)
(gnu-release
(package project)
(version
(tarball->version file))
(directory directory)
(files (list file)))))
(file->source file)))
(_ #f))
entries)))
;; Assume that SUBDIRS correspond to versions, and jump into the
;; one with the highest version number.
(let* ((release (reduce latest-release #f
(coalesce-releases releases)))
(coalesce-sources releases)))
(result (if (and result release)
(latest-release release result)
(or release result)))
@ -414,10 +381,18 @@ (define conn (ftp-open server))
(ftp-close conn)
result)))))))
(define (gnu-release-archive-types release)
"Return the available types of archives for RELEASE---a list of strings such
as \"gz\" or \"xz\"."
(map file-extension (gnu-release-files release)))
(define (latest-release* package)
"Like 'latest-release', but ignore FTP errors that might occur when PACKAGE
is not actually a GNU package, or not hosted on ftp.gnu.org, or not under that
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
;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
@ -431,121 +406,15 @@ (define (gnu-package-name->name+version name+version)
(values name+version #f)
(values (match:substring match 1) (match:substring match 2)))))
;;;
;;; Auto-update.
;;;
(define (non-emacs-gnu-package? package)
"Return true if PACKAGE is a non-Emacs GNU package. This excludes AucTeX,
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)
"Return an update path for PACKAGE, or #f if no update is needed."
(and (gnu-package? package)
(match (latest-release (package-name package))
(($ <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)))))
(define %gnu-updater
(upstream-updater 'gnu
non-emacs-gnu-package?
latest-release*))
;;; gnu-maintenance.scm ends here

27
guix/scripts/refresh.scm
View file

@ -25,7 +25,8 @@ (define-module (guix scripts refresh)
#:use-module (guix store)
#:use-module (guix utils)
#: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 (gnu packages)
#:use-module ((gnu packages commencement) #:select (%final-inputs))
@ -124,6 +125,15 @@ (define (show-help)
(newline)
(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))
"Update the source file that defines PACKAGE with the new version.
KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
@ -131,12 +141,12 @@ (define* (update-package store package #:key (key-download 'interactive))
(let-values (((version tarball)
(catch #t
(lambda ()
(package-update store package #:key-download key-download))
(package-update store package %updaters
#:key-download key-download))
(lambda _
(values #f #f))))
((loc)
(or (package-field-location package
'version)
(or (package-field-location package 'version)
(package-location package))))
(when version
(if (and=> tarball file-exists?)
@ -153,7 +163,6 @@ (define* (update-package store package #:key (key-download 'interactive))
downloaded and authenticated; not updating~%")
(package-name package) version)))))
;;;
;;; Entry point.
@ -262,14 +271,14 @@ (define core-package?
packages))))
(else
(for-each (lambda (package)
(match (false-if-exception (package-update-path package))
((new-version . directory)
(match (package-update-path package %updaters)
((? upstream-source? source)
(let ((loc (or (package-field-location package 'version)
(package-location package))))
(format (current-error-port)
(_ "~a: ~a would be upgraded from ~a to ~a~%")
(location->string loc)
(package-name package) (package-version package)
new-version)))
(_ #f)))
(upstream-source-version source))))
(#f #f)))
packages))))))

259
guix/upstream.scm Normal file
View file

@ -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

2
po/guix/POTFILES.in
View file

@ -23,7 +23,7 @@ guix/scripts/edit.scm
guix/scripts/size.scm
guix/scripts/graph.scm
guix/scripts/challenge.scm
guix/gnu-maintenance.scm
guix/upstream.scm
guix/ui.scm
guix/http-client.scm
guix/nar.scm