diff options
| -rw-r--r-- | gnu/packages.scm | 15 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 95 |
2 files changed, 84 insertions, 26 deletions
diff --git a/gnu/packages.scm b/gnu/packages.scm index 281d0d297d..c9efd0d691 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -348,13 +348,16 @@ it." #:ftp-open ftp-open* #:ftp-close (const #f)) (_ "looking for the latest release of GNU ~a...") name) - ((latest-version . _) - (when (version>? latest-version full-name) - (format (current-error-port) - (_ "~a: note: using ~a \ + ((? gnu-release? release) + (let ((latest-version + (string-append (gnu-release-package release) "-" + (gnu-release-version release)))) + (when (version>? latest-version full-name) + (format (current-error-port) + (_ "~a: note: using ~a \ but ~a is available upstream~%") - (location->string (package-location package)) - full-name latest-version))) + (location->string (package-location package)) + full-name latest-version)))) (_ #t))))) (lambda (key . args) ;; Silently ignore networking errors rather than preventing diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 7b608daea2..bfc03359ac 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -56,6 +56,12 @@ find-packages gnu-package? + gnu-release? + gnu-release-package + gnu-release-version + gnu-release-directory + gnu-release-files + releases latest-release gnu-package-name->name+version @@ -189,6 +195,13 @@ network to check in GNU's database." ;;; 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." @@ -227,9 +240,9 @@ stored." (define %alpha-tarball-rx (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) -(define (release-file project file) +(define (release-file? project file) "Return #f if FILE is not a release tarball of PROJECT, otherwise return -PACKAGE-VERSION." +true." (and (not (string-suffix? ".sig" file)) (and=> (regexp-exec %tarball-rx file) (lambda (match) @@ -237,7 +250,37 @@ PACKAGE-VERSION." (equal? project (match:substring match 1)))) (not (regexp-exec %alpha-tarball-rx file)) (let ((s (sans-extension file))) - (and (regexp-exec %package-name-rx s) s)))) + (regexp-exec %package-name-rx s)))) + +(define (tarball->version tarball) + "Return the version TARBALL corresponds to. TARBALL is a file name like +\"coreutils-8.23.tar.xz\"." + (let-values (((name version) + (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 @@ -251,7 +294,7 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). (match directories (() (ftp-close conn) - result) + (coalesce-releases result)) ((directory rest ...) (let* ((files (ftp-list conn directory)) (subdirs (filter-map (match-lambda @@ -267,10 +310,15 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). ;; in /gnu/guile, filter out guile-oops and ;; guile-www; in mit-scheme, filter out binaries. (filter-map (match-lambda - ((file 'file . _) - (and=> (release-file project file) - (cut cons <> directory))) - (_ #f)) + ((file 'file . _) + (if (release-file? project file) + (gnu-release + (package project) + (version (tarball->version file)) + (directory directory) + (files (list file))) + #f)) + (_ #f)) files) result)))))))) @@ -281,6 +329,10 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (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)) + a b)) + (define contains-digit? (cut string-any char-set:digit <>)) @@ -307,14 +359,19 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (match subdirs (() ;; No sub-directories, so assume that tarballs are here. - (let ((files (filter-map (match-lambda - ((file 'file . _) - (release-file project file)) - (_ #f)) - entries))) + (let ((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))))) + (_ #f)) + entries))) (ftp-close conn) - (and=> (reduce latest #f files) - (cut cons <> directory)))) + (reduce latest-release #f (coalesce-releases releases)))) ((subdirs ...) ;; Assume that SUBDIRS correspond to versions, and jump into the ;; one with the highest version number. @@ -346,11 +403,9 @@ open (resp. close) FTP connections; this can be useful to reuse connections." "Return an update path for PACKAGE, or #f if no update is needed." (and (gnu-package? package) (match (latest-release (package-name package)) - ((name+version . directory) - (let-values (((_ new-version) - (package-name->name+version name+version))) - (and (version>? name+version (package-full-name package)) - `(,new-version . ,directory)))) + (($ <gnu-release> name version directory) + (and (version>? version (package-version package)) + `(,version . ,directory))) (_ #f)))) (define* (download-tarball store project directory version |